*DECK CBPASS1                                                           000100
USETEXT TSBDIT,TSBTBL                                                   004280
  PRGM FTPASS1;                                                         000490
    BEGIN                                                               000120
  
  
*CALL COMHDRLEN              DEFINE ENTRY HEADER LENGTHS
  
      DEF ALIASPTR #0#;                # PNTR WORD ONE OF ALIAS ENTRY  #
      DEF AREA  #1#;                   # AREA TYPE.                    #
      DEF CWPTR #0#;
      DEF DEFINED #1#;                 # HASHED IS A REFERENCE OR DEFIN#000140
      DEF ELEMITM   #1#;                # ITEM TYPE IS ELEMENTRY.      #
      DEF F4 #8#;                      # DDLCOMP VALUE FOR FTN4        #
      DEF F5 #9#;                      # DDLCOMP VALUE FOR FTN5        #
      DEF GROUPITM   #0#;               # ITEM TYPE IS GROUP           #
      DEF ITEMS  #3#;                  # ITEM TYPE.                    #
      DEF MAXAREAS #4095#;              # MAXIMUM NUMBER OF AREAS.     #
      DEF MAXCOMBLK #500#;             # MAXIMUM NO. OF COMMON BLOCKS  #
      DEF MAXRECDS #4095#;              # MAXIMUM NUMBER OF RECORDS.   #
      DEF MAXITEMS #32767#;             # MAXIMUM NUMBER OF ITEMS.     #
      DEF MAXITMSIZ #32767#;           # MAX SIZE OF CHARACTER ITEM    #
      DEF MAXRITEMS #4095#;             # MAXIMUM ITEMS PER RECORD --  #
                                        # AS IMPOSED BY CDCS 2.0.      #
      DEF  MINSELENG    #  13#;    # MINIMUM SUB-ENTRY LENGT MAX-      #
                                       # IMUM OF EITHER AREA,RECORD,   #
                                       # ITEM,DATA CONTROL(EXCLUDING   #
                                       # FIT) OR RELATION HEADERS +    #
                                       # 3 WORDS FOR SS NAME + 3 WORDS #
                                       # FOR ALIAS NAME.               #
      DEF RECORD  #2#;                 # RECORD TYPE.                  #
      DEF REFERENCE  #0#;              # USE TO INDICATE IF NAME TO BE #000170
      DEF REPGRP   #2#;                 # ITEM TYPE IS REPEATING GROUP #
      DEF REPGRPVD   #6#;               # ITEM TYPE IS REPEATING GROUP #
                                        # OF VARIABLE DIMENSION.       #
      DEF RPGRPINRPGRP   #3#;           # ITEM TYPE IS REPEATING GROUP #
                                        # WITHIN A REPEATING GROUP.    #
      DEF SCPTR #0#;
      DEF SUBSCHPTR #15#;               # NUMBER OF CONTROL WORDS      #
      DEF VECTOR   #4#;                 # ITEM TYPE IS VECTOR.         #
      DEF VECTINRPG   #5#;              # ITEM TYPE IS VECTOR WITHIN A #
                                        # REPEATING GROUP.             #
      DEF VECTORVD   #7#;               # ITEM TYPE IS VECTOR OF VARI- #
                                        # ABLE DIMEMSION.              #
                                        # DDL VERSION NUMBER           #
      DEF DDLFVSN #"3.2"#;              # NOTE: MUST MATCH DDL3 VERSION#
                                        # OR DBMSTRD WILL ABORT        #
      XDEF
        BEGIN 
          ARRAY PICTEMP [31];              # CONTAINS THE PICTURE      #
            ITEM PICWORD U(0,0,60);       # SPECIFICATION.             #
          ITEM RECPTR;                  # POINTER USED WHEN CREATING A #
                                        # RECORD ENTRY. IT ALWAYS POINT#
                                        # TO THE FIRST WORD OF THE ENTY#
          ITEM REDEFLEVEL;             # CONTAINS THE LEVEL NUMBER OF  #
                                       # DATA-NAME-2 IN THE REDEFINES  #
                                       # CLAUSE.                       #
          ITEM REDEFPTR;               # CONTAINS THE WORD ADDRESS OF  #
                                       # THE FIRST REDEFINES ENTRY.    #
          ITEM REDEFSIZE;              # A COUNTER THAT TALLIES THE SIZ#
                                       # OF DATA-NAME-1 AND ITS SUBOR- #
                                       # DINATES. IT IS THEN COMPARED  #
                                       # AGAINST THE SIZE OF DATA-NAME2#
        END 
      XREF                                                              000180
        BEGIN                                                           000190
          ARRAY CWORD [25] S(1);       # CURRENT SYNTAX SOURCE WORD.   #
            BEGIN 
            ITEM CURWORD U(0,0,60);       # KRACKED BY CTLSCAN.        #
            ITEM CURWRD30 C(0,0,30);
            END 
          ARRAY DDLIWSA [10];             # CONTAINS THE CURRENT SOURCE#
            BEGIN                         # INPUT RECORD.              #
              ITEM IWSA C(0,0,10);
            END 
          ARRAY ENDMSG1 [5];;          # CONTAINS OUTPUT MESSAGE.      #
          ARRAY NEXWORD [25];             # CONTAINS THE NEXT SYNTAXT  #000220
            ITEM NEXWRD U(0,0,60);        # ELEMENT KRACKED BY CTLSCAN.#000230
          ITEM ABORTFLAG;              # 1=FATAL DIAGNOSTIC HAS BEEN   #
                                       # ISSUED.                       #
          ITEM CB5FLAG B;              # TRUE = COBOL 5 SUB-SCHEMA IS  #
                                       #        IS BEING COMPILED.     #
          ITEM DDLCOMP;                # CONTAINS A VALUE DESCRIBING   #001150
                                       # WHICH LANGUAGE IS BEING       #001160
                                       # PROCESSED.                    #001170
          ITEM CURLENG;                # LENGTH IN CHARACTERS OF THE   #000240
                                       # CURRENT  SOURCE WORD.         #000250
          ITEM CURLENW;                # LENGTH IN WORDS OF THE CURRENT#000260
                                       # SOURCE WORD.                  #000270
          ITEM CURP1;                  # CONTAINS A VALUE ASSOCIATED   #000280
          ITEM CURP2;                  # WITH THE CURRENT KEY WORD.    #000290
          ITEM CURTYPE;                # CONTAINS THE SYNTACTIC TYPE   #
                                       # OF CURRENT SOURCE WORD        #
          ITEM DDLDIAG;       # L #    # ADDRESS OF THE DIAG TABLE.    #000300
          ITEM DDLMEM;                 # LEFT MOST 30 BITS CONTAINS THE#
                                       # LAST WORD ADDRESS OF THE USERS#
                                       # FIELD LENGTH.                 #
          ITEM DDLSU ;                 # STORAGE USED (MIN FL NEEDED). #
          ITEM ERRCNTR;                # CONTAINS THE NUMBER OF DIAGS  #
                                       # ISSUED.                       #
          ITEM FIRSTWORD;               # CONTAINS THE FIRST WORD      #
                                        # ADDRESS OF CBWORKBUF.        #
          ITEM HDR2;                   # SPACE RESERVED FOR SUB-SCHEMA #
                                       # NAME IN THE PAGE HEADER.      #
          ITEM HDR4 ;                  # DDL VERSION.                  #
          ITEM HDR6;                   # CONTAINS THE DATE OF THE      #
                                       # SUB-SCHEMA COMPILATION.       #
          ITEM JULDAT;                 # JULIAN DTAE OF THE SUB-SCHEMA #
                                       # COMPILATION.                  #
          ITEM CRMLEV;                  #CRM VERSION                   #
          ITEM HDR3A;                   #DDL BUILD DATE                #
          ITEM LBLPTR;        #   #    # ADDRESS OF THE SUBROUTINE LIST#000310
          ITEM LBLPTRS;     # D #      # ADDRESS OF THE SUBROUTINE LIST#000320
          ITEM LEXICO;        #   #    # ADDRESS OF THE KEYWORD INDEX. #000330
          ITEM LEXICON;     # T #      # ADDRESS OF THE KEYWORD INDEX. #000340
          ITEM LEXWD;         # D #    # ADDRESS OF THE KEYWORD LIST.  #000350
          ITEM LEXWORD;     #   #      # ADDRESS OF THE KEYWORD LIST.  #000360
          ITEM LINENBR;                # CONTAINS THE SOURCE LINE NUMBR#
          ITEM MAXFL ;                 # CONTAINS THE MAXIMUM JOB      #
                                       # FIELD LENGTH THAT THE         #
                                       # OPERATING SYSTEM ALLOWS.      #
          ITEM MAXSELENG;              # CONTAINS THE MAXIMUM SUB-ENTRY#
                                       # LENGTH.                       #
          ITEM MULTSS B;               # TRUE-MULTIPLE SS PRESENT.     #
          ITEM NAMEID C(10);           # 10 CHAR SUBSCHEMA NAME, BLANK #
                                       # FILLED, LEFT JUSTIFIED.       #
          ITEM NBRLINE C(10);          # SOURCE LINE NUMBER IN DISPLAY #
                                       # CODE.                         #
          ITEM NEXLENG;                # LENGTH IN CHARACTERS OF THE   #000370
                                       # NEXT SYNTAXT ELEMENT.         #000380
          ITEM NEXLENW;                # LENGTH IN WORDS OF THE NEXT   #000390
                                       # SYNTAXT ELEMENT.              #000400
          ITEM ORDFLAG;                # 0 = DONOT PRINT ORDINAL NUMBER#
                                       # 1 = PRINT ORDINAL NUMBER.     #
          ITEM ORDNUM C(10);           # DISPLAY CODE ORDINAL NUMBER TO#
                                       # BE PRINTED.                   #
          PROC CBINDEX; 
          ITEM RELFLAG B;                # TRUE = RELATION DIVISION    #
                                         #        SPRCIFIED.           #
          ITEM REALMSZ;                # CONTAINS THE FIRST WORD ADDRES#
                                       # OF THE REALM LIST.            #
          ITEM SBSCHMA;                # CONTAINS THE FIRST WORD ADDR- #
                                       # ESS OF THE SUBSCH IN CORE.    #
          ITEM SCLFN;                  # CONTAINS THE SCHEMA LFN       #
                                       # SPECIFIED IN THE CALLING      #
                                       # SEQUENCE.                     #
          ITEM SUBSIZE;                # LENGTH OF SUBS ARRAY          #
          ITEM SUBSPTR;                # POINTER TO SUBS ARRAY         #
          ITEM SYNTBL;        # D #    # ADDRESS OF THE SYNTAX TABLE.  #000410
          ITEM SYNTBLE;     #   #      # ADDRESS OF THE SYNTAX TABLE.  #000420
          ITEM SWITCHVCTR;  #   #      # ADDRESS OF THE SWITCH VECTOR. #000430
          ITEM TRACE;         #   #    # ADDRESS OF THE TRACE TABLE.   #000440
          ITEM TRACEM;      # S #      # ADDRESS OF THE TRACE TABLE.   #000450
          PROC ABRT1;                  # ABORTS RUN BECAUSE OF INSUFIC-#
                                       # IENT FIELD LENGTH.            #
          PROC DDLABT;                 # ABORTS JOB DUE TO FATAL SYNTX #
                                       # ERRORS.                       #
          PROC ABRT3;                  # ABORTS RUN BECAUSE OF EMPTY   #
                                       # INPUT FILE.                   #
          PROC ALIASCL;                # CLOSES THE ALIAS FILE.        #
          PROC ALIASRD;                # I/O ROUTINE TO READ THE ALIAS #000460
                                       # ENTRY FROM DISK TO CORE.      #000470
          PROC ALIASRT;                # I/O ROUTINE TO WRITE THE ALIAS#000480
                                       # ENTRY FORM CORE TO DISK.      #000490
          PROC ALIASOP;                # OPENS THE ALIAS FILES.        #
          PROC CBABRT;                 # ABORTS CURRENT COMPILATION.   #
          PROC CBHASHN;                # HASHING ALGORITHYM.           #000500
          PROC CBOVLP2;                  # ALTERNATE ENTRY POINT IN    #
                                         # CBMAIN THAT WILL LOAD THE   #
                                         # SUB-SCHEMA/SCHEMA INTERFACE #
                                         # OVERLAY.                    #
          PROC CBPASS2;                # INTERFACE MODULE.             #
          PROC CBSIZE;                 # CALCULATES THE RELATIVE POSIT-#
                                       # IONS OF THE ITEMS WITHIN THE  #
                                       # RECORD.                       #
          PROC CLSEOUT;                # CLOSES THE OUTPUT FILE.       #
          PROC CLSESB;               # CLOSES THE SUB-SCHEMA FILE.     #
          PROC DCTINIT;                # ENTRY POINT IN CTLSCAN.       #
          PROC DA$DISC;                # SCHEMA DIRECTORY ACCESS ROUT- #000510
                                       # INE. GET ENTRY BY NAME AND    #000520
                                       # WORD ADDRESS OF QUALIFIER.    #000530
          PROC DE$NMSC;                # SCHEMA DIRECTORY ACCESS ROUT- #
                                       # INE. GET ENTRY BY NAME ONLY.  #000570
          PROC DE$OPSC;                # OPENS THE SCHEMA FILE AND ST- #
                                       # ORES THE 11 WORDS OF CONTROL  #
                                       # INFO INTO SCHCW (DIT).        #
          PROC DDLINIT;                # INITIAL ENTRY POINT IN CTLSCAN#000580
          PROC DDLOPSB;                # OPENS THE SUB-SCHEMA FILE.    #
          PROC DDLPRNT;                # PRINTS WHAT EVER IS IN THE  #
                                       # WORKING STORAGE AREA PASSED #
                                       # TO IT.                      #
          PROC DDLRTSB;               # I/O ROUTINE USED TO WRITE THE  #
                                      # SUB-SCHEMA TO THE WORD ADDRES#
                                      # ABLE FILE.                     #
          PROC DIAGDL;
          PROC DIAGSTD;                # ENTRY POINT IN STD THAT PROCES#000590
                                       # SES DIAGS ISSUED IN SYNGEN    #000600
                                       # SPECIFICATION.                #000610
          PROC MEMORY ;                # ISSUE FIELD LENGTH REQUEST.   #
          PROC PICTUR;                # PICTURE KRACKING ROUTINE.      #
          PROC READSC;                # I/0 ROUTINE USED TO READ THE   #
                                      # SCHEMA ENTRIES.                #
          PROC SAVSIM;
          PROC SNATCH;
          PROC SNATCHO; 
          PROC SNATCHF; 
          PROC SNATCHC; 
          PROC STDNO;                  # ENTRY POINT IN STD.           #000620
          PROC STDYES;                 # ENTRY POINT IN STD.           #000630
          PROC STD$START;              # INITIAL ENTRY POINT IN CTLSTD.#000640
          PROC WSSOUT2;                # WRITES TO SSOUT (ZZZZZS2)     #000180
          FUNC XCDD C(10);             # CONVERT INT TO DECIMAL DISP.  #000190
        END                                                             000650
                                                                        004300
# DECLARATIONS WITHIN $BEGIN AND $END BLOCKS ARE SATISFIED BY SYMPL    #004310
# TEXTS AS INDICATED IN THE USETEXT DIRECTIVE.                         #004320
                                                                        004330
      $BEGIN     # SYMPL TEXT * TSBTBL * USED                          #004340
                                                                        004350
      BASED ARRAY CBWORKBUF [0] S;
        BEGIN                                                           000670
          ITEM SBENTRYTYPE U(0,0,3);      # USED TO DETERMINE THE TYPE #000700
                                          # OF AN ENTRY THE SYMBOL     #000710
                                          # TABLE HASH ROUTINE IS      #000720
                                          # COMPARING AGAINST.         #000730
          ITEM SBENTRYNAME U(0,0,60);     # USED BY THE SYMBOL TABLE   #000740
                                          # HASH ROUTINE WHEN COMPARING#000750
                                          # NAMES IN THE SUB-SCHEMA    #000760
                                          # DIRECTORY.                 #000770
          ITEM BUFWORD U(0,0,60);         # SCRATCH ITEM USED TO REFER-#000780
                                          # ENCE WHOLE WORDS IN CBWORKB#000790
*CALL SBCWDECLS 
*CALL SUBDECLS                                                          000810
        END                                                             000820
                                                                        004370
      $END                                                              004380
                                                                        004390
      ARRAY ALIASBUF [50] S(1);           # WORKING STORAGE WHERE THE  #
        BEGIN                             # ALIAS ENTRY IS BUILT.      #000840
          ITEM ALIAS1LEN U(0,0,2);        # LENG OF ALIAS-NME-1 IN WRDS#000850
          ITEM ALIAS1CLEN U(0,2,5);       # LENG OF ALIAS-NME-1 IN CHRS#000860
          ITEM ALIAS2LEN U(0,7,2);        # LENG OF ALIAS-NME-2 IN WRDS#000870
          ITEM ALIAS2CLEN U(0,9,5);       # LENG OF ALIAS-NME-2 IN CHRS#000880
          ITEM ALIASTYPE U(0,14,2);       # 1 = REALM TYPE             #
                                          # 2 = RECORD TYPE            #
                                          # 3 = ITEM TYPE              #
          ITEM ALIAS2PTR U(0,16,3);       # OFFSET PTR TO ALIAS-NME-2. #000920
          ITEM ALIASQALPTR U(0,19,5);     # OFFSET PTR TO THE QUALIFIER#000930
                                          # LIST.                      #000940
          ITEM ALIASQALNUMB U(0,24,6);    # NUMBER OF QUALIFIERS SPECIF#000950
                                          # IED IN THE SUBJECT ALIAS   #000960
                                          # ENTRY.                     #000970
          ITEM ALIASSYNADR U(0,30,15);    # SUNONYM ADDRESS.           #000980
          ITEM ALIASNXTENT U(0,45,12);    # WORD ADDRESS OF THE NEXT   #
                                          #  ALIAS ENTRY.              #
          ITEM ALIAS1QALLG U(0,58,2);     # LENGTH IN WORDS OF THE     #
                                          #  QUALIFER FOR ALIAS NAME-1.#
                                          # ALSO USED AS A FLAG TO     #
                                          # A QUALIFER EXISTS.         #
                                          # ALIAS ENTRY.               #001000
          ITEM ALIAS1NME U(1,0,60);       # ALIAS-NME-1, 1-30 CHARACTER#
                                          # LEFT JUSTIFIED WITH ZERO   #001020
                                          # FILL.                      #001030
          ITEM ALIAS1NME30 C(1,0,30); 
          ITEM ALIAS1QALRC U(0,0,60);     # WORD ADDRESS OF THE ALIAS  #
                                          # NAME-1 QUALIFER. (SCHEMA   #
                                          # RECORD NAME)               #
          ITEM ALIAS1QAL30 C(0,0,30); 
          ITEM ALIAS2NME U(0,0,60);       # ALIAS-NME-2, 1-30 CHARACTER#
                                          # LEST JUSTIFIED WITH ZERO   #001050
                                          # FILL.                      #001060
          ITEM ALIAS2NME30 C(0,0,30); 
          ITEM ALIASLQALPTR U(0,0,9);     # OFFSET POINTER TO THE QUAL-#001070
                                          # IFIER NAME. LEFT MOST ITEM #001080
                                          # IN WORD.                   #001090
          ITEM ALIASLQALLEN U(0,9,3);     # LENGTH OF QUALIFIER NAME IN#001100
                                          # WORDS. LEFT MOST ITEM IN   #001110
                                          # WORD.                      #001120
          ITEM ALIASRQALPTR U(0,30,9);    # OFFSET POINTER TO THE QUAL-#001130
                                          # IFIER NAME. RIGHT MOST ITEM#001140
                                          # IN WORD.                   #001150
          ITEM ALIASRQALLEN U(0,39,3);    # LENGTH OF QUALIFIER NAME IN#001160
                                          # WORDS. RIGHT MOST ITEM IN  #001170
                                          # WORD.                      #001180
          ITEM ALIASQALNME U(0,0,60);     # QUALIFIER NAME, 1-30 CHAR- #
                                          # ACTERS, LEFT JUSTIFIED WITH#001200
                                          # ZERO FILL.                 #001210
          ITEM ALIASWRD U(0,0,60);        # SCRATCH ITEM DECLARATION.  #001220
        END                                                             001230
                                                                        002610
#      CLASS ARRAY IS USED BY ROUTINE ITEMEND TO OBTAIN A SWITCH VALUE #002620
#      FOR BRANCHING TO ONE OF THE ROUTINES FOLLOWING IT.              #002630
#      THE USAGE DETERMINES THE COLUMN. (VALUES LISTED AT SBITMUSAGE)  #002640
#      THE CLASS DETERMINES THE ROW. (VALUES LISTED AT SBITMCLASS)     #002650
#      (ONLY CLASSES 0-3 ARE USED. PROC PICTUR OFTEN DETERMINES CLASS.)#002660
#      THE RESULTING 2-DIGIT NUMBER IS THE SWITCH VALUE FOR THE        #002670
#      SETCLASS SWITCH.                                                #002680
      ARRAY CLASS [3];                    # THE VALUES STORED ARE INDEX#
        ITEM CDCSCLASS U(0,0,60) =        # VALUES TO A SWITCH VECTOR  #
          [O"00040512061011121212", 
           O"03031312131413121212", 
           O"02020212071411121212", 
           O"01011312131413121212"];
      ARRAY CNAME [2];                    # CONTAINS THE NAME OF AN    #001240
          ITEM CURRENTNME U(0,0,60);      # ENTRY THAT WILL BE PASSED  #001250
                                          # TO THE DIRECTORY ACCESS    #001260
                                          # ROUTINES                   #001270
      ARRAY QALNAME [40] S(1);
        BEGIN 
          ITEM QALNME U(0,0,60);
          ITEM QALADR U(3,0,18);
          ITEM QALORD U(3,18,18); 
        END 
      ARRAY HASHNME [3];
        ITEM HSHNAME U(0,0,60); 
                                                                        004410
      $BEGIN     # SYMPL TEXT *TSBDIT * USED                           #004420
                                                                        004430
      XREF ARRAY SCBUF [195];;           # CRM BUFFER FOR SC DIRECTORY #
                                          # ACCESS ROUTINES.           #
      XREF ARRAY DITSC [24] S(1); 
        BEGIN 
*CALL DITCOMSC
        END 
      BASED ARRAY REALMLIST [0] S;        # CONTAINS THE REALM NAMES   #
        BEGIN                             # AND POINTERS TO THE RECORD #
                                          # LIST AND REALM EXTRIES.    #
*CALL SBRLMLST
        END 
                                                                        004460
      $END                                                              004470
                                                                        004480
      BASED ARRAY RA [0];          # SYSTEM COMMUNICATION AREA(RA+*)   #004490
        ITEM RAWORD U(0,0,60);                                          004500
      ARRAY REDEFSTACK [30] S(1);         # STACK THAT CONTAINS REDEF- #
        BEGIN                             # INE ENTRIES THAT AREA SUB- #
                                          # ORDINATE TO A REDEFINES ENT#
          ITEM RSTACKLVL U(0,0,15);       # LEVEL NUMBER OF THE PRIOR  #
                                          # REDEFINES ENTRY.           #
          ITEM RSTACKREDA U(0,15,18);     # WORD ADDRESS OF THE REDEF- #
                                          # INES ENTRY.                #
          ITEM RSTACKWRDA U(0,33,18);     # WORD ADDRESS OF THE TARGET #
                                          # ITEM.                      #
        END 
      ARRAY REDEFINES [30] S(1);
        BEGIN 
          ITEM TARGETADDR U(0,0,18);
          ITEM REDEFADDR U(0,18,18);
          ITEM REDSIZE U(0,36,18);
          ITEM REDEFWORD U(0,0,60); 
        END 
      ARRAY SCRATCHBUF [100] S(1);        # USED AS A TEMPORARY WORKING#
        BEGIN                             # STORAGE AREA.              #001380
          ITEM SCRATCHWRD U(0,0,60);      # SCRATCH ITEM DECLARATION.  #001390
          ITEM SCRTOCCKYTY U(0,0,3);      # 2 = ASCENDING KEY.         #001400
                                          # 3 = DESCENDING KEY.        #001410
          ITEM SCRTOCCKYLC U(0,27,6);     # CONTAINS THE LENGTH OF THE #
                                          # INDEX NAME IN CHARACTERS.  #
          ITEM SCRTOCCKYLN U(0,3,3);      # LENGTH IN WORDS OF THE KEY #001420
                                          # NAME.                      #001430
          ITEM SCRTOCCKYNX U(0,6,3);      # OFFSET POINTER TO THE NEXT #001440
                                          # KEY ENTRY.                 #001450
          ITEM SCRTOCCKYNM U(1,0,60);     # KEY NAME, 1-30 CHARACTERS, #001460
                                          # LEFT JUSTIFIED WITH ZERO FL#001470
          ITEM SCRTOCCKYA U(0,9,18);      # ADDRESS OF THE SUBJECT ITEM#
                                          # WHERE THE KEY CLAUSE OR    #001490
                                          # INDEX IS DEFINED.          #001500
*CALL SCHDECLS                                                          001520
        END                                                             001530
      ARRAY SQUASHBUF [24] S(1);
        BEGIN                                                           001550
          ITEM SQWORD U(0,0,60);          # SCRATCH ITEM.              #
          ITEM SQITEMSIZE U(2,42,18);     # SIZE OF ITEM IN BITS.      #001560
          ITEM SQPOINTACTL U(5,53,1);     # 0 = ASSUMED DECIMAL POINT. #
                                          # 1 = ACTUAL DECIMAL POINT.  #
          ITEM SQPOINTLORR U(5,54,1);     # 0 = DECIMAL POINT IS TO THE#
                                          #     LEFT.                  #
                                          # 1 = DECIMAL POINT IS TO THE#
                                          #     RIGHT.                 #
          ITEM SQPOINTCONT U(5,55,5);     # POINT LOCATION COUNT.      #001630
          ITEM SQEDIT U(9,0,1);           # 1 = EDITING IS SPECIFIED.  #001640
          ITEM SQPICTURE U(10,59,1);      # 1 = PICTURE CLAUSE PRESENT.#001650
          ITEM SQEDITLENG U(10,57,3);     # EDIT MURAL LENGTH IN WORDS.#001660
          ITEM SQPICTSIZE U(11,54,6);     # PICTURE LENGTH IN CHARACTRS#001670
          ITEM SQNUMINSRTS U(09,54,6);    # NUMBER OF INSERTION CHARS. #
          ITEM SQSIGNFLG U(13,0,1);       # I = S IN PICTURE SPEC.     #
          ITEM SQCLASS U(14,56,4);        # 0 = UNSPECIFIED.           #
                                          # 1 = ALPHABETIC.            #001710
                                          # 2 = NUMERIC.               #001720
                                          # 3 = ALPHANUMERIC.          #001730
                                          # 4 THRU 7 NOT USED.         #001740
       END                                                              001750
*CALL COMSUBS 
                                                                        004520
      $BEGIN     # SYMPL TEXT * TSBTBL * USED                          #004530
                                                                        004540
      XREF
      BEGIN 
      ARRAY SYMBUF [512];                 # SYNBOL TABLE BUFFER.       #001760
        BEGIN                                                           001770
          ITEM HASHOCCUP B(0,0,1);        # TRUE = THIS ENTRY IS OCCUP-#001780
                                          #        IED.                #001790
          ITEM HASHALIASFLG B(0,1,1);     # TRUE = THERE IS AN ALIAS   #001800
                                          #        NAME ASSOCIATED WITH#001810
                                          #        THIS HAS VALUE.     #001820
          ITEM HASHALIASLEN U(0,2,3);     # LENGTH IN WORDS OF THE     #001830
                                          # ALIAS NAME.                #001840
          ITEM HASHTYPE U(0,5,4);         # ENTRY TYPE - REALM,REC,ITM #001850
          ITEM HASHALIAS1FG B(0,9,1);     # TRUE - SUBJECT SCHEMA NAME #
                                          #        HAS AN ALIAS NAME   #
                                          #        ASSOCIATED WITH IT. #
          ITEM HASHENTRY U(0,12,18);      # WORD ADDRESS OF THE ENTRY  #
                                          # WHOSE NAME HASHED TO THIS  #001870
                                          # ENTRY                      #001880
          ITEM HASHALIASENT U(0,30,18);   # WORD ADDRESS OF THE ALIAS  #
                                          # ENTRY WHOSE NAME HASHED TO #001900
        END                               # THIS ENTRY.                #001910
      END 
                                                                        004560
      $END                                                              004570
                                                                        004580
      ARRAY LITSTOR1[26] S(1);
        BEGIN 
        ITEM LITCHKC1 C(0,0,10);       # TO BE USED FOR ASCENDING     # 
                                       # ORDER TEST.                  # 
        ITEM LITCHK1 U(0,0,60);        # LITERAL1 STORED FOR COMPARE   #
         END
      ARRAY LITSTOR2[26] S(1);
        BEGIN 
        ITEM LITCHKC2 C(0,0,10);       # TO BE USED FOR ASCENDING     # 
                                       # ORDER TEST.                  # 
        ITEM LITCHK2 U(0,0,60);        # LITERAL2 STORED FOR COMPARE   #
         END
      ARRAY COBCTS[0:7];               # COBOL COLLATING SEQUENCE TABLE#
        ITEM CBLCS U(0,0,60) =
          [O"65313233343536370000",        # :ABCDEFG # 
           O"40414344454647500000",        # HIJKLMNO # 
           O"51525355565760610000",        # PQRSTUVW # 
           O"62636466677071720000",        # XYZ01234 # 
           O"73747576771722210000",        # 56789+-* # 
           O"23251520260024140000",        # /()$= ,. # 
           O"05035402270442060000",        #  []:"_ & # 
           O"07103011011213160000"];       # '?<>@\:  # 
      BASED ARRAY TGLIT;
        ITEM TGCHAR C(0,0,10);         # TARGET ARRAY FOR LIT. MOVE    #
      BASED ARRAY SRLIT;
        ITEM SRCHAR C(0,0,10);         # SOURCE ARRAY FOR LIT. MOVE    #
      ITEM ALIAS1NAME B;               # FLAG TO INDICATE THAT IT IS A #
                                       # SCHEMA NAME(ALIAS1-NAME) IN   #
                                       # THE ALIAS DIVISION.           #
      ITEM ALIASENT = 1;               # WORD ADDRESS OF THE ALIAS ENTR#
                                       # Y IN THE WORD ADDRESSABLE FILE#001930
      ITEM ALIASFLG;                   # INDICATES IF AN ENTRY HAS AN  #001940
                                       # ALIAS NAME ASSOCATED WITH IT. #001950
                                       # BITS 0-29 = INDICATES YES OR  #001960
                                       #              NO.              #001970
                                       # BITS 30-59 = IF YES CONTAINS  #001980
                                       #              THE WRD ADR OF   #001990
                                       #              ALIAS ENTRY.     #002000
      ITEM ALIASLISTP;                 # POINTER THE ALIAS QUALIFIER   #002010
                                       # LIST.                         #002020
      ITEM ALPTR;                      # THE VARIABLE POINTER USED WHEN#002060
                                       # CREATING AN ALIAS ENTRY.      #002070
      ITEM ARPTR;                      # POINTER USED WHEN CREATING AN #002080
                                       # AREA ENTRY. IT ALWAYS POINTS  #002090
                                       # TO THE FIRST WORD OF THE ENTRY#002100
      ITEM AREAORD = 1;                # COUNTER THAT MAINTAINS THE    #002110
                                       # ORDINAL NUMBER FOR AREA ENTRIE#002120
      ITEM AREAORDD C(10);             # AREA ORDINAL IN DISPLAY CODE  #000250
      ITEM ARRAYDIMS;                  # NO. OF DIMENSIONS ON ARRAY    #000500
      ITEM ARRAYLENGTH;                # SUB-TOTAL OF ARRAY ELEMENTS   #000510
      ITEM BBPOS U;                    # BEGINNING BYTE POSITION FOR   #
                                       # CHARACTER MOVE--L88 ENTRY     #
      ITEM BLANKS C(10) = "           ";
      ITEM BYTINDX U;                  # BYTE INDEX INTO COLLATING #
                                       # TABLE.                    #
      ITEM CHARFLAG B;                 # TRUE = CHARACTER DATA TYPE    #
      ITEM CHARLAST B;                 # TRUE = COMMON BLOCK IS TYPE   #
                                       # CHARACTER                     #
      ITEM COMCHAR;                    # COLUMN POS. FOR COMMON LINE   #001810
      ITEM COMCOUNT;                   # A COUNT OF THE NUMBER OF      #
                                       # COMMON BLOCKS GENERATED       #
      ITEM COMLENG;                    # NAME LENGTH FOR COMMON LINE   #001820
      ITEM DBCLASS;                    # CONTAINS DBCLASS OF FORTRAN   #
                                       # TYPES NOT FOUND IN COBOL      #
      ITEM DEFAULTLEN;                 # DEFAULT LENGTH OF CHARACTER   #
                                       # DATA TYPES                    #
      ITEM DFLAG B;                    # DIAGNOSTIC FLAG.              #
      ITEM DFLAG1 B;                   # DIAGNOSTIC FLAG FOR DIAG. 219 #
      ITEM DTEMP;                      #CONTAINS DISPLAY CODE VALUES   #
                                       # TO BE OR HAVE BEEN CONVERTED  #002160
      ITEM DITPTR;                     # POINTER USED TO INDEX THE     #002170
                                       # SCHEMA DIRECTORY INFORMATION  #002180
                                       # TABLE (ARRAY DITSC).          #002190
      ITEM DOMADR;                     # CONTAINS THE WORD ADDRESS OF  #
                                       # OF THE DOMINANT ITEM OF THE   #
                                       # SUBJECT ITEM ENTRY.           #
      ITEM DOMPTR;                     # CONTAINS THE DOMINANT ADDRESS #
                                       # USED WHEN VALIDATING THE QUAL-#
                                       # ING NAME.                     #
      ITEM DUPFLAG;                    # TRUE = DUPLICATE NAME. SET BY #002200
                                       #       HASH ROUTINE.           #002210
      ITEM ENTRYTYPE;                  # CONTAINS THE ENTRY TYPE CODE. #002220
      ITEM EOFFLAG;                    # FLAG THAT INDICATES END OF    #
                                       # SOURCE INPUT.                 #
      ITEM EXCESS B;                   # TRUE - REDEFINE ITEM SIZE IS  #
                                       #    TO BE ADJUSTED FOR SUBORD- #
                                       #    INATE REDEFINES.           #
                                       # FALSE - NO ADJUSTMENT NEEDED. #
  
      ITEM FCONST C(1);                # CONTAINS VALUE OF FIG. CONST. #
      ITEM FCVAR;                      # CONTAINS THE INDEX INTO THE   #
                                       # FIG. CONST. SWITCH VECTOR     #
      ITEM FRSTADDR;                   # CONTAINS THE BASE ADDRESS WHER#
                                       # A SEARCH FOR A VALUE BEGINS.  #
                                       # USED IN ASC-DESC KEY INDEXED. #
      ITEM FIRSTITEM;                  # CONTAINS THE WORD ADDRESS OF  #002270
                                                                        000210
                                       # SOURCE LINE TEMPLATES FOR USE #001100
                                       # IN GENERATING SSOUT FILE.     #001110
      ITEM F4IDBI C(30) =   "      INTEGER DBIXXXX";                    000270
      ITEM F5IDBI C(30) =   "      CHARACTER DBIXXXX";
      ITEM F4EDBI C(40) =   "      EQUIVALENCE (DBIXXXX,AAAAAAA)";      000280
                                       # THIS IS THE ORIGINAL FORMAT   #
                                       # OF F4CITEM. THE FORMAT MAY    #
                                       # VARY IN SOME FTN 5 SUBSCHEMAS #
      ITEM F4CITEM C(72) =  "      COMMON/DBXXXX/";                     000290
      ITEM SAVENAME C(10);             # TEMP AREA TO SAVE NAME        #000460
                                                                        000230
      ITEM HASHLENW;
                                       # THE FIRST ITEM OF A RECORD.   #002280
      ITEM HSHADDR;                    # CONTAINS THE WORD ADDRESS OF  #002290
      ITEM H;                         # SCRATCH ITEM.                 # 
                                       # AN ENTRY NAME PASSED TO THE   #002300
                                       # SYMBOL TABLE HASH ROUTINE.    #002310
      ITEM HSHNMELENW;                 # CONTAINS THE LENGTH OF THE    #002320
                                       # NAME OF THE SUBJECT SUB-SCHEMA#002330
                                       # ENTRY.                        #002340
      ITEM HSHREFDEF;                  # INDICATES TO THE HASH ROUTINE #002350
                                       # IF THE NAME TO HASHED IS A    #002360
                                       # REFERENCE OR A DEFINE.        #002370
                                       # 0 = REF.                      #002380
                                       # 1 = DEF                       #002390
      ITEM HRSLT;                      # HASH RESULT PASSED BACK BY    #002400
                                       # THE ROUTINE CBHASH.           #002410
      ITEM HSHTYPE;                    # CONTAINS THE ENTRY TYPE WHOSE #002420
                                       # NAME IS TO BE HASHED.         #002430
      ITEM HSHUNDEF;                   # 1 = NAME PASSED TO THE SYMBOL #002440
                                       #     TABLE HASH ROUTINE IS     #002450
                                       #     UNDEFINED.                #002460
      ITEM I;                          # SCRATCH ITEM.                 #002470
      ITEM I1 C(1);                    # 1ST CHAR IN ID OF COMMON BLOCK#
      ITEM I2 C(1);                    # 2ND CHAR IN ID OF COMMON BLOCK#
      ITEM INDEXCNT;                   # CONTAINS THE NUMBER OF INDEX  #
                                       # ENTRIES SPECIFIED FOR ONE     #
                                       # REPEATING GROUP.              #
      ITEM ITEMASCDESC;                # 2 = ASCENDING KEY TYPE.       #002480
                                       # 3 = DESCENDING KEY TYPE.      #002490
      ITEM ITEMCNTR;                   # CONTAINS THE TOTAL NUMBER OF  #
                                       # ITEMS DEFINED IN THE SUBSCHEMA#
      ITEM ITEMINT1;                   # CONTAINS THE FIRST INTEGER    #002500
                                       # VALUE ENCOUNTERED IN THE      #002510
                                       # OCCURS CLAUSE.                #002520
      ITEM ITEMORD = 1;                # COUNTER THAT MAINTAINS THE    #002550
                                       # ORDINAL NUMBER FOR ITEM ENTRIE#002560
      ITEM ITEMP;                      # CONTAINS BINARY VALUES TO BE  #002570
                                       # OR HAVE BEEN CONVERTED        #002580
      ITEM ITEMPTR;                    # POINTER USED WHEN CREATING AN #002590
                                       # ITEM ENTRY. IT ALWAYS POINTS  #002600
                                       # TO THE FIRST WORD OF THE ENTRY#002610
      ITEM J;                          # SCRATCH ITEM.                 #002620
      ITEM K;                          # SCRATCH ITEM.                 #002630
      ITEM L;                          # SCRATCH ITEM.                 #002640
      ITEM LASTADDR;                   # CONTAINS THE LAST ADDRESS OF  #
                                       # AN ITEM THAT WAS THE RESULT OF#
                                       # A SEARCH. USED IN OCCURS KEY  #
                                       # INDEX PROCESSING.             #
      ITEM LASTWORD;                   # CONTAINS THE LAST WORD ADDRESS#
                                       # OF SUBS ARRAY - 25. ASSUMED TO#
                                       # BE LWA OF USERS FIELD LENGTH  #
      ITEM LEFTPS;                     # SCALING FACTOR(LEFT)          #
      ITEM LITALPH1 U;
      ITEM LITALPH2 U;
      ITEM LITCTR;                     # LITERAL COUNTER               #
      ITEM LITSTART;                   # POINTER TO START OF LITERAL   #
                                       # ENTRY                         #
      ITEM L66WA;                      # CONTAINS THE WORD ADDRESS OF  #
                                       # DATA-NAME-2 OR DATA-NAME-3    #
                                       # SPECIFIED IN LEVEL 66 ITEM.   #
      ITEM L66ERRFLG B;                  # TRUE = ERROR DIAGNOSTIC HAS #
                                         #        BEEN ISSUED (196) DO-#
                                         #        NOT RE-ISSUE.        #
      ITEM M;                          # SCRATCH ITEM.                 #002650
      ITEM MVBUFFER C(30);             # BUFFER SPACE FOR LITERAL MOVE #
      ITEM N;                          # SCRATCH ITEM.                 #002660
      ITEM NEWCLINE B = TRUE;          # SWITCH FOR GENCOMMON TO START #001370
                                       # A NEW COMMON DECLARATION.     #001380
      ITEM NXCHAR C(1);                # CHARACTER FROM LITERAL        #
      ITEM OCCKEYFLAG;                 # CONTAINS THE LEVEL NUMBER OF  #
                                       # THE ITEM WHERE THE OCCURS KEY #
                                       # /INDEX IS SPECIFIED. IT IS    #
                                       # LATER REFERENCED TO DETERMINE #
                                       # WHEN THE REPEATING GROUP IS   #
                                       # COMPLETE.                     #
      ITEM ORDNBR;                     # ORDINAL NUMBER OF THE CURRENT #
                                       # ENTRY.                        #
      ITEM PICSIZ;                     # PICTURE SIZE OF FORTRAN TYPES #
                                       # NOT FOUND IN COBOL            #
      ITEM POSSIGN B;                  # SET IF LITERAL +VE            #
      ITEM PRIORAREA;                  # CONTAINS THE WORD ADDRESSOF   #002670
                                       # PREVIOUS AREA ENTRY.          #002680
      ITEM PRIORITEM;                  # CONTAINS THE WORD ADDRESS OF  #002690
                                       # THE PREVIOUS ITEM ENTRY.      #002700
      ITEM PRIORRECD;                  # CONTAINS THE WORD ADDRESS OF  #002710
                                       # THE PREVIOUS RECORD ENTRY.    #002720
      ITEM QALPTR;
      ITEM QUALNUMBER;                 # CONTAINS THE NUMBER OF QUALIFI#002730
                                       # ERS FOR AN ALIAS ENTRY.       #002740
      ITEM REALMLSTPTR;                # POINTER USED IN CREATING ENTR-#
                                       # IES IN THE REALM LIST.        #
      ITEM RECORDLENG;                # CONTAINS THE MAXIMUM RECORD    #
                                       # SPECIFIED IN THE SUB-SCHEMA.  #
      ITEM RECORDORD = 1;              # COUNTER THAT MAINTAINS THE    #002780
                                       # ORDINAL NUMBER FOR RECORD ENTR#002790
      ITEM TEMPERRCNT;                 # TEMPORARY STORAGE FOR ERROR   #
                                       # COUNT.                        #
      ITEM REDFPTR;                    # REDEFINES POINTER USED IN THE #
                                       # ARRAY REDEFINES.              #
      ITEM RIGHTPS;                    # SCALING FACTOR(RIGHT)         #
      ITEM SACPNT B;                   # SET IF DEC. PT. SPECIFIED IN  #
                                       # LITERAL--L88 ENTRY            #
      ITEM REDEFWRDA;                  # CONTAINS THE WORD ADDRESS OF  #
                                       # DATA-NAME-2.                  #
      ITEM  REDSIZEX;                  # ACCUMULATED SIZE OF REDEFINES #
                                       # ITEM THAT ARE SUBORDINATE TO  #
                                       # OTHER REDEFINES ITEMS.        #
      ITEM RSTACKPTR;                  # POINTER USED WHEN REFERENCING #
                                       # THE ARRAY REDEFSTACK.         #
      ITEM TEMPREDLVL;            # SAVES THE REDEFINES LEVEL FLAG     #
      ITEM SBNAMEADR;                  # CONTAINS THE WORD ADDRESS FO  #002830
                                       # THE NAME ENTRY OF A SUB-SCHEMA#002840
                                       # ENTRY. USED WHEN SEARCHING FOR#002850
                                       # A NAME IN THE PROC HASHTBLE.  #002860
      ITEM SBPTR;                      # CONTAINS THE WORD ADDRESS OF  #002870
                                       # ENTRY WHOSE NAME WAS PASSED TO#002880
                                       # THE SYMBOL TABLE HASH ROUTINE.#002890
      ITEM SBWRDADR;                   # CONTAINS THE WORD ADDRESS OF  #002900
                                       # A SUB-SCHEMA ENTRY WHEN SEARCH#002910
                                       # ING FOR A NAME IN THE SUB-SCHE#002920
                                       # MA. USED IN THE PROC HASNTBLE.#002930
      ITEM SCRTCHPTR;                  # VARIABLE POINTER FOR THE ARRAY#002970
                                       # SCRATCHBUF.                   #002980
      ITEM SDECPT I;                  # LOC. OF DEC. PT. IN LITERAL   # 
      ITEM SEPTR;                      # POINTS TO START OF A SUB-ENTRY#
      ITEM SFLAG B;                    # SET IF LITERAL -VE            #
      ITEM SIGDIGITS;                  # SIGNIFICANT DIGITS IN LITERAL #
      ITEM SQ;                         # POINTER INTO THE SQUASHBUF ARY#002990
      ITEM SSIGN B;                    # TRUE IF LITERAL -VE           #
      ITEM STARTRECORD B;              # TRUE WHEN START OF NEW RECORD #000350
                                       # FALSE AFTER FIRST ITEM FOUND  #000360
      ITEM SUBCOM B;                   # TRUE = COMMON BLOCK IS A      #
                                       # SECONDARY COMMON BLOCK        #
  
      ITEM TDECPT I;                   # TARGET DEC. PT. LOCATION      #
      ITEM TEMPLENG;                   # SAVES CURLENG FOR FTN ALIAS   #003580
      ITEM TEMPLENW;                   # SAVES CURLENW FOR FTN ALIAS   #003590
      ITEM TEMPWORD0;                  # SAVES CURWORD FOR FTN ALIAS   #003600
      ITEM TEMPWORD1;                  #                               #003610
      ITEM TEMPWORD2;                  #                               #003620
      ITEM THRUSPECFD B;               # SET IF THE THRU OPTION SPECIF-#
                                       # IED FOR LVL88 LITERALS.       #
      ITEM TSIGN U;                    # TRUE IF TARGET HAS SIGN SPEC. #
      ITEM USAGETYPE;                  # CONTAINS THE USAGE TYPE VALUE.#003000
                                       # SPECIFIED IN THE USAGE CLAUSE.#003010
      ITEM USESIZE;                    # SIZE OF FORTRAN TYPES NOT     #
                                       # FOUND IN COBOL                #
      ITEM WBPTR = 10;                 # POINTER IN WORKBUF THAT POINTS#
                                       # TO THE CURRECT OR VARIABLE ENT#003030
      ITEM WBPTRCNTR;                  # CONTAINS THE NUMBER OF 30 BIT #
                                       # ENTRIES CONTAINED IN THE OCCUR#
                                       # CLAUSE. IT IS THEN USED TO    #
                                       # INCREMENT WBPTR.              #
      ITEM WRDINDX U;                  # WORD INDEX INTO COLLATING #
                                       # TABLE.                    #
      ITEM ZEROFILL;                  # USED TO STORE BINARY ZEROES IN #
                                      # TO A CHARACTER FIELD.          #
      SWITCH COBOLJUMP                                                  003040
           SUBSCHNME, 
           SCHNAME, 
           ALIASTYP,                                                    003060
           ALIAS1QAL,                                                   003080
           ALIAS2QAL,                                                   003090
           ALIAS1STORNM,                                                003110
           ALIAS2STORNM,                                                003120
           ALIASINIT   ,                                                003180
           REALMALL    ,                                                003190
           REALMALIAS  ,                                                003200
           REALMNAME   ,                                                003210
           RECDNAME    ,                                                003230
           RECDWITHIN  ,                                                003240
           ITEMNAME    ,                                                003260
           ITEMDOM     ,                                                003270
           ITEM1COMP   ,                                                003300
           ITEM2COMP   ,                                                003310
           ITEMUSECK   ,                                                003340
           ITEMOC1INT  ,                                                003350
           ITEMTIMES   ,                                                003360
           ITEMOC2INT  ,                                                003370
           ITEMOCEND   ,
           LEVEL01     ,                                                003530
           ENDPASS1,
           ENDSS, 
           ABORT3,
           ITEMEND, 
           RESETCHARFLG,
           SETCHARLEN,
           SETDFLEN1, 
           SETDFLEN2, 
           CHKFTN5, 
           SETWBPTR,
           ADJWBPTR,
           SETRELFG,
           SETSSFGT,
           CHKMSS,
           ABORT4,
           INCRWBPTR,                                                   000510
           DOUBLERTN,                                                   000540
           BOOLEANRTN,                                                  001880
           CHARACTERRTN,
           COMPLEXRTN,                                                  001890
           LOGICALRTN,                                                  001900
           GENCOMMON,                                                   000550
           SETLEVEL01,                                                  000570
           RECD1STCKF,                                                  000600
           ITEMF1CKF,                                                   000610
           LEVELCONVRTF,                                                000620
           WRTCOM                                                       003120
          ,ALIASSAVENEW                                                 003130
          ,ALIASRESTNEW                                                 003140
                        ;                                               003150
                                                                        002560
                        # SWITCH SETCLASS IS USED BY ROUTINE ITEMEND,  #002570
                        # WITH SWITCH VALUE FOUND IN ARRAY CDCSCLASS.  #002580
                        # MORE INFORMATION IS AT ITEMEND AND CDCSCLASS.#002590
      SWITCH SETCLASS 
           GROUPCLAS, 
           ALPHACLAS, 
           NUMERICCLAS, 
           ALPHANMCLAS, 
           DISPUSAGE, 
           COMPUSAGE, 
           COMP1USAGE,
           PICNUMCLAS,
           COMP1USAGE,
           COMP2USAGE,
           ERROR166,
           ERROR167,
           ERROR168;
  START:                                                                003640
#**********************************************************************#003650
#                  S T A R T                                           #003660
#                                                                      #003670
#   INITIALIZES CELLS XDEFED IN CTLSTD TO THE LOCATION OF VARIOUS      #003680
#   SYNGEN TABLES.                                                     #003690
#                                                                      #003700
#**********************************************************************#003710
      ALIASOP;                         # OPEN ALIAS SCRATCH FILE       #
      P<RA> = 0;
      FIRSTWORD = RAWORD[53]; 
      SBSCHMA = FIRSTWORD + REALMSZ; # THE 1ST N  WORDS IN THE USERS   #
                                   # WORKING STORAGE IS RESERVED FOR   #
                                   # THE AREA LIST.                    #
      IF SBSCHMA GR B<0,30>DDLMEM THEN # CHECK IF THE 1ST WRD OF THE WK#
        ABRT1;    # ING STORAGE EXCEEDED THE USERS FIELD LENGTH.       #
      P<REALMLIST> = FIRSTWORD; 
      P<CBWORKBUF> = SBSCHMA; 
      LASTWORD = B<0,30>DDLMEM; # GET THE LAST WORD OF THE USERS FIELD #
                                # LENGTH.                              #
      FOR I=0 STEP 1 UNTIL LASTWORD - (FIRSTWORD+1) DO
           # ZERO OUT THE WORKING STORAGE AREA.                        #
        REALMLISTNME[I] = 0;
      LASTWORD = LASTWORD - 25;  # READJUST LASTWORD SO THAT LITERALS  #
            # AND ETC CAN BE STORED INTO AN ENTRY USING A FOR LOOP     #
            # AND BE ABLE TO DO SO WITH OUT CHECKING TO SEE IF OVERFLOW#
            # ED CORE.                                                 #
      P<SUBS> = B<0,30>DDLMEM;     # SET SUBS ARRAY TO LAST WORD OF    #
                                   # USER"S FIELD LENGTH               #
      SUBSIZE = 0;                 # INITIALIZE SIZE OF SUBS ARRAY     #
      SUBSPTR = -1;                # SKIP FIRST WORD OF SUBS SINCE IT  #
                                   # IS THE LAST WORD OF FIELD LENGTH  #
      CHECKFL;
      MAXSELENG = MINSELENG;       # INITIALIZE SUB-ENTRY LENGTH #
      DDLDIAG = LOC(DIAGSTD);                                           003720
*IF DEF,DEBUG 
      TRACE = LOC(TRACEM);                                              003730
*ENDIF
      LEXWD = LOC(LEXWORD);                                             003740
      LEXICO = LOC(LEXICON);                                            003750
      SYNTBL = LOC(SYNTBLE);                                            003760
      LBLPTR = LOC(LBLPTRS);                                            003770
      SWITCHVCTR = LOC(COBOLJUMP);                                      003780
      IF MULTSS THEN         # IF MULTIPLE SUBSCHEMAS PRESENT          #
        DCTINIT;             # CALL ALTERNATE ENTRY POINT IN CTLSCAN   #
      ELSE                   # INITIAL COMPILATION                     #
        DDLINIT;             # INITIAL ENTRY POINT IN CTLSCAN          #
      STD$START;        # INITIAL ENTRY POINT IN CTLSTD.               #003800
  ABORT3: 
#**********************************************************************#
#                  A B O R T 3                                         #
#                                                                      #
#   PRINTS THE MESSAGE - EMPTY INPUT FILE - ONTO THE DAYFILE. CLOSES   #
#   THE SUB-SCHEMA FILE AND HALTS FURTHER COMPILATIONS.                #
#                                                                      #
#**********************************************************************#
      ABRT3;
  ABORT4: 
#**********************************************************************#
#                  A B O R T 4                                         #
#                                                                      #
#     SETS UP CALL TO ABORT CURRENT COMPILATION AND GENERATE           #
#     APPROPRIATE MESSAGES TO THE OUTPUT LISTING.                      #
#**********************************************************************#
      DDLPRNT(ENDMSG1,60);         # WRITE MESSAGE TO OUTPUT FILE      #
      ALIASCL;                     # CLOSE ALIAS SCRATCH FILE          #
      CBABRT;                      # ABORT CURRENT COMPILATION         #
  ENDPASS1: 
#**********************************************************************#
#                   E N D P A S S 1                                    #
#                                                                      #
#   END OF CURRENT COMPILATION - UPDATE CONTROL WORDS AND STORAGE      #
#   USED,CLOSE FILES AND CALL ROUTINE TO LOAD THE NEXT APPLICABLE      #
#   OVERLAY,IF NO COMPILATION ERRORS. IF ERRORS,RETURNS TO STDNO.      #
#**********************************************************************#
      ALIASCL; # CLOSE THE ALIAS FILE (WORD ADDRESSABLE).              #
      SBCWSBLENG[CWPTR] = WBPTR; # SOTR WORD ADDRESS WHERE THE INDEX IS#
                             # TO BE BUILT.                            #
      SBCWNUMAREAS[CWPTR] = AREAORD - 1; # STORE THE TOTAL NUMBER OF   #
           # AREAS DEFINED INTO THE CONTROL WORD ENTRY.                #
      SBCWNUMBERCS[CWPTR] = RECORDORD - 1; # STORE THE TOTAL NUMBER OF #
           # RECORDS DEFINED INTO THE CONTROL WORD ENTRY.              #
      SBCWNUMITEMS[CWPTR] = ITEMCNTR; # STORE THE TOTAL NUMBER OF ITEMS#
           # DEFINED INTO THE CONTROL WORD ENTRY.                      #
      SBCWSBADDR[CWPTR] = 1;  # TEMPORARY CODE UNTIL DAR IS IMPLEM.    #
      IF RECORDLENG LS SBRECLENGTH[RECPTR] THEN  # RECORDLENG CONTAINS #
        RECORDLENG = SBRECLENGTH[RECPTR]; # THE LARGEST RECORD IN THE  #
                                        # SUB-SCHEMA.                  #
      SBCWMAXRECS[CWPTR] = RECORDLENG; # STORE THE LENGTH OF THE LARG- #
                                   # EST RECORD IN THE SUB-SCHEMA.     #
      SUBSIZE = ABS(SUBSPTR);      # CALCULATE LENGTH OF SUBS ARRAY    #
      IF SBSCHMA + WBPTR + SUBSIZE + 25 GR DDLSU
      THEN
        DDLSU = SBSCHMA + WBPTR + SUBSIZE + 25;  # UPDATE STORAGE USED #
      IF ABORTFLAG GR 0 AND RELFLAG THEN
        STDNO;              # ERRORS ENCOUNTERED, SKIP REMAINING SOURCE#
      IF NOT RELFLAG               # IF NO RELATION CLAUSE,            #
      THEN
        BEGIN 
        FOR SUBSPTR = -1 STEP -1 UNTIL -(SUBSIZE - 1) 
        DO
          SUBSWRD[SUBSPTR] = 0;    # ZERO OUT SUBS ARRAY               #
        I = 0;
        FOR RECPTR = SBCWFRSTRECA[0] STEP SBRECNXRECP[RECPTR] 
          WHILE I NQ SBCWNUMBERCS[0]  # LOOP THROUGH RECORD AND ITEM   #
        DO                            # ENTRIES TO ZERO OUT SUBS PTR   #
          BEGIN                       # FIELDS FOR CHECKSUMS           #
          FRSTADDR = RECPTR + SBRECNXITEMP[RECPTR]; 
          J = 0;
          FOR ITEMPTR = FRSTADDR STEP SBITMNEXTP[ITEMPTR] 
            WHILE J LQ SBRECNBRITMS[RECPTR] 
          DO
            BEGIN 
            J = J + 1;
            IF SBITMTYPE[ITEMPTR] EQ VECTOR      # IF ITEM IS A VECTOR,#
              OR SBITMTYPE[ITEMPTR] EQ VECTORVD  # ZERO OUT THE TEMP.  #
            THEN                                 # PTR TO SUBS ENTRY   #
              SBITMSUBSPTR[ITEMPTR+SBITMOCCURP[ITEMPTR]] = 0; 
            END 
          I = I + 1;
          END 
        SUBSIZE = 0;               # RESET SUBS ARRAY LENGTH TO ZERO   #
        END 
      CBOVLP2;     # CALL CBMAIN TO LOAD THE SCHEMA/SUB-SCHEMA INTER   #
                   # FACE PHASE.                                       #
  SUBSCHNME:  
#**********************************************************************#
#                                                                      #
#                  S U B S C H N M E                                   #
#                                                                      #
#   BUILDS THE SUB-SCHEMA ENTRY. STORES THE NAME AND ITS LENGTH IN     #
#   CHARACTERS AND WORDS. INDICATE SUB-SCHEMA SOURCE TYPE (FTN4 OR     #
#   FTN5). RETURN IS TO STDNO.                                         #
#                                                                      #
#**********************************************************************#
      SBSCNAMELENW[SUBSCHPTR] = CURLENW;   # LENGTH IN WORDS           #
      SBSCNAMELENC[SUBSCHPTR] = CURLENG;   # LENGTH IN CHARACTERS.     #
      FOR I=0 STEP 1 UNTIL CURLENW - 1 DO 
        SBSCHNAME[SUBSCHPTR + I] = CURWORD[I];   #SUBSCHEMA NAME.      #
      SBCWSBHDRPTR[CWPTR] = SUBSCHPTR; # OFFSET TO SUBSCH HEADER ENTRY #
      SBCWFRSTAREA[CWPTR] = SUBSCHPTR + CURLENW + 1; # STORE THE 1ST WD#
               # ADDRESS OF THE FIRST AREA ENTRY INTO THE CONTROL WORDS#
      WBPTR = SUBSCHPTR + CURLENW + 1; # POSITION THE WORKBUF POINTER  #
                                       # TO THE FIRST AREA ENTRY.      #
      CHECKFL;
      IF CURLENG GR 10 THEN 
        I = 10; 
       ELSE 
        I =CURLENG; 
      C<0,I>HDR2 = C<0,I>CURWORD[0];
      C<0,I>NAMEID = C<0,I>CURWORD[0]; #STORE SS NAME(AT MOST 10 CHARS)#
      SBCWSBSCHTME[CWPTR] = B<6,30>HDR6;  # STORE THE TIME -HH:MM-     #
      SBCWSBSCHDTE[CWPTR] = B<30,30>JULDAT; # STORE THE JULIAN DATE OF# 
                                          # THE SUB-SCHEMA COMPILATION# 
      SBCWVERSION[CWPTR] = DDLFVSN;                                     000120
      SBCWCRMVER[CWPTR] = C<0,3>CRMLEV;          #CRM VERSION          #
      SBCWBDATE[CWPTR]  =C<4,5>HDR3A;            #DDL BUILD DATE       #
  
      IF DDLCOMP EQ  F4            # IF COMPILATION LANGUAGE MODE SET  #
      THEN                         # TO FORTRAN 4                      #
        BEGIN 
        SBCWSSTYPE = "FT4";        # SET SS SOURCE TYPE TO DISPLAY FT4 #
        END 
      ELSE                         #             ELSE                  #
        BEGIN 
        SBCWSSTYPE = "FT5";        # SET SS SOURCE TYPE TO DISPLAY FT5 #
        END 
  
      STDNO;
  SCHNAME:  
#**********************************************************************#
#                                                                      #
#                  S C H N A M E                                       #
#                                                                      #
#   CHECKS IF THE SCHEMA NAME WAS SPECIFIED IN THE CALLING SEQUENCE OR #
#   THE SOURCE INPUT. THEN THE DIRECTORY ACCESS ROUTINE DA$OPSC IS CALL#
#   ED TO OPEN THE SCHEMA FILE AND STORE THE FIRST 11 WORDS OF THE     #
#   CONTROL WORDS INTO SCHCW (DIT). AFTER THE STORE OF SCHCW           #
#   A COMPARE OF THE SCHEMA NAME SPECIFIED IN THE SCHEMA CONTROL WORDS #
#   AGAINST THE SCHEMA NAME SPECIFIED IN THE SS SYNTAX TAKES PLACE.    #
#   IF THE NAMES MATCH THE SCHEMA NAME IS STORED IN TO THE SUB-SCHEMA  #
#   CONTROL WORDS AND RETURN IS TO STDYES. IF THE NAMES DONOT MATCH,   #
#   RETURN IS TO STDNO, WHERE DIAGNOSTIC 155 IS ISSUED.                #
#                                                                      #
#**********************************************************************#
      I = 0;     # INITIALIZE SCRATCH CELL.                            #
      IF SCLFN EQ 0 THEN  # CHECK IF THE SCHEMA NAME WAS SPECIFIED IN  #
                          # THE CALLING SEQUENCE. IF NOT STORE THE     #
                          # FIRST 7 CHARACTERS LEFT JUSTIFIED WITH ZERO#
        B<0,42>I  = B<0,42>CURWORD[0];  # STORE FIRST 7 CHARACTERS     #
               # OF SCHEMA NAME THAT IS SPECIFIED IN DDL SOURCE.       #
       ELSE 
        B<0,42>I = B<0,42>SCLFN;  # STORE FIRST 7 CHARACTERS OF SCHEMA #
               # NAME THAT WAS SPECIFIED IN THE CALLING SEQUENCE.      #
      DE$OPSC(I,DITSC,SCBUF,195);  # OPENS THE SCHEMA FILE AND STORES  #
           # THE 11 WORDS OF CONTROL INFO INTO SCHCW (DIT).            #
      IF SCCWSCHNAME[0] EQ 0 THEN # CHECK FOR EMPTY SCHEMA FILE.       #
        BEGIN 
          DIAGDL(169);
          STDYES; 
        END 
      SBCWSCTMEDTE[CWPTR] = SCCWSCTMEDTE[SCPTR]; # STORE THE SCHEMA    #
                           # TIME AND DATE INFO INTO THE CONTROL WORDS.#
       FOR I=0 STEP 1 UNTIL 2 DO   # COMPARE THE SCHEMA NAME IN THE    #
        BEGIN                     # SCH CNTRL WRDS AGAINST THE SCHEMA  #
          IF SCCWSCHNAME[I] NQ CURWORD[I] THEN # NAME IN CURWORD.      #
            STDNO;
        END 
      SBCWSCHEMANM[CWPTR] = CURWORD[0]; 
      SBCWSCHEMANM[CWPTR+1] = CURWORD[1]; 
      SBCWSCHEMANM[CWPTR+2] = CURWORD[2]; 
      STDYES; 
  ALIAS1QAL:                                                            003950
#**********************************************************************#003960
#                  A L I A S 1 Q A L                                   #003970
#                                                                      #003980
#   CHECKS IF THE ENTRY TYPE OF THE ALIAS-1-NAME IS ITEM. IF TRUE      #003990
#   RETURN IS TO STDYES, ELSE RETURN IS TO STDNO AND STD ISSUES DIAG-  #004000
#   NOSTIC 143.                                                        #004010
#                                                                      #004020
#**********************************************************************#004030
      IF HSHTYPE EQ ITEMS THEN                                          004040
        STDYES;                                                         004050
      STDNO;                                                            004060
  ALIAS2QAL:                                                            004070
#**********************************************************************#004080
#                  A L I A S 2 Q A L                                   #004090
#                                                                      #004100
#   CALLS THE SCHEMA DIRECTORY ACCESS ROUTINE DB$NMSC TO FIND THE      #004110
#   RECORD ENTRY THAT IS THE QUALIFER OF THE DBI. THE NINTH WORD OF    #004120
#   THE DIT CONTAINS THE WORD ADDRESS OF THE RECORD ENTRY IN THE SCHEMA#004130
#                                                                      #004140
#**********************************************************************#004150
      DE$NMSC(DITSC,1,CWORD,CURLENW,1,SCRATCHBUF);
      IF DASTATE[DITPTR] EQ 1 THEN # CHECK IF RECORD ENTRY WAS FOUND.  #
        STDNO;                        # NOT FOUND - FAILED             #004180
      FOR I=0 STEP 1 UNTIL CURLENW - 1 DO # STORE THE QUALIFER NAME    #
         # AND ITS LENGTH IN WORDS INTO THE ALIAS ENTRY.               #
        ALIAS1QALRC[ALPTR+I] = CURWORD[I];
      ALIAS1QALLG[ALIASPTR] = CURLENW;
      ALPTR = ALPTR + CURLENW;
      STDYES;                         # RECORD ENTRY.                  #004200
  ALIASTYP:                                                             004210
#**********************************************************************#004220
#                  A L I A S T Y P E                                   #004230
#                                                                      #004240
#   STORES THE P1 VALUE OF THE KEY WORDS REALM, RECORD AND DATA IN TO  #004250
#   HASHTYPE. RETURN IS TO STDNO.                                      #004260
#                                                                      #004270
#**********************************************************************#004280
                             # NOTE THAT THE P1 VALUE IS THE NUMBER IN #003170
                             # COLUMNS 46-50 OF THE SYNGEN INPUT       #003180
                             # FOLLOWING THE KEYWORD.                  #003190
      HSHTYPE = CURP1;                                                  004290
      STDNO;                                                            004300
                                                                        003210
  ALIASSAVENEW:                                                         003220
#**********************************************************************#003230
#                  A L I A S S A V E N E W                             #003240
#                                                                      #003250
#   FOR FORTRAN, SAVES THE NEW-NAME TEMPORARILY, FOR LATER PICK-UP BY  #003260
#   ALIASRESTNEW.  THIS IS DONE BECAUSE ALTHOUGH NEW-NAME IS GIVEN     #003270
#   FIRST IN FORTRAN, IT CORRESPONDS TO ALIAS-NAME-2 IN COBOL          #003280
#   PROCESSING.  RETURN IS TO STDNO.                                   #003290
#                                                                      #003300
#**********************************************************************#003310
      TEMPWORD0 = CURWORD[0];                                           003320
      TEMPWORD1 = CURWORD[1];                                           003330
      TEMPWORD2 = CURWORD[2];                                           003340
      TEMPLENW = CURLENW;                                               003350
      TEMPLENG = CURLENG;                                               003360
      STDNO;                                                            003370
                                                                        003380
  ALIAS1STORNM:                                                         004590
#**********************************************************************#004600
#                  A L I A S 1 S T O R N M                             #004610
#                                                                      #004620
#   STORES THE ALIAS-NAME-1 AND ITS LENGTH IN WORDS INTO ALIASBUF.     #004630
#   RETURN IS TO STDNO.                                                #004640
#                                                                      #004650
#**********************************************************************#004660
      FOR I=0 STEP 1 UNTIL CURLENW-1 DO   # STORE THE ALIAS-NAME-1 IN  #004670
        ALIAS1NME[ALIASPTR+I] = CURWORD[I];    # CURWORD INTO ALIASBUF.#004680
      I = (CURLENW * 10) - CURLENG; # ALIAS1NME MAY BE A KEY-WORD. KEY #
      J = 10 - I; #-WORDS ARE BLANK FILLED. THEREFORE THIS CODE WAS    #
      IF J NQ 10 THEN # NEEDED TO ZERO FILL THE ALIAS1NME.             #
        C<J,I>ALIAS1NME[ALIASPTR + (CURLENW-1)] = C<J,I>ZEROFILL; 
      ALIAS1LEN[ALIASPTR] = CURLENW;   # STORE THE LENGTH IN WORDS OF  #004690
      ALIASTYPE[ALIASPTR] = HSHTYPE;   # SOTRE ALIAS ENTRY TYPE.       #
      ALIAS1CLEN[ALIASPTR] = CURLENG; # STORE THE LENGTH IN CHARACTERS.#
      ALPTR = CURLENW + 1;             # SET THE VARIABLE POINTER TO   #004710
                                       # THE NEXT AVAILABLE WORD.      #004720
      ALIAS1NAME = TRUE;
      HASHALIAS;
      ALIAS1NAME = FALSE; 
      STDNO;                                                            004730
                                                                        003400
  ALIASRESTNEW:                                                         003410
#**********************************************************************#003420
#                  A L I A S R E S T N E W                             #003430
#                                                                      #003440
#   FOR FORTRAN, RESTORES THE NEW-NAME, SAVED BY ALIASSAVENEW, TO      #003450
#   CURWORD.  THEN PROCESSING CAN CONTINUE AS WITH ALIAS-NAME-2        #003460
#   PROCESSING IN COBOL.  RETURN IS TO STDNO.                          #003470
#                                                                      #003480
#**********************************************************************#003490
      CURWORD[0] = TEMPWORD0;                                           003500
      CURWORD[1] = TEMPWORD1;                                           003510
      CURWORD[2] = TEMPWORD2;                                           003520
      CURLENW = TEMPLENW;                                               003530
      CURLENG = TEMPLENG;                                               003540
      STDNO;                                                            003550
                                                                        003560
  ALIAS2STORNM:                                                         004740
#**********************************************************************#004750
#                  A L I A S 2 S T O R N M                             #004760
#                                                                      #004770
#   STORES THE ALIAS-NAME-2 AND ITS LENGTH INTO ALIASBUF. SETS THE     #004780
#   OFFSET POINTER TO THE LOCATION OF THE FIRST WORD OF ALIAS-NEME-2   #004790
#   IN ALIASBUF. SETS THE ALIAS FLAG AND STORES THE WORD ADDRESS OF THE#004800
#   ALIAS ENTRY INTO THE SYMBOL TABLE. RETURN IS TO STDNO.             #004810
#**********************************************************************#004820
      FOR I=0 STEP 1 UNTIL CURLENW - 1 DO   # STORE THE ALIAS-NAME-2 IN#004830
        ALIAS2NME[ALPTR+I] = CURWORD[I];    # CURWORD INTO ALIASBUF.   #004840
      ALIAS2LEN[ALIASPTR] = CURLENW;        # STORE THE LENGTH IN WORDS#004850
                                            # OF ALIAS-NAME-2 INTO     #004860
                                            # ALIASBUF.                #004870
      ALIAS2CLEN[ALIASPTR] = CURLENG; # STORE THE LENGTH IN CHARACTERS.#
      ALIAS2PTR[ALIASPTR] = ALPTR;          # STORE OFFSET POINTER TO  #004880
                                            # ALIAS-NAME-2.            #004890
      ALPTR = ALPTR + CURLENW;     # INCREMENT ALPTR TO NEXT AVAILABLE #004900
                                   # WORD.                             #004910
      HASHALIAS;   # CALL HASH ROUTINE WHICH SETS THE ALIAS FLAG AND   #004920
                   # STORES THE WORD ADDRESS OF THE SUBJECT ALIAS ENTRY#004930
                   # INTO THE SYMBOL TABLE.                            #004940
      STDNO;                                                            004950
  ALIASINIT:                                                            005930
#**********************************************************************#005940
#                  A L I A S I N I T                                   #005950
#                                                                      #005960
#   CALLS A COMPASS ROUTINE (ALIASRT) TO WRITE THE CURRENT ALIAS ENTRY #005970
#   (ALIASBUF) TO A WORD ADDRESSABLE FILE. INITIALIZES ALIAS POINTERS. #005980
#   ZEROS OUT ALIASBUF. RETURN IS TO STDNO.                            #005990
#                                                                      #006000
#**********************************************************************#006010
      ALIASRT(ALIASBUF,ALPTR,ALIASENT);   # WRITE ENTRY FROM ALIASBUF  #006020
      ALIASENT = ALIASENT + ALPTR;   # CALC NEXT LOCATION IN WORD ADDRE#006030
      FOR I=0 STEP 1 UNTIL ALPTR DO  # ZERO OUT ALIASBUF               #006060
        ALIASWRD[I] = 0;                                                006070
      ALPTR = 0;                                                        006080
      STDNO;                                                            006090
  REALMALL:                                                             006100
#**********************************************************************#006110
#                  R E A L M A L L                                     #006120
#                                                                      #006130
#   LINKS THROUGH THE SCHEMA DIRECTORY AREA ENTRIES USING THE SCHEMA   #006140
#   DIRECTORY ACCESS ROUTINES. EACH AREA ENTRY IS INDIVIDUALY READ INTO#006150
#   A SCRATCH BUFFER WHICH IS HASHED TO FORM AN ALIAS ENTRY IN THE     #
#   ALIAS TABLE. IF AN ALIAS OR A SYNONYM IS FOUND, THE ALIAS OR NEW   #
#   NAME IS STORED AS THE AREA NAME AND THE OLD IS STORED AS THE ALIAS.#
#   IF NO ALIAS IS FOUND, WE STORE ONLY THE AREA NAME.                 #
#   RETURN IS TO STDNO.                                                #
#                                                                      #006180
#**********************************************************************#006190
  
      J = SCCWFRSTAREA[DITPTR];   # GET THE ADDRESS OF THE FIRST AREA  #006200
                                  # ENTRY IN THE SCHEMA.               #006210
      IF J EQ 0 THEN  # CHECK IF THE FIRST AREA POINTER IN DIT IS ZERO.#
        BEGIN    # IF ZERO SCHEMA IS IN VALID.                         #
          DIAGDL(179);
          STDNO;
        END 
  
    REALM3:                                                             006220
  
      READSC(SCRATCHBUF,5,J);      # READ IN THE SCHEMA AREA ENTRY     #
  
      ARPTR = WBPTR;   # SET BASE AREA POINTER TO THE FIRST WORD OF THE#006240
                       # AREA ENTRY IN WORKBUF.                        #006250
      SBARTYPE[ARPTR] = AREA;   # SET ENTRY TYPE.                      #006260
      SBARORDINAL[ARPTR] = AREAORD;    # STORE AREA ORDINAL NUMBER.    #006270
  
      IF AREAORD EQ MAXAREAS+1 THEN 
        DIAGDL(202);         # MAXIMUM AREA COUNT EXCEEDED.            #
  
      CURLENW = SCHAREANAMEL[SCPTR];  # STORE AREA NAME LENGTH FOR LOOP#
      SBARNOMAPIND[ARPTR] = TRUE; # SET NO MAP INDICATOR TO DEFAULT VAL#
      AREAORD = AREAORD + 1;   # INCREMENT AREA ORDINAL COUNTER.       #006310
  
      CURWORD[0] = 0;   # ZERO OUT CURWORD.                            #
      CURWORD[1] = 0; 
      CURWORD[2] = 0; 
  
      FOR I=0 STEP 1               # STORE AREA NAME FOR HASH          #
        UNTIL CURLENW - 1 
      DO
        BEGIN 
        CURWORD[I] = SCHAREANAME[SCARNAMEPTR[SCPTR]+I]; 
        END 
  
      HSHTYPE = AREA;   # SET ENTRY TYPE FOR HASH ROUTINE.             #006380
      HSHREFDEF = DEFINED;  # SET DEFINE FLAG.                         #006390
      SBWRDADR = ARPTR;  # STORE THE WORD ADDRESS OF THE SUBJECT ENTRY #
                         # FOR THE HASH ROUTINE.                       #
      SBARPRIVPTR[ARPTR] = 0; 
  
      HASHTABLE;                   # LOCATE HASH TABLE ENTRY FOR AREA  #
  
      IF ALIASFLG GR 0 THEN # CHECK IF ALIAS NAME WAS SPECIFIED.       #
        BEGIN 
    ALIAS1:   #   # 
          ALIASRD(ALIASBUF,10,ALIASFLG); # CALL I/O ROUTINE TO READ    #
                # THE ALIAS ENTRY FROM DISK TO CORE.                   #
          ALPTR = ALIAS2PTR[ALIASPTR]; # STORE OFFSET POINTER TO ALIAS-#
                # NAME-2.                                              #
  
          CURLENG = SCHAREANAMEC[SCPTR];  # CURLENG EQUAL OLD NAME SIZE#
  
          IF CURLENG EQ ALIAS1CLEN[ALIASPTR]  # ARE SCHEMA AND OLD     #
          THEN                                # REALM NAMES SAME SIZE  #
            BEGIN 
                                   # YES, ARE THE REALM NAMES EQUAL    #
            IF C<0,CURLENG>CURWRD30[0] NQ C<0,CURLENG>ALIAS1NME30[0]
            THEN
              BEGIN 
              GOTO ALIAS2;         # IF UNEQUAL, CHECK THE SYNONYM     #
              END 
                                   # THE REALM NAME HAS BEEN ALIASED   #
                                   # SET UP THE AREA ENTRY COMPLETE    #
                                   # WITH THE ALIAS ENTRY              #
  
            SBARLENGCHAR[ARPTR] = ALIAS2CLEN[ALIASPTR];  # CHAR LENGTH #
            SBARALIASLC[ARPTR] = ALIAS1CLEN[ALIASPTR];
  
            K = ALIAS2LEN[ALIASPTR];
            L = ALIAS1LEN[ALIASPTR];
  
            SBARLENGWRDS[ARPTR] = K;  # WORD LENGTH                    #
            SBARALIASLW[ARPTR] = L; 
  
            WBPTR = WBPTR + DFSBARLG;  # SET POINTER TO THE NAME ENTRY #
            CHECKFL;               # CHECK FIELD LENGTH                #
  
            FOR I=0 STEP 1
              UNTIL K - 1          # ALIAS OR NEW NAME                 #
            DO
              BEGIN 
              SBARNAME[WBPTR+I] = ALIAS2NME[ALPTR+I]; 
              END 
  
            SBARNAMEPTR[ARPTR] = WBPTR - ARPTR;  # OFFSET POINTER-AREA #
  
            WBPTR = WBPTR + K;     # SET POINTER TO NEXT WORD AVAILABLE#
            CHECKFL;               # CHECK FIELD LENGTH                #
  
            FOR I=0 STEP 1
              UNTIL L - 1          # ALIASED OR OLD NAME               #
            DO
              BEGIN 
              SBARALIASNME[WBPTR+I] = ALIAS1NME[ALIASPTR+I];
              END 
  
            SBARALIASPTR[ARPTR] = WBPTR - ARPTR;  # OFFSET PTR - ALIAS #
  
            ALIASFLG = 0;          # RESET THE ALIAS FLAG              #
            WBPTR = WBPTR + L;     # SET POINTER TO NEXT AVAILABLE WORD#
            CHECKFL;               # CHECK FIELD LENGTH                #
            END 
  
          ELSE                     # IF THE NAMES DO NOT MATCH, CHECK  #
            BEGIN                  # TO SEE IF A SYNONYM IS PRESENT    #
  
    ALIAS2:   #   # 
              IF ALIASSYNADR[ALIASPTR] GR 0 THEN
                BEGIN 
                  ALIASFLG = ALIASSYNADR[ALIASPTR]; # STORE THE ADDRESS#
                    # OF THE ALIAS ENTRY THE HAS THE SAME HASH VALUE.  #
                  GOTO ALIAS1;
                END 
  
            ALIASFLG = 0; 
  
            GOTO NOALIAS;          # NO ALIAS EXISTS SO GO TO NO ALIAS #
  
            END 
          END 
  
        ELSE                       # IF NO ALIAS EXISTS, STORE ONLY    #
                                   # SCHEMA INFO IN THE REALM ENTRY    #
          BEGIN 
  
    NOALIAS:  
  
          SBARLENGCHAR[ARPTR] = SCHAREANAMEC[SCPTR];  # NAME CHAR LGTH #
          SBARLENGWRDS[ARPTR] = SCHAREANAMEL[SCPTR];  # NAME LENG WRDS #
          WBPTR = WBPTR + DFSBARLG;  # SET POINTER THE AREA NAME ENTRY #
          CHECKFL;                   # CHECK FIELD LENGTH              #
          SBARNAMEPTR[ARPTR] = WBPTR - ARPTR;  # AREA NAME POINTER     #
  
          FOR I=0 STEP 1
            UNTIL CURLENW - 1        # AREA NAME                       #
          DO
            BEGIN 
            SBARNAME[WBPTR+I] = SCHAREANAME[SCARNAMEPTR[SCPTR]+I];
            END 
  
          WBPTR = WBPTR + CURLENW;   # SET PNTR TO NEXT AVAILABLE WORD #
          CHECKFL;                   # CHECK FIELD LENGTH              #
          END 
  
      BUILDINDEX;   # PROC THAT BUILDS THE AREA LIST                   #006420
      J = SCARNXTAREA[SCPTR];   # GET NEXT AREA ADDRESS.               #006430
      ZEROSCRTCH(10); 
      IF J EQ 0 THEN   # CHECK IF THERE ARE MORE AREA ENTRIES.         #006440
        STDNO;                                                          006450
      SBARNEXT[ARPTR] = WBPTR; # STORE THE NEXT AREA ADDRESS.          #
      GOTO REALM3;                                                      006470
  REALMALIAS:                                                           006480
#**********************************************************************#006490
#                  R E A L M A L I A S                                 #006500
#                                                                      #006510
#   CALLS THE SYMBOL TABLE HASH ROUTINE (HASHTABLE) TO DETERMINE IF    #006520
#   THERE IS AN ALIAS NAME FOR THE SPECIFIED REALM NAME. IF AN ALIAS   #006530
#   NAME IS FOUND, A CELL CALL ALIASFLG WILL BE NON-ZERO. IF NO ALIAS  #006540
#   NAME EXISTS. PLIASFLG WILL BE ZERO. CHECK IS ALSO MADE FOR DUPLICAT#006550
#   E NAMES. IF DUPLICATE NAME IS FOUND RETURN IS TO STDNO AND DIAGNOS #006560
#   TIC 116 IS ISSUED, ELSE RETURN IS TO STDYES.                       #006570
#**********************************************************************#006580
      HSHTYPE = AREA;                                                   006590
      HSHREFDEF = DEFINED;  # SET DEFINE FLAG FOR HASH ROUTINE.        #006600
      SBWRDADR = WBPTR; 
      HASHTABLE;   # CALL HASH ROUTINE.                                #006610
      IF DUPFLAG EQ 1 THEN   # CHECK FOR DUPLICATE NAMES               #006620
        BEGIN 
          DUPFLAG = 0;
          DIAGDL( 116 );
          STDNO;
        END 
  
REALM2: 
      IF ALIASFLG GR 0 THEN          # CHECK IF THE ALIAS FLAG IS SET. #006640
        BEGIN   # FLAG WHICH WAS SET BY HASHALIAS. IF NON-ZERO THEN    #006650
                # THERE IS AN ALIAS NAME.                              #006660
    REALM1:                                                             006670
          ALIASRD(ALIASBUF,10,ALIASFLG); # CALL I/O ROUTINE TO READ THE#006680
                # ALIAS ENTRY FROM DISK TO CORE.                       #006690
          IF ALIASTYPE[ALIASPTR] NQ AREA       # IF NOT AREA TYPE      #
          THEN
            BEGIN 
            ALIASFLG = ALIASSYNADR[ALIASPTR];  # GET SYNONYM ENTRY     #
            GOTO REALM2;
  
            END 
          ALPTR = ALIAS2PTR[ALIASPTR];    # STORE OFFSET POINTER TO    #006700
                                         # ALIAS-NAME-2.               #006710
          IF CURLENG EQ ALIAS1CLEN[ALIASPTR] THEN 
            IF C<0,CURLENG>CURWRD30[0] EQ C<0,CURLENG>ALIAS1NME30[0]
            THEN   # COMPARE REALM NAME WITH ALIAS-NAME-1.             #
              BEGIN          # NAMES EQUAL, ERROR.                     #
                DIAGDL(201);
                STDYES; 
              END 
          IF CURLENG EQ ALIAS2CLEN[ALIASPTR] THEN 
            IF C<0,CURLENG>CURWRD30[0] EQ C<0,CURLENG>ALIAS2NME30[ALPTR]
            THEN   # COMPARE REALM NAME WITH ALIAS-NAME-2.             #
              STDYES;        # MATCH FOUND.                            #
          IF ALIASSYNADR[ALIASPTR] GR 0 THEN   # CHECK FOR SYNONYM LINK#006830
           BEGIN                                                        006840
              ALIASFLG = ALIASSYNADR[ALIASPTR]; # STR WRD ADDR OF THE # 
                                           # NEXT ALIAS ENTRY          #006860
              GOTO REALM1;                                              006870
            END                                                         006880
        END                                                             006890
      ALIASFLG = 0; # NO MATCH WAS FOUND. TURN OFF FLAG.               #
      STDYES; 
  REALMNAME:                                                            006920
#**********************************************************************#006930
#                  R E A L M N A M E                                   #006940
#                                                                      #006950
#   BUILDS THE AREA ENTRY. RETURN IS TO STDNO.                         #006960
#                                                                      #006970
#**********************************************************************#006980
      ARPTR = WBPTR;   # SET BASE POINTER.                             #006990
      WBPTR = WBPTR + DFSBARLG;          # SET POINTER TO FIRST WORD   #
                                         # OF VARIABLE ENTRY.          #
      CHECKFL;
      SBARNAMEPTR[ARPTR] = WBPTR - ARPTR; 
      SBARTYPE[ARPTR] = AREA;   # SET ENTRY TYPE.                      #007010
      SBARORDINAL[ARPTR] = AREAORD;   # STORE AREA ORDINAL NUMBER.     #007020
      AREAORD = AREAORD + 1;   # INCREMENT ORDINAL NUMBER.             #007030
      SBARNOMAPIND[ARPTR] = TRUE; # SET NO MAP INDICATOR TO DEFAULT VAL#
      SBARLENGWRDS[ARPTR] = CURLENW;  # STORE THE LENGTH IN WORDS.     #007040
      SBARLENGCHAR[ARPTR] = CURLENG;  # STORE THE LENGTH IN CHARACTERS.#007050
      SBARSRCLNEN[ARPTR] = LINENBR;       # STORE SOURCE LINE NUMBER.  #000820
      FOR I=0 STEP 1 UNTIL CURLENW - 1 DO                               007060
        SBARNAME[WBPTR+I] = CURWORD[I];     # STORE AREA NAME.         #
      WBPTR = WBPTR + CURLENW;
      CHECKFL;
      IF ALIASFLG NQ 0 THEN                                             007080
        BEGIN                                                           007090
          SBARALIASLC [ARPTR] = ALIAS1CLEN[ALIASPTR];   # STORE LENGTH #007100
                                  # IN CHARS OF ALIAS NAME.            #007110
          J = ALIAS1LEN[ALIASPTR];  # STORE LENGTH IN WORDS OF ALIAS-  #007120
                                   # NAME-1 INTO SCRATCH CELL.         #007130
          SBARALIASLW[ARPTR] = J;                     # STORE LENGTH IN#007140
                                  # WORDS OF ALIAS NAME.               #007150
          FOR I=0 STEP 1 UNTIL J-1 DO  # STORE THE ALIAS NAME.         #
            SBARALIASNME[WBPTR+I] = ALIAS1NME[ALIASPTR+I];
          SBARALIASPTR[ARPTR] = WBPTR - ARPTR; # STORE OFFSET PTR TO   #
                                          # ALIAS NAME.                #007190
          ALIASFLG = 0;                                                 007200
          WBPTR = WBPTR + J;   # INCREMENT POINTER TO NEXT AVAILABLE   #007210
          CHECKFL;
        END                    # WORD                                  #007220
      BUILDINDEX;   # PROC THAT BUILDS THE AREA LIST.                  #007230
      IF PRIORAREA NQ 0 THEN # CHECK IF THERE PRIOR AREA ENTRY         #
        SBARNEXT[PRIORAREA] = ARPTR; # STORE THE NEXT AREA WORD        #
                                     # ADDRESS INTO THE PRIOR AREA ENTY#
      PRIORAREA = ARPTR;             # SET POINTER TO THE LATEST AREA  #007290
                                     # ENTRY.                          #007300
      STDYES; 
  RECD1STCKF:                                                           000650
#**********************************************************************#000660
#                  R E C D 1 S T C K F                                 #000670
#                                                                      #000680
#   SETS LEVEL NUMBER TO 1 AND ENTRY TYPE TO RECORD. RETURNS TO STDYES #000690
#   BECAUSE IT IS ALWAYS A RECORD ENTRY.                               #000700
#                                                                      #000710
#**********************************************************************#000720
      STARTRECORD = TRUE;              # SET FLAG FOR START OF RECORD  #000330
      RECPTR = WBPTR;         #SET POINTER TO FIRST WORD OF ENTRY.     #000730
      ITEMP = 1;              #SET LEVEL NUMBER TO 01.                 #000740
      SBRECTYPE[RECPTR] = RECORD; #SET ENTRY TYPE TO RECORD            #000750
      SBCWFRSTRECA[CWPTR] = RECPTR; #STORE THE WORD ADDRESS OF THE     #000760
                                    #FIRST RECORD ENTRY.               #000770
      TEMPERRCNT = ERRCNTR;                                             000780
      STDYES;                 #RETURN YES                              #000790
  RECDNAME:                                                             007500
#**********************************************************************#007510
#                  R E C D N A M E                                     #007520
#                                                                      #007530
#   CALLS THE SYMBOL TABLE HASH ROUTINE (HASHTABLE) TO DETERMINE IF THE#007540
#   SUBJECT RECORD NAME IS UNIQUE AND IF THERE IS AN ALIAS NAME ASSOC- #007550
#   IATED WITH IT. THE RECORD ENTRY IS BUILT IN THIS ROUTINE. IF DUPLIC#007560
#   ATE RECORD NAMES APPEAR, THE ENTRY IS STILL BUILT AND DIAGNOSTIC   #007570
#   121 IS ISSUED, RETURN IS TO STDNO. IF RECORD NAME IS UNIQUE RETURN #007580
#   IS TO STDYES.                                                      #007590
#                                                                      #007600
#**********************************************************************#007610
      WBPTR = WBPTR + DFSBRCLG;    # INCREMENT PTR TO 1ST VARIABLE WORD#
                              # FOR THE HASH ROUTINE.                  #007630
      CHECKFL;
      SBRECNAMEPTR[RECPTR] = WBPTR - RECPTR; # STORE REC. NAME POINTER.#
      FOR I = 0 STEP 1 UNTIL CURLENW-1 DO 
        SBRECNAME[WBPTR+I] = CURWORD[I];  # STORE RECORD NAME.         #
      WBPTR = WBPTR + CURLENW;     #INCREMENT POINTER BY LENGTH OF NAME#
      CHECKFL;
      HSHREFDEF = DEFINED; # SET DEFINE FLAG FOR THE HASH ROUTINE.     #007640
      HSHTYPE = RECORD; # SET ENTRY TYPE FOR THE HASH ROUTINE.         #007650
      SBWRDADR = RECPTR;  # STORE WORD ADDRESS OF SUBJECT ENTRY INTO   #
                          # A CELL REFERENCED BY HASHTABLE.            #
      HASHTABLE;   # CALL SYMBOL TABLE HASH ROUTINE.                   #007660
      IF ALIASFLG NQ 0 THEN   # CHECK IF THERE IS AN ALIAS NAME ASSOCI-#007670
        BEGIN  # ATED WITH THIS ENTRY.                                 #007680
    RECD1:                                                              007690
          ALIASRD(ALIASBUF,10,ALIASFLG);   # CALL I/O ROUTINE TO WRITE #007700
                # ALIAS ENTRY FROM DISK TO CORE.                       #007710
          ALPTR = ALIAS2PTR[ALIASPTR];   # STORE OFFSET POINTER TO     #007720
                                         # ALIAS-NME-2.                #007730
          IF ALIASTYPE[ALIASPTR] EQ RECORD THEN # CHECK IF ALIAS TYPE  #007740
            BEGIN   # IS THE SAME AS THE SUBJECT ENTRY TYPE.           #007750
              IF CURLENG EQ ALIAS1CLEN[ALIASPTR] AND
                 C<0,CURLENG>CURWRD30[0] EQ C<0,CURLENG>ALIAS1NME30[0]
              THEN           # COMPARE RECORD NAME WITH ALIAS-NAME-1.  #
                DIAGDL(201);       # MATCH FOUND, ERROR.               #
              ELSE
                IF CURLENG EQ ALIAS2CLEN[ALIASPTR] THEN 
                  BEGIN 
                    IF C<0,CURLENG>CURWRD30[0] NQ C<0,CURLENG>
                     ALIAS2NME30[ALPTR] THEN
                      GOTO RECD2;  # NO MATCH FOUND.                   #
                  END 
                ELSE
                  GOTO RECD2; 
              J = ALIAS1LEN[ALIASPTR];  # STORE LENGTH IN WORDS OF ALIA#007810
              SBRECALIASLC[RECPTR] = ALIAS1CLEN[ALIASPTR]; # STORE LENG#007820
                               # IN CHARACTERS OF ALIAS-NAME-1.        #007830
              SBRECALIASLW[RECPTR] = J;                    # STORE LENG#007840
                               # IN WORDS OF ALIAS-NAME-1.             #007850
              SBRECALIASP[RECPTR] = WBPTR - RECPTR; # STORE OFFSET     #
                               # POINTER TO THE ALIAS ENTRY.           #007870
              FOR I=0 STEP 1 UNTIL J - 1 DO  # STORE ALIAS NAME.       #007880
                SBRECALIASNM[WBPTR+I] = ALIAS1NME[ALIASPTR+I];          007890
              WBPTR = WBPTR + J;  # INCREMENT POINTER TO THE NEXT      #007900
                                  # AVAILABLE WORD.                    #007910
      CHECKFL;
              GOTO RECD3;  # ALIAS MATCH.                              #007920
            END                                                         007930
    RECD2:                                                              007940
          IF ALIASSYNADR[ALIASPTR] GR 0 THEN   # CHECK FOR SYNONYM OR  #007950
            BEGIN   # SAME-NAME ADDRESS.                               #007960
              ALIASFLG = ALIASSYNADR[ALIASPTR]; # STORE THE WORD ADDRES#007970
                                       # OF THE NEXT ALIAS ENTRY.      #007980
              GOTO RECD1;                                               007990
            END                                                         008000
        END                                                             008010
    RECD3:                                                              008020
      SBRECORDINAL[RECPTR] = RECORDORD; # STORE RECORD ORDINAL NUMBER. #008030
      IF RECORDORD EQ MAXRECDS+1 THEN 
        DIAGDL(203);         # MAXIMUM RECORD COUNT EXCEEDED.          #
      RECORDORD = RECORDORD + 1;  # INCREMENT ORDINAL NUMBER.          #008040
      SBRECNMELENW[RECPTR] = CURLENW;  # STORE LENG IN WRDS OF REC NME.#008050
      SBRECNMELENC[RECPTR] = CURLENG;  # STORE LENG IN CHRS OF REC NME.#008060
      SBRECSRCLNEN[RECPTR] = LINENBR;       # STORE SOURCE LINE NUMBER.#000840
      IF FIRSTITEM EQ RECPTR THEN     # CHECK IF PREVIOUS RECORD ENTRY #008090
            SBRECNXITEMP [PRIORRECD] = 0; # HAD ANY ITEMS DEFINED IN IT#008100
      IF PRIORRECD NQ 0 THEN # CHECK FOR PREVIOUS RECORD SO THAT NEXT  #008110
        BEGIN  # RECORD POINTER CAN BE UPDATED.                        #008120
          SBRECNXRECP[PRIORRECD] = RECPTR - PRIORRECD; # STORE OFFSET  #008130
        END    # POINTER.                                              #008140
      PRIORRECD = RECPTR;  # UPDATE PRIOR POINTER TO CURRENT ENTRY.    #008150
      FOR I = 0 STEP 1 UNTIL 30 DO
        REDEFWORD[I] = 0; 
      REDFPTR = 0;
      IF DUPFLAG EQ 1 THEN   # CHECK IF RECORD NAME IS UNIQUE.         #008160
        BEGIN 
          DUPFLAG = 0;
          STDNO;
        END 
      STDYES;                                                           008180
  RECDWITHIN:                                                           008190
#**********************************************************************#008200
#                  R E C D W I T H I N                                 #008210
#                                                                      #008220
#   CALLS SCHEMA DIRECTORY ACCESS ROUTINE TO READ UP THE RECORD ENTRY  #008230
#   THAT CORRESPONDS TO THE SUBJECT SUB-SCHEMA RECORD ENTRY. USING THE #008240
#   ADDRESS CONTAINED IN THE WITHIN FIELD OF THE SCHEMA RECORD ENTRY,  #008250
#   ANOTHER CALL    TO THE SCHEMA DIRECTORY ACCESS ROUTINE IS MADE READ#008260
#   ING UP THE OWNER AREA. THE NAME OF THE OWNER AREA IS THEN STORED   #008270
#   IN CORE AND A COMPARE IS MADE WITH THE REALM ENTRIES IN THE SUB-SCH#008280
#   EMA. WHEN A MATCH IS FOUND THE ORDINAL NUMBER IN THE REALM ENTRY IN#008290
#   SUB-SCHEMA IS THEN STORED IN THE SUBJECT RECORD ENTRY IN THE SUB-  #008300
#   SCHEMA. RETURNS TO STDYES. IF A MATCH IS NOT FOUND RETURN IS TO    #008310
#   STDNO WHERE DIAGNOSTIC 122 IS ISSUED.                              #008320
#                                                                      #008330
#**********************************************************************#008340
      IF SBRECALIASLW[RECPTR] NQ 0 THEN  # CHECK FOR ALIAS NAME.       #
        BEGIN                                                           008360
          FOR I=0 STEP 1 UNTIL SBRECALIASLW[RECPTR] - 1 DO  # STORE THE#008370
            CURWORD[I] = SBRECALIASNM[SBRECALIASP[RECPTR]+RECPTR+I];    008380
                          # ALIAS NAME INTO CWORD WHICH WILL BE PASSED #008390
                          # TO THE DIRECTORY ACCESS ROUTINE.           #008400
          CURLENW = SBRECALIASLW[RECPTR]; # STORE LENGTH IN WORDS OF   #008410
                                          # THE ALIAS NAME.            #008420
        END                                                             008430
      IF SCCWSCHNAME[DITPTR] EQ 0 THEN # CHECK IF SCHEMA FILE EXISTS.  #
        STDNO;
      DE$NMSC(DITSC,1,CWORD,CURLENW,10,SCRATCHBUF); 
         # THE DIRECTORY ACCESS ROUTINE TO GET THE CORRESPONDING SCHEMA#008450
         # RECORD ENTRY.                                               #008460
      J = SCRWITHINA1[SCPTR];      # STORE ADDRESS OF OWNER AREA.      #
      READSC( SCRATCHBUF, 10, J ); # READ IN AREA ENTRY.               #
      J = SBCWFRSTAREA[CWPTR]; # STORE THE ADR OF 1ST AREA ENTRY IN THE#
                      # SUB-SCHEMA.                                    #008530
      K = 1; # SCRATCH CELL USED AS A COUNTER TO SEE IF THE REALM      #
             # ENTRIES HAVE BEEN SCANED.                               #
    RECD5:     # STORED IN SCRATCHBUF.                                 #008560
        IF SBARALIASLW[J] NQ 0 THEN  # CHECK IF AREA ENTRY HAS AN ALIAS#008570
          BEGIN                      # NAME.                           #008580
            I = SBARALIASLW[J];  # STORE WORD LENGTH OF ALIAS NAME.    #008590
            M = J;
            J = J + SBARALIASPTR[J]; # INCREMENT POINTER TO ALIAS NAME #
          END                                                           008620
         ELSE                                                           008630
          BEGIN                                                         008640
            I = SBARLENGWRDS[J]; # STORE WORD LENGTH OF REALM NAME.    #008650
            M = J;
            J = J + SBARNAMEPTR[J]; 
          END                                                           008660
        FOR L=0 STEP 1 UNTIL I-1 DO                                     008670
          BEGIN                                                         008680
            IF SBARNAME[J+L] NQ SCHAREANAME[SCPTR+SCARNAMEPTR[SCPTR]+L] 
              THEN
              BEGIN 
                J = SBARNEXT[M]; # STORE NEXT REALM ADDRESS.           #008720
                K = K + 1; # INCREMENT COUNTER.                        #
                IF K EQ AREAORD THEN # CHECK IF ALL THE REALM ENTRIES  #
                                     # WHERE SCANNED.                  #
                  BEGIN 
                    ZEROSCRTCH(10); 
                    STDNO;
                  END 
                GOTO RECD5;                                             008730
              END                                                       008740
          END                                                           008750
      ZEROSCRTCH(10); 
    RECD4:                                                              008800
      SBRECWITHINO[RECPTR] = SBARORDINAL[M];  # STORE AREA ORDINAL.    #
      SBRECRLMADR[RECPTR] = M; # STORE THE WORD ADDRESS OF THE OWNER   #
                               # REALM.                                #
      ARPTR = M;
      IF SBARFREC[ARPTR] THEN # IF A RECORD HAS ALREADY BEEN DEFINED   #001190
        DIAGDL(210);          # FOR THIS REALM, ISSUE DIAGNOSTIC       #001200
      SBARFREC[ARPTR]  = TRUE;# MARK RECORD DEFINED FOR THIS AREA      #001210
      SBRECNXITEMP[RECPTR] = WBPTR; # SET NEXT ITEM POINTER.           #
      FIRSTITEM = WBPTR; # STORE THE ADDRESS OF WHERE THE FIRST ITEM OF#
                         # THIS RECORD WILL BE STORED.                 #
      IWSA[9] = "** WITHIN ";  # STORE LITERAL TO BE PRINTED IN THE OUT#
      I = SBARLENGCHAR[M]; # GET THE LENGTH IN CHARACTERS OF THE REALM #
                           # NAME.                                     #
      IF I GR 7 THEN # DISPLAY ONLY THE FIRST 7 CHARACTERS OF THE REALM#
        I = 7;       # NAME.                                           #
      IWSA[10] = C<0,I>SBARNAME[M+SBARNAMEPTR[M]]; # STORE REALM NAME. #
      ORDFLAG = 1; # SET FLAG FOR PRINT ROUTINE TO PRINT REALM NAME. #
      STDYES;                                                           008850
  ITEMF1CKF:                                                            000810
#**********************************************************************#000820
#                  I T E M F 1 C K F                                   #000830
#                                                                      #000840
#   SETS LEVEL NUMBER OF ITEM TO 2. SETS UP POINTERS FOR ITEM ENTRY.   #000850
#   STORES ORDINAL LITERAL ON SOURCE RECORD. RETURNS TO STDYES.        #000860
#                                                                      #000870
#**********************************************************************#000880
      ITEMPTR = WBPTR; #SET POINTER TO 1ST WORD OF ITEM ENTRY.         #000890
      ITEMP =  2;             #SET LEVEL NUMBER TO 2.                  #000900
      SBITMLEVEL[WBPTR] = ITEMP; # STORE LEVEL NUMBER IN SQUASHBUF.    #000910
      SBRECNXITEMP[RECPTR] = ITEMPTR - RECPTR; # STORE OFFSET POINTER  #000920
                                            # TO THE FIRST ITEM ENTRY. #000930
      IWSA[9] = "** ORDINAL";                                           000940
      STDYES;                 # RETURN YES.                            #000950
  ITEMNAME:                                                             009060
#**********************************************************************#009070
#                  I T E M N A M E                                     #009080
#                                                                      #009090
#   INITIALIZES ARRAY DIMENSION COUNT FIELD.                           #000460
#   CALLS SYMBOL TABLE HASH ROUTINE TO VERIFY THAT THE ITEM NAME IS    #009100
#   UNIQUE AND TO SEE IF THERE IS AN ALIAS NAME ASSOCIATED WITH THIS   #009110
#   ENTRY. IF THE ITEM NAME IS NOT UNIQUE THE ENTRY IS IGNORED, RETURN #009120
#   IS TO STDNO. IF THE ITEM NAME IS UNIQUE. THE ITEM NAME AND IF ALIAS#009130
#   NAME EXISTS THE ALIAS NAME IS STORED INTO THE ITEM ENTRY. RETURN IS#009140
#   TO STDYES                                                          #009150
#                                                                      #009160
#**********************************************************************#009170
      ARRAYDIMS = 0;                                                    000480
      ARRAYLENGTH = 1;
      DFLAG1 = FALSE;              # INITIALIZE DIAGNOSTIC FLAG        #
      DFLAG = FALSE;
      HSHTYPE = ITEMS;                                                  009180
      HSHREFDEF = DEFINED;         # SYMBOL TABLE HASH ROUTINE.        #009190
      SBWRDADR = ITEMPTR; # STORE THE WPRD ADDRESS OF THE ITEM ENTRY   #
                          # FOR THE HASH ROUTINE.                      #
      HASHTABLE;  # CALL SYMBOL TABLE HASH ROUTINE.                    #009200
      IF DUPFLAG EQ 1 THEN  # IF ITEM IS NOT UNIQUE RETURN.            #009210
        BEGIN 
          DUPFLAG = 0;
          DIAGDL(125);
          STDNO;
        END 
      WBPTR = WBPTR + DFSBITMLG;   # INCREMENT POINTER TO THE FIRST    #
                                   # WORD OF A VARIABLE ENTRY.         #
      CHECKFL;
      FOR I = 0 STEP 1 UNTIL CURLENW-1 DO 
        SBITMNAME[WBPTR+I] = CURWORD[I];      # STORE ITEM NAME.       #
      SBITMNAMEPTR[ITEMPTR] = WBPTR - ITEMPTR;  # STORE OFFSET POINTER #
                                                # TO ITEM NAME.        #
      WBPTR = WBPTR + CURLENW;
      CHECKFL;
      IF ALIASFLG GR 0 THEN # CHECK IF THERE IS AN ALIAS NAME ASSOCIAT-#009260
        BEGIN   # WITH THIS ENTRY.                                     #009270
    ITEM1:                                                              009280
          ALIASRD(ALIASBUF,20,ALIASFLG); # CALL THE I/O ROUTINE TO READ#009290
                           # THE ALIAS ENTRY FROM DISK TO CORE.        #009300
          ALPTR = ALIAS2PTR[ALIASPTR]; # SET POINTER TO ALIAS-NME-2.   #009310
          IF ALIASTYPE[ALIASPTR] EQ ITEMS THEN # CHECK IF ALIAS ENTRY  #009320
            BEGIN  # TYPE IS THE SAME AS THE SUBJECT TYPE.             #009330
              IF CURLENG EQ ALIAS1CLEN[ALIASPTR] THEN 
                IF C<0,CURLENG>CURWRD30[0] EQ C<0,CURLENG>ALIAS1NME30[0]
                THEN  # CHECK IF ALIAS-NAME-1 IS THE SAME AS SUBJECT   #
                  BEGIN      # ITEM NAME.                              #
                    IF ALIAS1QALLG[ALIASPTR] GR 0 THEN # CHECK IF ALIAS#
                      BEGIN        # NAME-1 IS QUALIFIED.              #
                        IF SBRECALIASLW[RECPTR] EQ ALIAS1QALLG[ALIASPTR]
                        THEN       # CHECK FOR QUALIFICATION.          #
                          BEGIN 
                            IF C<0,SBRECALIASLC[RECPTR]>SBRECALIAS30
                            [RECPTR+SBRECALIASP[RECPTR]] EQ 
                            C<0,SBRECALIASLC[RECPTR]>ALIAS1QAL30[1 +
                            ALIAS1LEN[ALIASPTR]] THEN 
                              DFLAG = TRUE; # MATCH FOUND,ERROR.       #
                          END 
                        ELSE
                          IF SBRECNMELENW[RECPTR] EQ ALIAS1QALLG
                          [ALIASPTR] THEN # CHECK FOR QUALIFICATION    #
                            BEGIN  # WHEN RECORD IS NOT ALIASED.       #
                              IF C<0,SBRECNMELENC[RECPTR]>SBRECNAME30 
                               [SBRECNAMEPTR[RECPTR]+RECPTR] EQ 
                               C<0,SBRECNMELENC[RECPTR]>ALIAS1QAL30 
                               [ALIAS1LEN[ALIASPTR] + 1] THEN 
                                DFLAG = TRUE;  # MATCH FOUND,ERROR.    #
                            END 
                      END 
                    ELSE     # NO QUALIFICATION.                       #
                      DFLAG = TRUE;  # MATCH FOUND,ERROR. SET ERROR FLG#
                  END 
              IF DFLAG THEN  # IF ERROR FLAG SET,                      #
                BEGIN 
                  DIAGDL( 201 );   # ISSUE DIAGNOSTIC.                 #
                  DFLAG = FALSE;   # REINITIALIZE ERROR FLAG.          #
                  WBPTR = ITEMPTR;  # RESET VARIABLE POINTER.          #
                  STDNO;
                END 
              IF CURLENG NQ ALIAS2CLEN[ALIASPTR] OR 
                    C<0,CURLENG>CURWRD30[0] NQ C<0,CURLENG>ALIAS2NME30
                 [ALPTR] THEN      # COMPARE IF ENTRY NAME EQUALS      #
                BEGIN              # ALIAS NAME.                       #
                  IF ALIASSYNADR[ALIASPTR] GR 0 THEN   # SEARCH SYNONYM#
                    BEGIN    # CHAIN.                                  #
                      ALIASFLG = ALIASSYNADR[ALIASPTR]; 
                      GOTO ITEM1; 
                    END 
                  ALIASFLG = 0; 
                  GOTO ITEM2; 
                END 
                IF ALIASQALPTR[ALIASPTR] GR 0 THEN
                  BEGIN 
                    J = ITEMPTR;
                    M = 0;
                    K = ALIASPTR + ALIASQALPTR[ALIASPTR]; 
                    FOR I=0 STEP 1 UNTIL ALIASQALNUMB[ALIASPTR] - 1 DO
                      BEGIN 
                        L = B<M,9>ALIASWRD[K] + ALIASPTR; 
    CKDOM:   #   #
                        J = SBITMDOMADR[J]; 
                        IF J EQ RECPTR THEN 
                          BEGIN 
                            FOR N=0 STEP 1 UNTIL
                             SBRECNMELENW[RECPTR] - 1 DO
                              IF SBRECNAME[SBRECNAMEPTR[RECPTR]+RECPTR
                                 +N] NQ 
                               ALIASQALNME[L+N] THEN
                                BEGIN 
                                  ALIASFLG = 0; 
                                  GOTO ITEM2; 
                                END 
                              TEST I; 
                          END 
                          FOR N=0 STEP 1 UNTIL SBITMNELENW[J] - 1 DO
                            IF SBITMNAME[SBITMNAMEPTR[J]+J+N] NQ
                               ALIASQALNME[L+N] THEN GOTO CKDOM;
                          IF M EQ 0 THEN
                            M = 30; 
                           ELSE 
                              BEGIN 
                                M = 0;
                                K = K +1; 
                              END 
                        TEST I; 
                      END 
                  END 
                  J = ALIAS1LEN[ALIASPTR]; # STORE THE LENGTH OF ALIAS-#009490
                                           # NAME-2.                   #009500
                  FOR I=0 STEP 1 UNTIL J - 1 DO  # STORE ALIAS-NAME-1  #009510
                    SBITMALIASNM[WBPTR+I] = ALIAS1NME[ALIASPTR+I]; # IN#009520
                                           # TO THE ITEM ENTRY.        #009530
                  SBITMALIASP[ITEMPTR] = WBPTR - ITEMPTR; # STR OFFSET #
                                   # TO THE ALIAS NAME ENTRY.          #009550
                  WBPTR = WBPTR + J; # INCREMENT POINTER TO THE NEXT   #009560
                                     # AVAILABLE WORD.                 #009570
      CHECKFL;
                  SBITMALIASLW[ITEMPTR] = J; # STORE THE LENGTHS IN    #009580
                  SBITMALIASLC[ITEMPTR] = ALIAS1CLEN[ALIASPTR]; # WORDS#009590
            END                                                         009650
           ELSE                                                         009660
            BEGIN                                                       009670
              IF ALIASSYNADR[ALIASPTR] GR 0 THEN  # CHECK FOR SYNONYM  #009680
                BEGIN                             # ADDRESS.           #009690
                  ALIASFLG = ALIASSYNADR[ALIASPTR];  # STORE SYNONYM   #009700
                  GOTO ITEM1;                     # ADDRESS.           #009710
                END                                                     009720
              ALIASFLG = 0; # NO ALIAS NAME.                           #009730
            END                                                         009740
        END                                                             009750
    ITEM2:                                                              009760
      SBITMNELENW[ITEMPTR] = CURLENW;   # STORE THE WORD AND CHARACTER #009790
      SBITMNMELENC[ITEMPTR] = CURLENG;  # LENGTHS OF THE ITEM NAME.    #009800
      SBITMENTRY[ITEMPTR] = ITEMS; # SET ENTRY TYPE.                   #009810
      ORDNBR = ITEMORD;  # STORE THE ORDINAL NUMBER FOR THE CONVERSION #
                         # ROUTINE.                                    #
      ORDFLAG = 1; # SET FLAG TO INDICATE TO PRINT ORDINAL NUMBER      #
      CONVORD;  # CONVERTS THE ORDINAL NUMBER FROM BINARY TO DECIMAL   #
                # DISPLAY.                                             #
      SBITMORDINAL[ITEMPTR] = ITEMORD;  # STORE THE ORDINAL NUMBER.    #
      ITEMORD = ITEMORD + 1; # INCREMENT THE ORDINAL NUMBER.           #
      ITEMCNTR = ITEMCNTR + 1; # ADD CURRENT ITEM TO ITEM COUNT.       #
      IF ITEMCNTR EQ MAXITEMS+1 THEN
        DIAGDL(204);         # MAXIMUM ITEM COUNT EXCEEDED.            #
      IF ITEMORD EQ MAXRITEMS+1 THEN
        DIAGDL(205);         # MAXIMUM ITEMS/RECORD COUNT EXCEEDED.    #
      SBITMSRCLNEN[ITEMPTR] = LINENBR;      # STORE SOURCE LINE NUMBER.#000860
      STDYES;                                                           009820
  ITEMDOM:                                                              009830
#**********************************************************************#009840
#                  I T E M D O M                                       #009850
#                                                                      #009860
#   DETERMINES THE DOMINANT ITEM AND STORES ITS ADDRESS AND ORDINAL    #009870
#   NUMBER. RETURN IS TO STDNO.                                        #009880
#                                                                      #009890
#**********************************************************************#009900
      J = PRIORITEM;                                                    009910
      IF PRIORITEM EQ 0 THEN  # CHECK IF FIRST ITEM OF A RECORD.       #009920
        BEGIN                                                           009930
          SBITMDOMADR[ITEMPTR] = RECPTR; # STORE RECORD ENTRY ADDRESS. #009950
          DOMADR = RECPTR; # STORE THE WORD ADDRESS OF THE DOMINANT ITM#
          SBITMTYPE[ITEMPTR] = ELEMITM; # SET ITEM TYPE TO ELEMENTRY   #
                                        # ITEM.                        #
          STDYES;                                                       009960
        END                                                             009970
    ITEM3:                                                              009980
      IF SBITMLEVEL[J] EQ ITEMP THEN   # CHECK IF THE PRIOR ITEM ENTRY #009990
        BEGIN                     # HAS THE SAME LEVEL NUMBER.         #010000
          SBITMDOMADR[ITEMPTR] = SBITMDOMADR[J]; # STORE DOMINANT ADR  #010010
          SBITMDOMORD[ITEMPTR] = SBITMDOMORD[J]; # AND ORDINAL NUMBER. #
          DOMADR = SBITMDOMADR[ITEMPTR]; # STORE THE DOMINANT ADDRESS. #
          SBITMTYPE[ITEMPTR] = ELEMITM; # SET ITEM TYPE TO ELEMENTRY   #
                                        # ITEM.                        #
          GOTO CKREPDOM;
        END                                                             010040
      IF SBITMLEVEL[J] LS ITEMP THEN  # CHECK IF THE PRIOR ITEM ENTRY  #010050
        BEGIN                     # HAS SMALLER LEVEL NUMBER.          #010060
          SBITMDOMADR[ITEMPTR] = J;  # STORE DOMINANT ADDRESS AND      #010070
          DOMADR = J;   # STORE THE DOMINANT ADDRESS.                  #
          SBITMDOMORD[ITEMPTR] = SBITMORDINAL[J]; # STORE ORDINAL NO.OF#
              # DOMINANT ITEM OF THE CURRENT DOMINANT ITEM.            #
          SBITMTYPE[ITEMPTR] = ELEMITM; # CURRENT ITEM IS AN ELEMENTRY #
                                        # ITEM.                        #
        I = SBITMTYPE[J];  # STORE ITEM TYPE IN TEMP CELL  TO SAVE     #
                  # OBJECT CODE GEN IN THE CONDITION CHECKS.           #
        IF I EQ VECTINRPG THEN # IF DOMINANT ITEM IS A VECTOR IN A RE- #
                              # PEATING GROUP, CHANGE TO REPEATING     #
                              # GROUP IN A REPEATING GROUP.            #
          SBITMTYPE[J] = RPGRPINRPGRP;
       ELSE 
        IF I EQ VECTOR OR I EQ VECTORVD THEN  # IF DOMINANT ITEM IS    #
                   # A VECTOR, CHECK ALL DOMINANT ITEMS TO SEE IF THEY #
                   # ARE REPEATING GROUPS, IF SO DOMINANT ITEM WILL BE #
                   # A REPEATING GROUP IN A REPEATING GROUP, ELSE IT   #
                   # WILL BE EITHER A REPEATING GROUP OR A REPEATING   #
                   # OF VARIABLE DIMENSION.                            #
          BEGIN 
            L = SBITMDOMADR[J]; 
            FOR K=0 WHILE L NQ RECPTR DO  # SCAN BACK THRU THE DOMINAN# 
                 # ITEMS LOOKING FOR A REPEATING GROUP.                #
              BEGIN 
              IF SBITMOCCURP[L] GR 0 THEN 
                BEGIN 
                  SBITMTYPE[J] = RPGRPINRPGRP;
                  GOTO ISDOMREC;
                END 
              L = SBITMDOMADR[L]; 
              END 
            IF I EQ VECTOR THEN 
              SBITMTYPE[J] = REPGRP;
             ELSE 
              SBITMTYPE[J] = REPGRPVD;
            GOTO ISDOMREC;
          END 
         ELSE 
        IF I EQ REPGRP OR I EQ RPGRPINRPGRP OR I EQ REPGRPVD THEN 
                 # IF DOMINANT ITEM IS ALREADY TYPED AS A REPEATING    #
                 # RETURN, DOMINANT ITEM CHECKING IS COMPLETE.         #
          STDYES; 
         ELSE 
          SBITMTYPE[J] = GROUPITM;
    ISDOMREC:   #   # 
          SBITMIPICSIZ[J] = 0;
          SBITMUSESIZE[J] = 0;
          GOTO CKREPDOM;
        END                                                             010100
       K = SBITMPRIORP[J]; # GET THE PRIOR ITEM ENTRY POINTER.         #
       IF K EQ 0 THEN # CHECK IF POSITIONED AT THE FIRST ITEM ENTRY.   #
         STDNO; 
       J = J - K; 
      GOTO ITEM3;                                                       010140
#**********************************************************************#
# W A R N I N G      W A R N I N G    W A R N I N G                    #
# THE FOLLOWING CODE SEARCHES FOR A DOMINANT ITEM THAT  ARE REPEATING  #
# GROUP. IF FOUND THE ORDINAL NUMBER OF THE REPEATING GROUP IS STORED  #
# IN THE CURRENT ITEM BEING PROCESSED. THIS MEANS THAT THE ORDINAL     #
# NUMBER OF THE DOMINANT ITEM MAY DIFFER THEN THE WORD ADDRESS OF THE  #
# DOMINANT ITEM. DDL NEEDS THE ADDRESS OF THE DOMINANT ITEM HETHER ITS# 
# A REPEATING GROUP OR NOT. CDCS NEEDS THE DOMINANT ORDINAL NUMBER ONLY#
# ONLY REPEATING DOMINANT ITEMS.                                       #
#       W A R N I N G         W A R N I N G      W A R N I N G         #
#**********************************************************************#
    CKREPDOM:   #   # 
      J = SBITMDOMADR[ITEMPTR]; # GET THE DOMANINT ADDRESS.            #
      FOR I = 0 WHILE J NQ RECPTR DO
        BEGIN 
          IF SBITMTYPE[J] GR 1 THEN  # CHECK IF DOMINANT ITEM IS A     #
            BEGIN                    # REPEATING GROUP.                #
              SBITMDOMORD[ITEMPTR] = SBITMORDINAL[J];  # RESTORE THE   #
              STDYES;              # DOMINANT ITEM ORDINAL.            #
            END 
          J = SBITMDOMADR[J];      # GET NEXT DOMINANT ITEM            #
        END 
      SBITMDOMORD[ITEMPTR] = 0;    # DOMINANT ITEM IS THE RECORD ENTRY,#
      STDYES;                      # HENCE ZERO OUT THE ORDINAL FIELD. #
  ITEM1COMP:                                                            010550
#**********************************************************************#010560
#                  I T E M 1 C O M P                                   #010570
#                                                                      #010580
#   STORES THE USAGE VALUE FOR COMPUTATIONAL-1 INTO A TEMPORARY CELL.  #010590
#  RETURN IS TO STDNO.                                                 #010600
#                                                                      #010610
#**********************************************************************#010620
      USAGETYPE = 4;                                                    010630
      STDNO;                                                            010640
  ITEM2COMP:                                                            010650
#**********************************************************************#010660
#                  I T E M 2 C O M P                                   #010670
#                                                                      #010680
#   STORES THE USAGE VALUE FOR COMPUTATIONAL-2 INTO A TEMPORARY CELL.  #010690
#   RETURN IS TO STDNO.                                                #010700
#                                                                      #010710
#**********************************************************************#010720
      USAGETYPE = 6;                                                    010730
      STDNO;                                                            010740
  DOUBLERTN:                                                            001240
#**********************************************************************#001250
#                  D O U B L E R T N                                   #001260
#                                                                      #001270
#   STORES THE USAGE VALUE FOR FTN-ONLY TYPES INTO A TEMPORARY CELL.   #001920
#   FOR A FORTRAN DOUBLE PRECISION ITEM, SET DBMS CLASS TO 14          #001930
#   AND USAGE SIZE TO 20.  RETURN IS TO STDNO.                         #001940
#                                                                      #001310
#**********************************************************************#001320
      USAGETYPE = 0;                                                    001960
      DBCLASS = 14; 
      USESIZE = 20; 
      PICSIZ = 1;             # DEFAULT PICTURE SIZE IS 1 (MINIMUM)    #
      STDNO;                  # RETURN TO STDNO.                       #001360
                                                                        002010
  BOOLEANRTN:                                                           002020
#**********************************************************************#002030
#                  B O O L E A N R T N                                 #002040
#                                                                      #002050
#   STORES THE USAGE VALUE FOR FTN-ONLY TYPES INTO A TEMPORARY CELL.   #002060
#   FOR A FORTRAN BOOLEAN ITEM, SET DBMS CLASS TO 18                   #002070
#   AND USAGE SIZE TO 10.  RETURN IS TO STDNO.                         #002080
#                                                                      #002090
#**********************************************************************#002100
      IF DDLCOMP EQ F4        # IF THIS IS A FTN 4 SUBSCHEMA,          #002110
      THEN
        DIAGDL(220);          # TYPE BOOLEAN IS NOT VALID.             #
      USAGETYPE = 0;                                                    002130
      DBCLASS = 18; 
      USESIZE = 10; 
      PICSIZ = 1;             # DEFAULT PICTURE SIZE IS 1 (MINIMUM)    #
      STDNO;                  # RETURN IS TO STDNO.                    #002170
  
  CHARACTERRTN: 
#**********************************************************************#
#                     C H A R A C T E R R T N                          #
#                                                                      #
#   IF THIS IS A FTN 4 SUBSCHEMA, RETURN IS TO STDNO.  SET FLAG TO     #
#   INDICATE CHARACTER DATA TYPE.  RETURN IS TO STDYES.                #
#                                                                      #
#**********************************************************************#
      USAGETYPE = 0;
      CHARFLAG = TRUE;
      IF DDLCOMP EQ F4             # TYPE CHARACTER NOT ALLOWED IN FTN4#
      THEN
        STDNO;
      STDYES; 
                                                                        002180
  COMPLEXRTN:                                                           002190
#**********************************************************************#002200
#                  C O M P L E X R T N                                 #002210
#                                                                      #002220
#   STORES THE USAGE VALUE FOR FTN-ONLY TYPES INTO A TEMPORARY CELL.   #002230
#   FOR A FORTRAN COMPLEX ITEM, SET DBMS CLASS TO 15                   #002240
#   AND USAGE SIZE TO 20.  RETURN IS TO STDNO.                         #002250
#                                                                      #002260
#**********************************************************************#002270
      USAGETYPE = 0;                                                    002280
      DBCLASS = 15; 
      USESIZE = 20; 
      PICSIZ = 1;             # DEFAULT PICTURE SIZE IS 1 (MINIMUM)    #
      STDNO;                  # RETURN IS TO STDNO.                    #002320
                                                                        002330
  LOGICALRTN:                                                           002340
#**********************************************************************#002350
#                  L O G I C A L R T N                                 #002360
#                                                                      #002370
#   STORES THE USAGE VALUE FOR FTN-ONLY TYPES INTO A TEMPORARY CELL.   #002380
#   FOR A FORTRAN LOGICAL ITEM, SET DBMS CLASS TO 17                   #002390
#   AND USAGE SIZE TO 10.  RETURN IS TO STDNO.                         #002400
#                                                                      #002410
#**********************************************************************#002420
      USAGETYPE = 0;                                                    002430
      DBCLASS = 17; 
      USESIZE = 10; 
      PICSIZ = 1;             # DEFAULT PICTURE SIZE IS 1 (MINIMUM)    #
      STDNO;                  # RETURN IS TO STDNO.                    #002470
                                                                        002480
  ITEMUSECK:                                                            010950
#**********************************************************************#010960
#                  I T E M U S E C K                                   #010970
#                                                                      #010980
#   CHECK THE DOMINANT ITEM TO SEE IF THE USAGE CLAUSE WAS SPECIFIED   #010990
#   IN A GROUP ITEM. IF USAGE TYPE WAS SPECIFIED IN A GROUP            #011000
#   ITEM, A COMPARE IS MADE TO DETERMINE IF THE USAGE TYPES ARE THE    #011010
#   SAME. IF THE USAGE TYPES ARE NOT SAME, THE TYPE SPECIFIED IN THE   #011020
#   GROUP ITEM IS STORED AND RETURN IS TO STDNO WHERE DIAGNOSTIC 129   #011030
#   IS ISSUED. IF USAGE TYPE WAS NOT SPECIFIED IN THE GROUP ITEM, THE  #011040
#   VALUE STORED IN A TEMPORARY CELL IS STORED IN THE USAGE FIELD OF   #011050
#   THE SUBJECT ENTRY AND RETURN IS TO STDYES.                         #011060
#                                                                      #011070
#**********************************************************************#011080
      SBITMUSAGE[ITEMPTR] = USAGETYPE; # STORE USAGE TYPE.             #011210
      STDYES;                                                           011220
  ITEMOC1INT:                                                           011230
#**********************************************************************#011240
#                  I T E M O C 1 I N T                                 #011250
#                                                                      #011260
#   INCREMENTS NUMBER OF DIMENSIONS.  CHECKS IF THE MAXIMUM NUMBER OF  #
#   DIMENSIONS IS EXCEEDED AND IF SO, ISSUES DIAGNOSTIC 133 AND SETS   #
#   THE DIMENSION COUNT TO A VERY LOW NUMBER SO THIS DIAGNOSTIC WILL   #
#   NOT BE ISSUED MORE THAN ONCE.  CONVERTS FIRST BOUND OF DIMENSION   #
#   TO BINARY AND STORES IT INTO A TEMPORARY CELL.                     #
#   RETURN IS TO STDYES.                                               #
#                                                                      #011290
#**********************************************************************#011300
      ARRAYDIMS = ARRAYDIMS + 1;
      IF DDLCOMP EQ F5 AND ARRAYDIMS GR 7    # ERROR IF MORE THAN 7    #
        OR DDLCOMP EQ F4 AND ARRAYDIMS GR 3  # DIMS. IN FTN5 OR MORE   #
      THEN                                   # THAN 3 DIMS. IN FTN4    #
        BEGIN 
        DIAGDL(133);
        ARRAYDIMS = -500;          # SET TO VERY SMALL NO. SO THIS DIAG#
                                   # WILL NOT BE ISSUED MORE THAN ONCE #
        END 
      NXCHAR = C<0>CURWORD[0];     # CHECK FIRST CHARACTER OF SUBSCRIPT#
      IF NXCHAR EQ "-"             # IF SUBSCRIPT IS NEGATIVE,         #
      THEN
        BEGIN 
        SFLAG = TRUE;              # SET NEGATIVE FLAG TO TRUE         #
        C<0,10>DTEMP = C<1,9>CURWORD[0];  # STRIP OFF SIGN WHEN        #
                                   # CONVERTING TO BINARY.             #
        END 
      ELSE
        BEGIN                      # SUBSCRIPT IS POSITIVE             #
        SFLAG = FALSE;             # SET NEGATIVE FLAG TO FALSE        #
        DTEMP = CURWORD[0]; 
        END 
      DISPDECTOBIN;                # CONVERT DISPLAY NUMBER TO BINARY  #
      SEPTR = WBPTR;               # SET SUB-ENTRY POINTER             #
      IF SFLAG                     # IF SUBSCRIPT WAS NEGATIVE         #
      THEN
        ITEMINT1 = -ITEMP;         # RESTORE NEGATIVE VALUE            #
      ELSE
        ITEMINT1 = ITEMP;          # STORE BINARY VALUE IN TEMP ITEM   #
      DTEMP = O"55";               # INITIALIZE DTEMP                  #
      STDYES;                                                           011370
  ITEMTIMES:                                                            011380
#**********************************************************************#011390
#                  I T E M T I M E S                                   #011400
#                                                                      #011410
#   STORES ARRAY LENGTH AND POINTER TO SUBS ENTRY IN THE OCCURS ENTRY. #
#   STORES OFFSET POINTER TO THE OCCURS ENTRY IN THE HEADER WORDS OF   #
#   THE CURRENT ITEM ENTRY. STORES NUMBER OF DIMENSIONS IN FIRST WORD  #
#   OF SUBS ENTRY.  RETURN IS TO STDNO.                                #
#                                                                      #011450
#**********************************************************************#011460
      SBITMHIBNDS[WBPTR] = ARRAYLENGTH;  # STORE ARRAY LENGTH          #
      SBITMSUBSPTR[WBPTR] = ABS(SUBSPTR + ARRAYDIMS);  # STORE PTR TO  #
                                                       # SUBS ENTRY    #
      SBITMOCCURP[ITEMPTR] = WBPTR - ITEMPTR;  # STORE OFFSET PTR TO   #
                                               # OCCURS ENTRY          #
      SUBSDIM[SUBSPTR + ARRAYDIMS] = ARRAYDIMS;  # STORE NO. OF DIMS.  #
      WBPTR = WBPTR + 1;
      CHECKFL;
      SBITMTYPE[ITEMPTR] = VECTOR;  # ITEM ENTRY IS A VECTOR.          #
      STDNO;                                                            011500
  ITEMOC2INT:                                                           011510
#**********************************************************************#011520
#                  I T E M O C 2 I N T                                 #011530
#                                                                      #011540
#   CHECKS IF THE SECOND BOUND IS USED FOR FTN4 AND IF SO, ISSUES      #
#   DIAGNOSTIC 219 AND SETS A FLAG SO THIS DIAGNOSTIC WILL NOT BE      #
#   ISSUED MORE THAN ONCE. CONVERTS 2ND BOUND OF DIMENSION TO BINARY.  #
#   STORES THE HIGH AND LOW BOUNDS IN THE SUBS ARRAY.  CHECKS IF THE   #
#   LOW BOUND IS GREATER THAN THE HIGH BOUND AND IF SO, ISSUES DIAG.   #
#   131 AND RETURNS TO STDYES.  UPDATES ARRAY LENGTH.  RETURN IS TO    #
#   STDYES.                                                            #
#                                                                      #011620
#**********************************************************************#011630
      IF DDLCOMP EQ F4             # IF THIS IS A FTN 4 SUBSCHEMA,     #
      THEN                         # ERROR IF FTN 5 FEATURE USED       #
        IF NOT DFLAG1              # IF THIS DIAGNOSTIC HAS NOT BEEN   #
        THEN                       # PREVIOUSLY ISSUED FOR THIS ARRAY, #
          BEGIN 
          DIAGDL(219);             # ISSUE DIAGNOSTIC, AND SET FLAG TO #
          DFLAG1 = TRUE;           # INDICATE THE DIAGNOSTIC WAS ISSUED#
          END 
      NXCHAR = C<0>CURWORD[0];     # CHECK FIRST CHARACTER OF SUBSCRIPT#
      IF NXCHAR EQ "-"             # IF SUBSCRIPT IS NEGATIVE,         #
      THEN
        BEGIN 
        SFLAG = TRUE;              # SET NEGATIVE FLAG TO TRUE         #
        C<0,10>DTEMP = C<1,9>CURWORD[0];  # STRIP OFF SIGN WHEN        #
                                   # CONVERTING TO BINARY.             #
        END 
      ELSE
        BEGIN                      # SUBSCRIPT IS POSITIVE             #
        SFLAG = FALSE;             # SET NEGATIVE FLAG TO FALSE        #
        DTEMP = CURWORD[0]; 
        END 
      DISPDECTOBIN;                # CONVERT DISPLAY NUMBER TO BINARY  #
      IF SFLAG                     # IF SUBSCRIPT WAS NEGATIVE,        #
      THEN
        ITEMP = -ITEMP;            # RESTORE NEGATIVE VALUE            #
      SUBSLOBND[SUBSPTR] = ITEMINT1;  # STORE HIGH AND LOW BOUNDS IN   #
      SUBSHIBND[SUBSPTR] = ITEMP;     # SUBS ARRAY.                    #
      SUBSPTR = SUBSPTR - 1;
      LASTWORD = LASTWORD - 1;     # RESET LAST WORD OF FIELD LENGTH   #
      CHECKFL;
      IF ITEMINT1 GR ITEMP         # CHECK IF THE LOWER BOUNDS EXCEEDS #
      THEN                         # THE UPPER BOUNDS                  #
        BEGIN 
        DIAGDL(131);
        STDYES; 
        END 
                                   # UPDATE ARRAY LENGTH               #
      ARRAYLENGTH = ARRAYLENGTH * (ITEMP - ITEMINT1 + 1); 
      STDYES; 
  ITEMOCEND:  
#**********************************************************************#
#                  I T E M O C E N D                                   #
#                                                                      #
#   STORES THE HIGH AND LOW BOUNDS IN THE SUBS ARRAY.  CHECKS IF HIGH  #
#   BOUND IS LESS THAN 1 (DEFAULT FOR LOW BOUND) AND IF SO, ISSUES     #
#   DIAGNOSTIC 131 AND RETURNS TO STDNO.  UPDATES ARRAY LENGTH. RETURN #
#   IS TO STDNO.                                                       #
#                                                                      #
#**********************************************************************#
      SUBSLOBND[SUBSPTR] = 1;      # STORE HIGH AND LOW BOUNDS IN SUBS #
      SUBSHIBND[SUBSPTR] = ITEMINT1;
      SUBSPTR = SUBSPTR - 1;
      LASTWORD = LASTWORD - 1;     # RESET LAST WORD OF FIELD LENGTH   #
      CHECKFL;
      IF ITEMINT1 LS 1             # CHECK IF HIGH BOUND IS LESS THAN  #
      THEN                         # LOW BOUND (LOW BOUND IS ASSUMED   #
        BEGIN                      # TO BE 1).                         #
        DIAGDL(131);
        STDNO;
        END 
      ARRAYLENGTH = ARRAYLENGTH * ITEMINT1;  # UPDATE ARRAY LENGTH     #
      STDNO;
  INCRWBPTR:   #   #
#**********************************************************************#
#                  I N C R W B P T R                                   #
#                                                                      #
#   INCREMENTS THE WORK BUFFER POINTER TO THE NEXT WORD. RETURN IS TO  #
#   STDNO.                                                             #
#                                                                      #
#**********************************************************************#
      IF BUFWORD[WBPTR] NQ 0 THEN 
        WBPTR = WBPTR + 1;
      CHECKFL;
      STDNO;
  ADJWBPTR:   #   # 
      IF WBPTRCNTR EQ 0 OR SBITMDEPNDON[WBPTR-1] AND WBPTRCNTR EQ 1 THEN
        BEGIN 
          WBPTRCNTR = 0;
          STDNO;
        END 
      WBPTR = WBPTR + WBPTRCNTR;   # INCREMENT POINTER TO THE NEXT     #
                 # AVAILABLE WORD FOR THE NEXT ITEM ENTRY.             #
      CHECKFL;
      IF (WBPTR-SEPTR) GR MAXSELENG THEN
        MAXSELENG = WBPTR - SEPTR;  # SET NEW SUB-ENTRY LENGTH(MAX).   #
      STDNO;
  LEVELCONVRTF:                                                         000970
#**********************************************************************#000980
#                  L E V E L C O N V R T F                             #000990
#                                                                      #001000
#   SETS LEVEL NUMBER TO 2. RETURNS TO STDYES.                         #001010
#                                                                      #001020
#**********************************************************************#001030
      ITEMP = 2;              # SET LEVEL NUMBER TO 2.                 #001040
      STDYES;                 # RETURN YES.                            #001050
  LEVEL01:                                                              013650
#**********************************************************************#013660
#                  L E V E L 0 1                                       #013670
#                                                                      #013680
#   CHECK IF ENTRY IS A RECORD ENTRY. IF RECORD ENTRY, RETURN IS STDYES#013690
#   ELSE RETURN IS TO STDNO.                                           #013700
#                                                                      #013710
#**********************************************************************#013720
      IF ITEMP EQ 1 THEN                                                013730
        BEGIN 
                    # IN THE RECORD.                                   #
          SBRECNXRECP[RECPTR] = WBPTR - RECPTR; # STORE OFFSET POINTER #
                         # TO THE NEXT RECORD ENTRY.                   #
          SBITMNEXTP[ITEMPTR] = 0; # ZERO OUT NEXT ITEM POINTER LAST   #
                                   # ITEM.                             #
          SBRECNBRITMS[RECPTR] = ITEMORD - 1; # STORE THE NO. OF ITEMS #
                           # SPECIFIED IN THE CURRENT RECORD.          #
          TEMPREDLVL = REDEFLEVEL;
          REDEFLEVEL = 0; 
          L66ERRFLG = FALSE;
          IF ERRCNTR LQ TEMPERRCNT THEN  # IF NO DIAGNOSTIC WERE       #
            CBSIZE;  # ISSUED THEN CALL CBSIZE TO CALCULATE THE RELAT- #
                     # IVE POSITION OF THE ITEM WITHIN THE RECORD AND  #
                     # CALCULATE THE RECORD SIZE.                      #
          IF NOT SBITMREDEFFG[ITEMPTR] THEN 
            TEMPERRCNT = ERRCNTR; 
          IF RECORDLENG LS SBRECLENGTH[RECPTR] THEN # RECORDLENG IS TO #
                         # CONTAIN THE LARGEST RECORD LENGTH SPECIFIED #
            RECORDLENG = SBRECLENGTH[RECPTR]; # IN THE SUB-SCHEMA.     #
          ITEMORD = 1;       # RE-INITIALIZE THE ITEM ORDINAL COUNT.   #
          RECPTR = WBPTR;  # SET RECORD POINTER TO THE FIRST WORD OF   #
                           # THE SUBJECT RECORD ENTRY.                 #
          SBITMPRIORP[RECPTR] = 0; # ZERO OUT THE PRIOR ITEM POINTER. # 
          SBRECTYPE[RECPTR] = RECORD;  # SET ENTRY TYPE TO RECORD.     #
          PRIORITEM = 0;     # RE-INITIALIZE PRIOR ITEM POINTER.       #
          STDYES; 
        END 
      ITEMPTR = WBPTR;  # SET ITEM POINTER TO THE FIRST WORD OF THE    #
                        # SUBJECT ITEM ENTRY.                          #
      SBITMLEVEL[ITEMPTR] = ITEMP;  # STORE CONVERTED LEVEL NUMBER.    #
      STDNO;
  SETLEVEL01:                                                           001380
#**********************************************************************#001390
#                                                                      #001400
#                  S E T L E V E L 0 1                                 #001410
#                                                                      #001420
#   SETS LEVEL NUMBER TO 1 FOR RECORD ENTRY. RETURNS TO STDYES.        #001430
#                                                                      #001440
#**********************************************************************#001450
      ITEMP = 1;              # SET LEVEL NUMBER TO 1                  #001460
       STARTRECORD = TRUE;                                              000170
      STDYES;                 # RETURN TO STDYES                       #001470
  
      EOFFLAG = 1;      # SET A FLAG TO INDICATE END OF SOURCE INPUT   #
  
  ENDSS:  
#**********************************************************************#
#                   E N D S S                                          #
#                                                                      #
#   PROCESS LAST RECORD SINCE THE END OF CURRENT SUBSCHEMA HAS BEEN    #
#   DETECTED. ESSENTIALLY SETS CERTAIN DIRECTORY FIELDS AND COMPUTES   #
#   RECORD SIZE OF LAST RECORD. RETURNS TO STDNO.                      #
#**********************************************************************#
      SBITMNEXTP[ITEMPTR] = 0; # ZERO OUT NEXT ITEM POINTER, LAST ITEM# 
      SBITMPRIORP[WBPTR] = 0;  # ZERO OUT THE PRIOR POINTER STORED IN  #
                               # THE NEXT ENTRY. END OF INPUT.         #
      SBRECNBRITMS[RECPTR] = ITEMORD - 1; # STORE THE NUMBER OF ITEMS  #
                           # SPECIFIED IN THE CURRENT RECORD.          #
      SBRECNXRECP[RECPTR] = WBPTR - RECPTR; # CALCULATE THE LENGTH OF  #
                        # RECORD ENTRY (INCLUDING THE ITEM ENTRIES) AND#
                        # STORE IT IN THE NEXT REC POINTER FIELD. THIS #
                        # IS NEEDED FOR THE DIRECTORY ACCESS ROUTINES. #
      TEMPREDLVL = REDEFLEVEL;
      REDEFLEVEL = 0; 
      IF ERRCNTR LQ TEMPERRCNT THEN 
        BEGIN 
          CBSIZE; 
        END 
      STDNO;
  ITEMEND:   #   #
#*********************************************************************# 
#                                                                     # 
#                   I T E M E N D                                     # 
#                                                                     # 
#   IF ITEM IS TYPE CHARACTER, STORES ITEM SIZE AND ITEM CLASS.       # 
#   STORES THE LENGTH IN WORDS OF THE ITEM ENTRY AND STORES THE       # 
#   OFFSET POINTER TO THE NEXT ITEM ENTRY. ALSO STORES THE PRIOR      # 
#   POINTER IN THE NEXT ITEM ENTRY. RETURN IS TO STDNO.               # 
#                                                                     # 
#*********************************************************************# 
      IF CHARFLAG                  # ITEM IS TYPE CHARACTER            #
      THEN
        BEGIN 
        IF SBITMIPICSIZ[ITEMPTR] EQ 0  # ITEM LENGTH WAS NOT SPECIFIED #
        THEN
          SBITMIPICSIZ[ITEMPTR] = DEFAULTLEN;  # USE DEFAULT LENGTH    #
        SBITMCLASS[ITEMPTR] = 1;   # SET CLASS TO 1 FOR BRANCH TO      #
                                   # ALPHANMCLAS IN SETCLASS SWITCH    #
        END 
      J = WBPTR - ITEMPTR;  # GET ENTRY LENGTH.                       # 
      SBITMNEXTP[ITEMPTR] = J;   # SET NEXT ITEM POINTER.             # 
      SBITMENTRYL[ITEMPTR] = J; # STORE ITEM ENTRY LENGTH.             #
      SBITMPRIORP[WBPTR] = J; # STORE PRIOR POINTER IN THE NEXT ITEM  # 
                              # ENTRY.                                # 
      PRIORITEM = ITEMPTR;  # STORE ITEM POINTER SO THAT THE NEXT ITEM #
                # ENTRY CAN REFERENCE IT AS A PRIOR ITEM POINTER.      #
      I = SBITMDOMADR[ITEMPTR]; 
      IF I NQ RECPTR AND SBITMUSAGE[ITEMPTR] EQ 0 THEN # IF THE USAGE  #
               # FIELD IS NOT SET, STORE THE USAGE TYPE OF THE DOMINANT#
               # ITEM INTO THE CURRENT ITEM.                           #
        SBITMUSAGE[ITEMPTR] = SBITMUSAGE[I];
      FOR I=0 STEP 1 UNTIL 24 DO
        SQWORD[I]= 0;   # ZERO OUT SQUASHBUF.                          #
      PICWORD[0]= 0;   # ZERO OUT PICTEMP.                             #
      PICWORD[1] = 0; 
      PICWORD[2] = 0; 
                                                                        002700
           # BRANCH TO ONE OF THE FOLLOWING ROUTINES BASED ON USAGE    #002710
           # AND CLASS. MORE INFORMATION IS AT CDCSCLASS AND SETCLASS. #002720
                                                                        002730
      GOTO SETCLASS[B<SBITMUSAGE[ITEMPTR]*6,6>CDCSCLASS[SBITMCLASS
        [ITEMPTR]]]; # CALL THE SWITCHVECTOR SETCLASS USING THE VALUE  #
           # STORED IN THE MATRIX CDCSCLASS. USE THE USAGE TYPE VALUE  #
           # TO DETERMINE THE BIT POSITION IN THE WORD AND USE THE     #
           # CLASS VALUE TO DETERMINE WHAT WORD TO REFERENCE IN        #
           # CDCSCLASS.                                                #
  GROUPCLAS:   #   #
#**********************************************************************#
#                  G R O U P C L A S                                   #
#   NO PICTURE OR USAGE SPECIFIED.  VALID FOR GROUP ITEMS IN COBOL.    #002500
#   ALSO USED FOR FORTRAN TYPES WHICH DO NOT APPEAR IN COBOL.  SET     #
#   DBMS CLASS, USAGE SIZE, AND PICTURE SIZE.                          #
#   RETURN IS TO STDNO.                                                #002530
#                                                                      #
#**********************************************************************#
      SBITMDBCLASS[ITEMPTR] = DBCLASS;
      SBITMUSESIZE[ITEMPTR] = USESIZE;
      SBITMIPICSIZ[ITEMPTR] = PICSIZ; 
      STDNO;         # ELEMENTRY ITEMS.                                #
  ALPHACLAS:   #   #
#**********************************************************************#
#                  A L P H A C L A S                                   #
#                                                                      #
#   PICTURE IS ALPHABETIC AND USAGE IS NOT SPECIFIED, THEREFORE SET    #
#   DBMS CLASS TO 1 AND SET USAGE SIZE TO PICTURE SIZE.                #
#                                                                      #
#**********************************************************************#
      SBITMCLASS[ITEMPTR] = 1; # RESET THE CLASS CODE. COBOL IMS DOES  #
                               # NOT AGREE WITH THE RESULTS RETURNED   #
                               # BY CBPICTUR. CLASS CODE HAS TO BE     #
                               # RE-ADJUSTED.                          #
      SBITMDBCLASS[ITEMPTR] = 1;
      SBITMUSESIZE[ITEMPTR] = SBITMIPICSIZ[ITEMPTR];
      STDNO;
  NUMERICCLAS:  
#**********************************************************************#
#                  N U M E R I C C L A S                               #
#                                                                      #
#   PICTURE IS NUMERIC, USAGE COULD BE DISPLAY, COMP OR NOT SPECIFIED  #
#   AT ALL. A CHECK IS MADE TO SEE IF THE DECIMAL POINT IS SPECIFIED.  #
#   IF THE DECIMAL POINT IS SPECIFIED SET THE DBMS CLASS TO 4 ELSE SET #
#   IT TO 3. SET USE SIZE TH THE PICTURE SIZE. RETURN IS TO STDNO.     #
#                                                                      #
#**********************************************************************#
      IF SBITMPTINFO[ITEMPTR] EQ 0 THEN 
        SBITMDBCLASS[ITEMPTR] = 3;
       ELSE 
        SBITMDBCLASS[ITEMPTR] = 4;
      SBITMUSESIZE[ITEMPTR] = SBITMIPICSIZ[ITEMPTR];
      STDNO;
  ALPHANMCLAS:   #   #
#**********************************************************************#
#                  A L P H A N M C L A S                               #
#                                                                      #
#   PICTURE IS ALPHANUMERIC, USAGE COULD BE DISPLAY OR NOT SPECIFIED.  #
#   SET USE SIZE TO THE PICTURE SIZE. DBMS CLASS IS ALREADY SET TO ZERO#
#   RETURN IS TO STDNO.                                                #
#                                                                      #
#**********************************************************************#
      SBITMUSESIZE[ITEMPTR] = SBITMIPICSIZ[ITEMPTR];
      SBITMCLASS[ITEMPTR] = 3; # RESET THE CLASS CODE. COBOL IMS DOES  #
                               # NOT AGREE WITH THE RESULTS RETURNED   #
                               # BY CBPICTUR. CLASS NO HAS TO BE RE-AD-#
                               # JUSTED.                               #
      STDNO;
  DISPUSAGE:   #   #
#**********************************************************************#
#                  D I S P U S A G E                                  *#
#                                                                     *#
#   NO PICTURE SPECIFICATION, USAGE IS DISPLAY. DBMS CLASS IS SET TO 0*#
#   SET USEAGE SIZE TO 1. RETURN IS TO STDNO.                         *#
#                                                                     *#
#**********************************************************************#
      SBITMUSESIZE[ITEMPTR] = 1;
      SBITMIPICSIZ[ITEMPTR] = 1;
      STDNO;
  COMPUSAGE:   #   #
#**********************************************************************#
#                  C O M P U S A G E                                  *#
#                                                                     *#
#   NO PICTURE SPECIFICATION, USAGE IS COMP. SET DBMS CLASS TO 3 AND  *#
#   SET USAGE SIZE TO 1. RETURN IS TO STDNO.                          *#
#                                                                      #
#**********************************************************************#
      SBITMDBCLASS[ITEMPTR] = 3;
      SBITMUSESIZE[ITEMPTR] = 1;
      SBITMIPICSIZ[ITEMPTR] = 1;
      STDNO;
  COMP1USAGE:   #   # 
#**********************************************************************#
#                  C O M P 1 U S A G E                                *#
#                                                                     *#
#   NO PICTURE SPECIFICATION, USAGE IS COMP-1. SET DBMS CLASS TO 12   *#
#   AND USAGE SIZE TO 10. RETURN IS TO STDNO.                         *#
#                                                                     *#
#**********************************************************************#
      SBITMDBCLASS[ITEMPTR] = 10; 
      SBITMUSESIZE[ITEMPTR] = 10; 
      SBITMIPICSIZ[ITEMPTR] = 1;
      STDNO;
  PICNUMCLAS:   #   # 
#**********************************************************************#
#                  P I C N U M C L A S                                 #
#                                                                      #
#   PICTURE IS NUMERIC AND USAGE IS COMP-1. CHECK IF PICTURE SIZE IS   #
#   LESS THAN 15, AND IF SO SET DBMS CLASS TO 12 AND USAGE SIZE TO 10, #
#   ELSE SET DBMS CLASS TO 13 AND USAGE SIZE TO 20. RETURN IS TO STDNO.#
#                                                                      #
#**********************************************************************#
      IF SBITMIPICSIZ[ITEMPTR] LS 15 THEN 
        SBITMDBCLASS[ITEMPTR] = 10; 
      ELSE
        DIAGDL(217);
      SBITMUSESIZE[ITEMPTR] = 10; 
     STDNO; 
  COMP2USAGE:   #   # 
#**********************************************************************#
#                  C O P M 2 U S A G E                                 #
#                                                                      #
#   PICTURE COULD BE NUMERIC OR NO PICTURE SPECIFIED AT ALL, AND USAGE #
#   IS COMP-2. SET DBMS CLASS TO 13 AND USAGE SIZE TO 10. RETURN IS TO #
#   STDNO.                                                             #
#                                                                      #
#**********************************************************************#
      SBITMDBCLASS[ITEMPTR] = 13; 
      SBITMUSESIZE[ITEMPTR] = 10; 
      IF SBITMIPICSIZ[ITEMPTR] EQ 0 THEN
        BEGIN 
          SBITMIPICSIZ[ITEMPTR] = 1;
        END 
      STDNO;
  ERROR166:   #   # 
#**********************************************************************#
#                  E R R O R 1 6 6                                     #
#                                                                      #
#   INVALID USAGE TYPE INDEXING CDCS MATRIX.  RETURN TO STDNO.         #
#                                                                      #
#**********************************************************************#
      DIAGDL(166);
      STDNO;
  ERROR167:   #   # 
#**********************************************************************#
#                  E R R O R 1 6 7                                     #
#                                                                      #
#   ALPHABETIC PICTURE OR ALPHANUMERIC PICTURE NOT ALLOWED WITH USAGE  #
#   IS COMP, COMP-1, OR COMP-2 CLAUSE. RETURN IS TO STDNO.             #
#                                                                      #
#**********************************************************************#
        DIAGDL(217);
      STDNO;
  ERROR168:   #   # 
#**********************************************************************#
#                 E R R O R 1 6 8                                      #
#                                                                      #
#   PICTURE CLAUSE IS NOT ALLOWED WITH USAGE IS INDEX. RETURN IS TO    #
#   STDNO.                                                             #
#                                                                      #
#**********************************************************************#
      DIAGDL(168);
      STDNO;
  RESETCHARFLG: 
#**********************************************************************#
#                     R E S E T C H A R F L A G                        #
#                                                                      #
#   SET FLAG WHICH INDICATES CHARCTER TYPE STATEMENT TO FALSE.         #
#                                                                      #
#**********************************************************************#
      CHARFLAG = FALSE; 
      STDNO;
  SETCHARLEN: 
#**********************************************************************#
#                          S E T C H A R L E N                         #
#                                                                      #
#   ERROR IF THIS IS NOT A CHARACTER ITEM.  CONVERT DISPLAY-CODED      #
#   INTEGER TO BINARY.  STORE ITEM SIZE.  IF SIZE IS GREATER THAN      #
#   MAXIMUM SIZE ALLOWED, RETURN IS TO STDNO.  ELSE RETURN TO STDYES.  #
#                                                                      #
#**********************************************************************#
      IF NOT CHARFLAG              # ITEM IS NOT TYPE CHARACTER        #
      THEN
        BEGIN 
        DIAGDL(128);
        STDYES; 
        END 
      DTEMP = CURWORD[0]; 
      DISPDECTOBIN;                # CONVERT TO BINARY.                #
      SBITMIPICSIZ[ITEMPTR] = ITEMP;  # STORE ITEM SIZE                #
      IF ITEMP GR MAXITMSIZ        # ITEM SIZE GREATER THAN MAX. SIZE  #
      THEN
        STDNO;
      STDYES; 
  SETDFLEN1:  
#**********************************************************************#
#                       S E T D F L E N 1                              #
#                                                                      #
#   SET DEFAULT LENGTH TO 1.  RETURN IS TO STDNO.                      #
#                                                                      #
#**********************************************************************#
      DEFAULTLEN = 1; 
      STDNO;
  SETDFLEN2:  
#**********************************************************************#
#                     S E T D F L E N 2                                #
#                                                                      #
#   CONVERT DISPLAY-CODED INTEGER TO BINARY AND STORE INTO DEFAULT     #
#   LENGTH.  IF DEFAULT LENGTH IS GREATER THAN MAX. VALUE ALLOWED,     #
#   RETURN IS TO STDNO.  ELSE, RETURN IS TO STDYES.                    #
#                                                                      #
#**********************************************************************#
      DTEMP = CURWORD[0]; 
      DISPDECTOBIN;                # CONVERT TO BINARY                 #
      DEFAULTLEN = ITEMP; 
      IF ITEMP GR MAXITMSIZ        # ITEM SIZE GREATER THAN MAX SIZE   #
      THEN
        STDNO;
      STDYES; 
  CHKFTN5:  
#**********************************************************************#
#                     C H K F T N 5                                    #
#                                                                      #
#   IF THIS IS A FORTRAN 5 SUBSCHEMA, RETURN IS TO STDNO, ELSE RETURN  #
#   IS TO STDYES.                                                      #
#                                                                      #
#**********************************************************************#
      IF DDLCOMP EQ F5
      THEN
        STDNO;
      STDYES; 
  SETWBPTR:   #   # 
#**********************************************************************#
#                   S E T W B P T R                                    #
#                                                                      #
#   RESETS WBPTR TO POINT TO WORD FOLLOWING LAST ENTRY, IN CASE OF     #
#   ERRONEOUS ENTRIES.                                                 #
#                                                                      #
#**********************************************************************#
      I = SBITMPRIORP[ITEMPTR]; 
      FOR J = ITEMPTR STEP 1 UNTIL WBPTR DO 
        BUFWORD[J] = 0; 
      WBPTR = ITEMPTR;
      ITEMPTR = ITEMPTR - I;
      STDNO;
  SETRELFG:   #   # 
      SBITMNEXTP[ITEMPTR] = 0; # ZERO OUT NEXT ITEM POINTER, LAST ITEM# 
      SBITMPRIORP[WBPTR] = 0;  # ZERO OUT THE PRIOR POINTER STORED IN  #
                               # THE NEXT ENTRY. END OF INPUT.         #
      SBRECNBRITMS[RECPTR] = ITEMORD - 1; # STORE THE NUMBER OF ITEMS  #
                           # SPECIFIED IN THE CURRENT RECORD.          #
      SBRECNXRECP[RECPTR] = WBPTR - RECPTR; # CALCULATE THE LENGTH OF  #
                        # RECORD ENTRY (INCLUDING THE ITEM ENTRIES) AND#
                        # STORE IT IN THE NEXT REC POINTER FIELD. THIS #
                        # IS NEEDED FOR THE DIRECTORY ACCESS ROUTINES. #
      TEMPREDLVL = REDEFLEVEL;
      REDEFLEVEL = 0; 
      RELFLAG = TRUE; 
      IF ERRCNTR LQ TEMPERRCNT THEN 
        CBSIZE; 
  CHKMSS: 
#**********************************************************************#
#                   C H K M S S                                        #
#                                                                      #
#   CHECKS THE MULTIPLE COMPILATION FLAG. IF SET,RETURNS TO STDYES     #
#   AFTER TURNING THE FLAG OFF. ELSE, RETURNS TO STDNO.                #
#**********************************************************************#
      IF MULTSS THEN
        BEGIN                # MULTIPLE COMPILATION BEGIN DONE         #
        MULTSS = FALSE;      # TURN OFF FLAG                           #
        STDYES; 
        END 
      STDNO;
  SETSSFGT: 
#**********************************************************************#
#                   S E T S S F G T                                    #
#                                                                      #
#   TURNS ON THE MULTIPLE COMPILATION FLAG. RETURNS TO STDNO.          #
#**********************************************************************#
      MULTSS = TRUE;
      STDNO;
  GENCOMMON:                                                            001620
#**********************************************************************#001630
#                                                                      #001640
#                  G E N C O M M O N                                   #001650
#                                                                      #001660
#     ADD ITEM NAMES TO COMMON STATEMENT.                              #001400
#     WHEN A LINE IS FULL, WRITE TO SSOUT FILE.                        #001410
#     THE FORMAT OF THE COMMON STATEMENT IS:  COMMON/DBXXXX/           #
#     WHERE XXXX IS THE AREA ORDINAL.  IN FTN5 IF A SECONDARY COMMON   #
#     BLOCK IS GENERATED, IT WILL HAVE THE FORMAT:  COMMON/DXXXXYY/    #
#     WHERE YY IS A 2-CHARACTER ID WHICH RANGES FROM AA, AB,...,YY.    #
#     FIRST ITEM OF RECORD IS EQUIVALENCED TO A SPECIAL GENERATED ITEM.#000550
#                                                                      #001420
#**********************************************************************#001670
      COMLENG = SBITMNMELENC[ITEMPTR];  # LENGTH OF ITEM NAME          #
      SAVENAME = C<0,COMLENG>SBITMNAME30[ITEMPTR+SBITMNAMEPTR[ITEMPTR]];
  
      IF STARTRECORD               # IF START OF NEW RECORD,           #
      THEN
        BEGIN 
        STARTRECORD = FALSE;
        SUBCOM = FALSE;            # THIS IS 1ST COMMON BLOCK IN RECORD#
        COMCOUNT = COMCOUNT + 1;
        I = SBRECWITHINO[RECPTR];  # PICK UP REALM ORDINAL             #
                                   # CONVERT TO DISPLAY CODE, ZERO FILL#
        AREAORDD = "00000"; 
        FOR K = 24 STEP -6
          WHILE I GR 0
        DO
          BEGIN 
          J = I / 10; 
          B<K,6>AREAORDD = I - J*10 + O"33";
          I = J;
          END 
  
        C<22,4>F4EDBI = C<1,4>AREAORDD;  # STORE ORD INTO EQUIV. LINE  #
        C<27,7>F4EDBI = C<0,COMLENG>SAVENAME;  # STORE ITEM NAME       #
        IF CHARFLAG                # IF ITEM IS TYPE CHARACTER,        #
        THEN
          BEGIN 
          CHARLAST = TRUE;         # COMMON BLOCK IS FOR CHAR ITEMS    #
          C<19,4>F5IDBI = C<1,4>AREAORDD;  # STORE ORD INTO TEMPLATE   #
          WSSOUT2(F5IDBI,30);      # WRITE TO SSOUT                    #
          END 
        ELSE                       # ITEM IS NOT A CHARACTER DATA TYPE #
          BEGIN 
          CHARLAST = FALSE;        # COMMON BLOCK IS FOR NON-CHAR ITEMS#
          C<17,4>F4IDBI = C<1,4>AREAORDD;  # STORE ORD INTO TEMPLATE   #
          WSSOUT2(F4IDBI,30);      # WRITE TO SSOUT                    #
          END 
        WSSOUT2(F4EDBI,40);        # WRITE EQUIV. LINE TO SSOUT        #
        I1 = "A";                  # INITIALIZE ID VARIABLES           #
        I2 = "A"; 
        END 
  
      IF (NOT CHARFLAG AND CHARLAST)  # PREVIOUS COMMON BLOCK NOT      #
        OR (CHARFLAG AND NOT CHARLAST)  # COMPATIBLE WITH CURRENT ITEM.#
      THEN
        BEGIN 
        SUBCOM = TRUE;             # THIS IS A SECONDARY COMMON BLOCK  #
        NEWCLINE = TRUE;
        CHARLAST = CHARFLAG;       # RESET TYPE OF COMMON BLOCK        #
        COMCOUNT = COMCOUNT + 1;
        C<18,1>F4CITEM = I1;       # STORE 2-CHARACTER ID INTO COMMON  #
        C<19,1>F4CITEM = I2;       # BLOCK TEMPLATE                    #
        B<0,6>I2 = B<0,6>I2 + 1;   # INCREMENT 2ND ID CHARACTER        #
        IF I2 EQ "Z"
        THEN
          BEGIN 
          I2 = "A"; 
          B<0,6>I1 = B<0,6>I1 + 1;  # INCREMENT 1ST ID CHARACTER       #
          IF I1 EQ "Z"
          THEN
            I1 = "A"; 
          END 
        END 
  
      IF NEWCLINE 
      THEN
        BEGIN 
        NEWCLINE = FALSE; 
        IF SUBCOM                  # IF SECONDARY COMMON BLOCK, USE A  #
        THEN                       # DIFFERENT FORMAT FOR TEMPLATE:    #
                                   #     COMMON/DXXXXYY/               #
          BEGIN 
          C<14,4>F4CITEM = C<1,4>AREAORDD;
          C<20,1>F4CITEM = "/"; 
          END 
        ELSE                       # USE ORIGINAL FORMAT FOR TEMPLATE: #
                                   #     COMMON/DBXXXX/                #
          BEGIN 
          C<14,1>F4CITEM = "B"; 
          C<15,4>F4CITEM = C<1,4>AREAORDD;
          C<19,2>F4CITEM = "/ ";
          END 
        COMCHAR = 21;              # SET TO STARTING CHAR POSITION     #
        END 
                                   # MOVE ITEM NAME TO LINE            #
      C<COMCHAR,COMLENG>F4CITEM = C<0,COMLENG>SAVENAME; 
      COMCHAR = COMCHAR + COMLENG;
      IF COMCHAR GR 64             # IF LINE IF FULL,                  #
      THEN
        BEGIN 
        WSSOUT2(F4CITEM,COMCHAR);  # WRITE OUT LINE                    #
        NEWCLINE = TRUE;
        END 
      ELSE
        BEGIN 
        C<COMCHAR,1>F4CITEM = ",";  # ADD COMMA AFTER NAME             #
        COMCHAR = COMCHAR + 1;
        END 
  
      IF COMCOUNT GR 500           # MAX. NO. OF COMMON BLOCKS EXCEEDED#
      THEN
        DIAGDL(200);
      STDYES;                                                           001680
  WRTCOM:                                                               001900
#**********************************************************************#001910
#                                                                      #001920
#                  W R T C O M                                         #001930
#                                                                      #001940
#     WRITE OUT PARTIAL COMMON STATEMENT, IF ANY, TO SSOUT FILE.       #001720
#                                                                      #001730
#**********************************************************************#001950
      IF NOT NEWCLINE THEN                                              001750
        BEGIN                                                           001760
         C<COMCHAR-1,1>F4CITEM = " ";  # BLANK OUT FINAL COMMA         #000500
          WSSOUT2(F4CITEM,COMCHAR);                                     000610
          NEWCLINE = TRUE;                                              001780
        END                                                             001790
      STDYES;                                                           001960
  PROC BUILDINDEX;
    BEGIN 
#**********************************************************************#
#                                                                      #
#                  B U I L D I N D E X                                 #
#                                                                      #
#   BUILDS THE REALM LIST. STORES THE REALM NAME AND WORD ADDRESS.     #
#                                                                      #
#**********************************************************************#
      FOR I=0 STEP 1 UNTIL SBARLENGWRDS[ARPTR] - 1 DO  # GET THE REALM #
        REALMLISTNME[REALMLSTPTR+I] = SBARNAME[ARPTR +
                                       SBARNAMEPTR[ARPTR] + I]; 
          #NAME FROM THE REALM ENTRY AND STORE IT INTO THE REALM LIST. #
      REALMADR[REALMLSTPTR] = ARPTR; # STORE THE WORD ADDRESS OF THE   #
      # REALM ENTRY.                                                   #
      REALMENTRYLG[REALMLSTPTR] = WBPTR - ARPTR; # STORE THE LENGTH OF #
                                         # REALM ENTRY.                #
      REALMLSTPTR = REALMLSTPTR + 4; # INCREMENT THE REALM LIST POINT  #
                                       # ER TO THE NEXT REALM LIST     #
      RETURN;                          # ENTRY.                        #
    END 
  PROC HASHTABLE;                                                       014970
#**********************************************************************#
#                         H A S H T A B L E                            #
#                                                                      #
#          VALIDATES THE UNIQUENESS OF AREA, RECORD AND ITEM NAMES     #
#                                                                      #
#**********************************************************************#
    BEGIN                                                               014980
# THIS ROUTINE IS USED TO VALIDATE THE UNIQUENESS OF AREA, RECORD AND  #014990
# ITEM NAMES.                                                          #015000
      ALIASFLG = 0;  # RESET THE ALIAS FLAG.                           #
      CBHASHN(CWORD,CURLENW,HRSLT);  # NAME STORED IN CWORD IS HASHED. #
                                       # LOCATION OF THE HASHTBLE ENTRY#015020
                                       # IS RETURNED IN HRSLT.         #015030
      IF HASHALIASFLG[HRSLT] OR HASHALIAS1FG[HRSLT] THEN  # CHECK IF   #
                 # SUBJECT ENTRY HAS A POSSIBLE ASSOCIATION WITH AN    #
                 # ALIAS NAME.                                         #
        ALIASFLG = HASHALIASENT[HRSLT]; # STORE THE WORD ADDRESS OF THE#
                                        # ALIAS ENTRY.                 #
      IF NOT HASHOCCUP[HRSLT] THEN     # CHECK IF THE HASH TABLE ENTRY #015040
        GOTO ENTERHASHTBL;             # IS EMPTY. IF EMPTY GOTO ROUT- #015050
                                       # INE THAT STORES WORD ADDRESS  #015060
                                       # OF THE SUB-SCHEMA ENTRY.      #015070
      SBPTR = SBWRDADR;  # SAVE THE WORD ADDRESS OF THE CURRENT ENTRY. #
      SBWRDADR = HASHENTRY[HRSLT];     # STORE THE SUB-SCHEMA ADDRESS  #015080
                                       # THAT IS IN HASHENTRY.         #015090
    CONTSYNM:   #   # 
      ENTRYTYPE = SBENTRYTYPE[SBWRDADR];  # STORE THE ENTRY TYPE OF THE#015100
                                          # ENTRY THAT ALREADY EXISTS I#015110
                                          # THE SUB-SCHEMA.            #015120
      IF ENTRYTYPE EQ ITEMS THEN      # CHECK THE CURRENT ENTRY TYPE SO#
        BEGIN # THAT A NAME POINTER CAN BE ADJUSTED TO POINT TO THE    #
                # NAME.                                                #
          SBNAMEADR = SBWRDADR + SBITMNAMEPTR[SBWRDADR];
          I = SBITMNELENW[SBWRDADR]; # STORE THE LENGTH IN WORDS.      #
        END 
       ELSE 
        IF ENTRYTYPE EQ RECORD THEN 
          BEGIN 
            SBNAMEADR = SBWRDADR + SBRECNAMEPTR[SBWRDADR];
            I = SBRECNMELENW[SBWRDADR]; 
          END 
         ELSE 
          BEGIN 
            SBNAMEADR = SBWRDADR + SBARNAMEPTR[SBWRDADR]; 
            I = SBARLENGWRDS[SBWRDADR]; 
          END 
      IF I NQ CURLENW THEN # CHECK IF THE LENGTHS ARE EQUAL.           #
        GOTO CKSYNONYM; 
      FOR I=0 STEP 1 UNTIL CURLENW  - 1 DO # CHECK IF CONTENTS OF NAMES#015190
        BEGIN                          # EQUAL THE NAME IN THE SUB-SCHE#015200
          IF CURWORD[I] NQ SBENTRYNAME[SBNAMEADR+I] THEN  # MA ENTRY.  #015210
            GOTO CKSYNONYM;  # NAMES WHERE NOT EQUAL, CHECK FOR SYNONYM#015220
                             # POINTER.                                #015230
        END                                                             015240
      GOTO CKSMENAME;   # NAMES WERE THE SAME.                         #
    CKSYNONYM:                                                          015250
      IF ENTRYTYPE EQ ITEMS THEN     # CHECK IF ITEM ENTRY.            #015260
        J = SBITMSYNADDR[SBWRDADR];  # STORE ADDRESS OF THE NEXT       #015270
       ELSE                          # SYNONYM ENTRY.                  #015280
      IF ENTRYTYPE EQ RECORD THEN    # CHECK IF RECORD ENTRY.          #015290
        J = SBRECSYNADR[SBWRDADR];   # STORE ADDRESS OF THE NEXT       #015300
       ELSE                          # SYNINYM ENTRY.                  #015310
        J = SBARSYNADDR[SBWRDADR];   # AREA ENTRY. STORE ADDRESS OF THE#015320
                                     # SYNONYM ENTRY.                  #015330
      IF J EQ 0 THEN      # CHECK FOR A NEXT SYNONYM POINTER.          #015340
        BEGIN                                                           015350
          IF ENTRYTYPE EQ ITEMS THEN   # CHECK IF ITEM ENTRY.          #015360
            SBITMSYNADDR[SBWRDADR] = SBPTR; # STORE THE WORD ADDRESS OF#015370
                         # THE SUBJECT SUB-SCHEMA ENTRY INTO THE       #015380
                         # SYNONYM LINK POINTER.                       #015390
           ELSE                                                         015400
          IF ENTRYTYPE EQ RECORD THEN   # CHECK IF RECORD ENTRY.       #015410
            SBRECSYNADR[SBWRDADR] = SBPTR;                              015420
           ELSE                                                         015430
            SBARSYNADDR[SBWRDADR] = SBPTR; # FELL THRU TO AREA ENTRY.  #015440
          RETURN;                                                       015450
        END                                                             015460
      SBWRDADR = J; 
      GOTO CONTSYNM;
    CKSMENAME:                                                          015530
      IF HSHTYPE EQ ENTRYTYPE THEN# CHECK IF THE EXISTING ENTRY IN THE #015540
        BEGIN                     # THE SUB-SCHEMA IS THE SAME ENTRY   #015550
                                  # TYPE OF THE ONE BEING HASHED.      #015560
          DUPFLAG = 1; # DUPLICATE ENTRIES.                            #015650
          RETURN;                                                       015660
        END                                                             015670
      ELSE
        IF HSHTYPE EQ ITEMS AND ENTRYTYPE EQ RECORD THEN
          BEGIN  # HASHED NAME IS AN ITEM NAME AND NAME IN SAME-NAME   #
            IF SBWRDADR EQ RECPTR THEN   # LINK IS A RECORD.           #
              BEGIN          # HASHED NAME BELONGS TO RECORD IN SAME-  #
                DUPFLAG = 1; # NAME LINK--HENCE NAME IS NOT UNIQUE.    #
                RETURN; 
              END 
          END 
    CKSAMECONT:                                                         015680
      IF ENTRYTYPE EQ ITEMS THEN # CHECK IF ENTRY TYPE IS ITEM.        #015690
        J = SBITMSAMENME[SBWRDADR]; # STORE THE VALUE IN THE SAME      #015700
       ELSE                         # NAME LINK.                       #015710
         IF ENTRYTYPE EQ RECORD THEN  # CHECK IF ENTRY TYPE IS RECORD. #015720
           J = SBRECSMENMEA[SBWRDADR]; # STORE THE VALUE IN THE SAME   #015730
          ELSE                         # NAME LINK.                    #015740
            J = SBARSAMENAME[SBWRDADR]; # FELL THRU TO AREA. STORE THE #015750
      IF J NQ 0 THEN          # VALUE IN THE SAME LINK. CHECK FOR NEXT #015760
        BEGIN                 # SAME NAME LINK.                        #015770
          ENTRYTYPE = SBENTRYTYPE[J];  # GET SAME NAME ENTRY TYPE.     #015780
          SBWRDADR = J;                # STORE WORD ADDRESS OF THE SAME#015790
          GOTO CKSMENAME;           # NAME ENTRY IN THE SUB-SCHEMA.    #015800
        END                                                             015810
      IF ENTRYTYPE EQ ITEMS THEN  # CHECK IF THE ENTRY BEING HASHED IS #
        SBITMSAMENME[SBWRDADR] = SBPTR;     # AN ITEM ENTRY.           #015830
       ELSE                                                             015840
      IF ENTRYTYPE EQ RECORD THEN  # CHECK IF THE ENTRY BEING HASHED IS#
          SBRECSMENMEA[SBWRDADR] = SBPTR;     # A RECORD ENTRY.        #015860
         ELSE                             # FELL THRU TO AREA ENTRY.   #015870
          SBARSAMENAME[SBWRDADR] = SBPTR;                               015880
      RETURN;                                                           015890
    ENTERHASHTBL:                                                       015900
      HASHOCCUP[HRSLT] = TRUE;         # SET INDICATOR TO OCCUPIED.    #015910
      HASHENTRY[HRSLT] = SBWRDADR;     # STORE ADDRESS OF SUBJECT      #015920
                                       # SUB-SCHEMA ENTRY.             #015930
      HASHTYPE[HRSLT] = HSHTYPE;       # STORE ENTRY TYPE.             #015940
      IF HASHALIASFLG[HRSLT] THEN # CHECK IF THERE IS AN ALIAS ENTRY   #
                                  # FOR THE SUBJECT ENTRY.             #
        BEGIN 
          ALIASFLG = HASHALIASENT[HRSLT]; # STORE THE WORD ADDRESS OF  #
        END                               # THE ALIAS ENTRY.           #
      RETURN;                                                           015950
    END                                                                 015960
  PROC CHARMOVE(SRLOC,SRBYTE,MOVELENG,TGLOC,TGBYTE);
#**********************************************************************#
#                  C H A R M O V E                                     #
#                                                                      #
#   MOVES A SPECIFIED LENGTH OF CHARACTERS FROM ONE LOCATION TO        #
#   ANOTHER.                                                           #
#                                                                      #
#**********************************************************************#
    BEGIN 
      ITEM SRLOC;      # SOURCE LOCATION  # 
      ITEM SRBYTE;     # SOURCE BYTE #
      ITEM MOVELENG;   # LENGTH OF STRING TO BE MOVED # 
      ITEM TGLOC;      # TARGET LOCATION #
      ITEM TGBYTE;      #TARGET BYTE                   #
      ITEM LENGMVD; 
  
      ITEM MVSRBT;
      ITEM MVTGBT;
      P<SRLIT> = SRLOC; 
      P<TGLIT> = TGLOC; 
      LENGMVD = 0;
      MVSRBT = SRBYTE;
      MVTGBT = TGBYTE;
      FOR K = K WHILE LENGMVD LS MOVELENG DO
        BEGIN 
      FOR K = K WHILE MVSRBT GR 9 DO
        BEGIN 
          MVSRBT = MVSRBT - 10; 
          P<SRLIT> = LOC(SRLIT) +1; 
        END 
      FOR K = K WHILE MVTGBT GR 9 DO
        BEGIN 
          MVTGBT = MVTGBT - 10; 
          P<TGLIT> = LOC(TGLIT) + 1;
        END 
      C<MVTGBT>TGCHAR[0] = C<MVSRBT>SRCHAR[0];
      MVTGBT = MVTGBT + 1;
      MVSRBT = MVSRBT + 1;
      LENGMVD = LENGMVD + 1;
      END 
    END 
  PROC CHECKFL; 
#**********************************************************************#
#                  C H E C K F L                                       #
#                                                                      #
#   CHECKS IF THE WORKING STORAGE AREA (CBWORKBUF) HAS EXCEEDED THE    #
#   USERS FIELD LENGTH. IF SO DIAGNOSTIC 171 IS ISSUED AND THE COMPILAT#
#   ION IS ABORTED.                                                    #
#                                                                      #
#**********************************************************************#
    BEGIN 
      ITEM S ;
      ITEM T; 
      S = SBSCHMA + WBPTR ; 
      IF S + 25 + ABS(SUBSPTR) GR DDLSU 
      THEN
        DDLSU = S + 25 + ABS(SUBSPTR);      # UPDATE STORAGE USED      #
      IF  S GR LASTWORD THEN       # IF BEYOND CURRENT FIELD LENGTH    #
        BEGIN 
          S = ((S + 25 + ABS(SUBSPTR) + 63) / 64) * 64; 
          IF S GQ MAXFL                     # IF GREATER THAN MAXIMUM  #
          THEN                              # FIELD LENGTH ALLOWED     #
            BEGIN 
            DIAGDL(171);                    # ISSUE DIAGNOSTIC         #
            ABRT1;                          # AND ABORT                #
            END 
          MEMORY (S) ;                      # ELSE REQUEST MORE FL     #
          T = B<0,30>DDLMEM - P<SUBS>;      # CALCULATE DISTANCE BTWN  #
                                            # NEW LAST WORD AND SUBS   #
          P<SUBS> = B<0,30>DDLMEM;          # SET SUBS TO NEW LAST WORD#
          FOR S = -1 STEP -1 UNTIL SUBSPTR + 1
          DO
            BEGIN                           # MOVE SUBS ARRAY DOWN TO  #
            SUBSWRD[S] = SUBSWRD[S-T];      # NEW POSITION, ONE WORD   #
            SUBSWRD[S-T] = 0;               # AT A TIME.               #
            END 
          LASTWORD = LASTWORD + T;          # RESET LAST WORD OF FL    #
        END 
      RETURN; 
    END 
      XDEF PROC CONVLNENBR; 
  PROC CONVLNENBR(LNENBR);
    BEGIN 
      ITEM LNENBR;   # CONTAINS THE BINARY LINE NUMBER TO BE CONVERTED #
                     # TO DISPLAY CODE.                                #
      ITEM CONV1;   # SCRATCH ITEM.                                    #
      ITEM CONV2;   # SCRATCH ITEM.                                    #
      NBRLINE = "          "; 
      FOR CONV1=9 STEP -1 UNTIL 5 DO
        BEGIN 
          CONV2 = LNENBR / 10;
          C<CONV1>NBRLINE = LNENBR - CONV2 * 10 + O"33";
          LNENBR = CONV2; 
        END 
      RETURN; 
    END 
  PROC CONVORD; 
#**********************************************************************#
#                  C O N V O R D                                       #
#                                                                      #
#   CONVERTS THE ENTRY ORDINAL NUMBER FROM BINARY TO DECIMAL DISPLAY.  #
#                                                                      #
#**********************************************************************#
    BEGIN 
      ORDNUM = "          "; # INITIALIZE DISPLAY CELL.                #
      FOR I=24 STEP - 6 WHILE ORDNBR GR 0 DO
        BEGIN 
          J = ORDNBR / 10;
          B<I,6>ORDNUM = ORDNBR - J * 10 + O"33"; 
          ORDNBR = J; 
        END 
      RETURN; 
    END 
  PROC DISPDECTOBIN;
#**********************************************************************#
#                  D I S P D E C B I N                                 #
#                                                                      #
#   CONVERTS THE DECIMAL DISPLAY VALUE SPECIFIED IN THE DDL SOURCE     #
#   INPUT INTO BINARY.                                                 #
#   ENTRY CONDITION:  DTEMP CONTAINS THE DISPLAY CODED VALUE.          #
#   EXIT CONDITION:  ITEMP CONTAINS THE BINARY VALUE.                  #
#                                                                      #
#**********************************************************************#
    BEGIN 
      ITEMP = 0;   #INITIALIZE.                                        #
      FOR I=0 STEP 6 UNTIL 54 DO  # STORE A CHARACTER OF THE INPUT     #
        BEGIN                     # STRING                             #
          J = B<I,6>DTEMP;
          IF J EQ 0 THEN   # CHECK IF AT END OF INPUT STRING.          #
            RETURN; 
          ITEMP = ITEMP*10 + J-O"33"; 
        END 
    END 
PROC GETLITCHAR;  # PROCEDURE TO FETCH A CHARACTER FROM CURWORD.       #
#**********************************************************************#
#                  G E T L I T C H A R                                 #
#                                                                      #
#   GETS A CHARACTER FROM SOURCE STRING.                               #
#                                                                      #
#**********************************************************************#
    BEGIN 
      IF J LS 9 THEN
        J = J + 1;
      ELSE
        BEGIN 
          J = 0;
          K = K + 1;
        END 
      NXCHAR = C<J>CURWORD[K];
    END 
  PROC HASHALIAS;                                                       016030
#**********************************************************************#
#                  H A S H A L I A S                                   #
#                                                                      #
#   CALLS CBHASHN TO HASH THE ALIAS NAME AND RETURN THE LOCATION IN THE#
#   SYMBOL WHERE THE CORRESPONDING ENTRY WILL BE PLACED. THE ALIAS FLAG#
#   IS SET AND THE WORD ADDRESS OF THE ALIAS ENTRY IN THE ALIAS FILE IS#
#   IS STORED (IN SYMBOL TABLE). THE ENTRY THAT THE ALAIS NAME PERTAINS#
#   HAS NOT BEEN DEFINED YET. ALL THAT IS DONE HERE IS TO FLAG THE SLOT#
#   IN THE SYMBOL TABLE WHERE THE ENTRY INFO WILL BE STORED.           #
#                                                                      #
#**********************************************************************#
    BEGIN                                                               016040
      CBHASHN(CWORD,CURLENW,HRSLT); # HASH ALIAS-NAME(1/2). HASH RESULT#
                                    # IS RETURNED IN HRSLT.            #
      IF HASHALIASFLG[HRSLT] OR HASHALIAS1FG[HRSLT] THEN
        BEGIN 
          IF HASHALIASENT[HRSLT] EQ ALIASENT  # ALIAS-NAME-1 AND ALIAS-#
          THEN                                # NAME-2 ARE HASHED INTO #
            BEGIN                             # A SAME SLOT            #
            IF ALIAS1NAME THEN
              HASHALIAS1FG[HRSLT] = TRUE;     # SET FLAG AND RETURN    #
            ELSE
              HASHALIASFLG[HRSLT] = TRUE; 
            RETURN; 
            END 
          J = HASHALIASENT[HRSLT];
    GETNXALS:   #   # 
          ALIASRD(SCRATCHBUF,1,J);
          IF B<30,15>SCRATCHWRD[0] EQ ALIASENT THEN  # IF END OF SYN-  #
            BEGIN  # ONYM CHAIN REACHED, SET FLAG AND RETURN.          #
              IF ALIAS1NAME THEN
                HASHALIAS1FG[HRSLT] = TRUE; 
              ELSE
                HASHALIASFLG[HRSLT] =TRUE;
              RETURN; 
            END 
          IF B<30,15>SCRATCHWRD[0] GR 0 THEN
            BEGIN 
              J = B<30,15>SCRATCHWRD[0];
              GOTO GETNXALS;
            END 
          B<30,15>SCRATCHWRD[0] = ALIASENT; 
          ALIASRT(SCRATCHBUF,1,J);
            IF ALIAS1NAME THEN     # IF ALIAS-NAME-1,SET FLAG IN       #
              HASHALIAS1FG[HRSLT] = TRUE;    # IN SYMBOL TABLE.        #
            ELSE   # ELSE, IF ALIAS-NAME-2 , SET FLAG.                 #
              HASHALIASFLG[HRSLT] = TRUE; 
          RETURN; 
        END 
      IF ALIAS1NAME THEN     # IF ALIAS-NAME-1,                        #
        BEGIN 
          HASHALIAS1FG[HRSLT] = TRUE;  # SET FLAG.                     #
          HASHALIASENT[HRSLT] = ALIASENT;  # STORE WORD ADDRESS.       #
          RETURN; 
        END 
      HASHALIASFLG[HRSLT] = TRUE; # SET ALIAS FLAG.                    #
      HASHALIASLEN[HRSLT] = CURLENW; # STORE THE LENGTH IN WORDS OF    #
                                     # ALIAS-NAME-2.                   #
      HASHALIASENT[HRSLT] = ALIASENT; # STORE THE WORD ADDRESS OF THE  #
              # ALIAS ENTRY IN ALIAS BUF.                              #
      RETURN;                                                           016050
    END                                                                 016060
  PROC HASHNAME;
    BEGIN 
      HSHADDR = 0;
      CBHASHN(HASHNME,HASHLENW,HRSLT);
      IF NOT HASHOCCUP[HRSLT] THEN
        RETURN; 
      HSHADDR = HASHENTRY[HRSLT]; 
    CKNAME:   #   # 
      FOR K=0 STEP 1 UNTIL HASHLENW - 1 DO
        IF HSHNAME[K] NQ SBITMNAME[HSHADDR+SBITMNAMEPTR[HSHADDR]+K] THEN
          BEGIN 
            IF SBITMENTRY[HSHADDR] EQ ITEMS THEN
              HSHADDR = SBITMSYNADDR[HSHADDR];
             ELSE 
              IF SBITMENTRY[HSHADDR] EQ RECORD THEN 
                HSHADDR = SBRECSYNADR[HSHADDR]; 
               ELSE 
                HSHADDR = SBARSYNADDR[HSHADDR]; 
            IF HSHADDR EQ 0 THEN
              RETURN; 
            GOTO CKNAME;
          END 
      QALPTR = 0; 
      DOMPTR = SBITMDOMADR[HSHADDR];
    CKQALNAME:   #   #
      IF SBITMENTRY[DOMPTR] EQ RECORD THEN
        BEGIN 
          FOR K=0 STEP 1 UNTIL SBRECNMELENW[DOMPTR] - 1 DO
            IF SBRECNAME[DOMPTR+SBRECNAMEPTR[DOMPTR]+K] NQ
                             QALNME[QALPTR+K] THEN
              BEGIN 
              FOR K=0 STEP 1 UNTIL SBARLENGWRDS[ARPTR] - 1 DO 
                IF QALNME[QALPTR+K] NQ SBARNAME[ARPTR+SBARNAMEPTR[ARPTR]
                                                +K] THEN
                BEGIN 
                IF SBITMENTRY[HSHADDR] EQ ITEMS THEN
                  HSHADDR = SBITMSAMENME[HSHADDR];
                 ELSE 
                  HSHADDR = SBRECSMENMEA[HSHADDR];
                IF HSHADDR EQ 0 THEN
                  RETURN; 
                GOTO CKNXTNAME; 
                END 
              QALADR[QALPTR] = ARPTR; 
              QALORD[QALPTR] = AREAORD - 1; 
              RETURN; 
              END 
          QALADR[QALPTR] = DOMPTR;
          QALORD[QALPTR] = SBRECORDINAL[DOMPTR];
          QALPTR = QALPTR + 4;
          IF QALNME[QALPTR] GR 0 THEN 
            BEGIN 
              FOR K=0 STEP 1 UNTIL SBARLENGWRDS[ARPTR] - 1 DO 
                IF QALNME[QALPTR+K] NQ SBARNAME[ARPTR+SBARNAMEPTR[ARPTR]
                                                +K] THEN
                BEGIN 
                  HSHADDR = 0;
                  RETURN; 
                END 
              QALADR[QALPTR] = ARPTR; 
              QALORD[QALPTR] = AREAORD - 1; 
            END 
          RETURN; 
        END 
      FOR K=0 STEP 1 UNTIL SBITMNELENW[DOMPTR] - 1 DO 
        IF SBITMNAME[DOMPTR+SBITMNAMEPTR[DOMPTR]+K] NQ
                             QALNME[QALPTR+K] THEN
          BEGIN 
            IF DOMPTR EQ SBITMDOMADR[DOMPTR] THEN 
              BEGIN 
                HSHADDR = 0;
                RETURN; 
              END 
            DOMPTR = SBITMDOMADR[DOMPTR]; 
            GOTO CKQALNAME; 
          END 
      QALADR[QALPTR] = DOMPTR;
      QALORD[QALPTR] = SBITMORDINAL[DOMPTR];
      QALPTR = QALPTR + 4;
      IF QALNME[QALPTR] GR 0 THEN 
        BEGIN 
          DOMPTR = SBITMDOMADR[DOMPTR]; 
          GOTO CKQALNAME; 
        END 
      RETURN; 
    CKNXTNAME:   #   #
      FOR K=0 STEP 1 UNTIL HASHLENW-1 DO
        IF SBITMNAME[HSHADDR+SBITMNAMEPTR[HSHADDR]+K] NQ HSHNAME[K] THEN
          BEGIN 
            IF SBITMENTRY[HSHADDR] EQ ITEMS THEN
              HSHADDR = SBITMSAMENME[HSHADDR];
             ELSE 
              HSHADDR = SBRECSMENMEA[HSHADDR];
            IF HSHADDR EQ 0 THEN
              RETURN; 
            GOTO CKNXTNAME; 
          END 
      QALPTR = 0; 
      DOMPTR = SBITMDOMADR[HSHADDR];
      GOTO CKQALNAME; 
    END 
  PROC ZEROSCRTCH(NUMTIMES);
    BEGIN 
#**********************************************************************#
#                   Z E R O S C R T C H                                #
#                                                                      #
#   ZEROES OUT SCRATCHBUF.                                             #
#                                                                      #
#**********************************************************************#
       ITEM NUMTIMES; 
      FOR I=0 STEP 1 UNTIL NUMTIMES DO
        SCRATCHWRD[I] = 0;
      SCRTCHPTR = 0;
      RETURN; 
    END 
   END                                                                  016110
  TERM;                                                                 016120
