*DECK CBPASS1                                                           000100
USETEXT TSBDIT,TSBTBL 
      PRGM DL30401;                # THIS IS 4,1 OVERLAY               # DL3A030
    BEGIN                                                               000120
  
  
*CALL COMHDRLEN              DEFINE ENTRY HEADER LENGTHS
  
      DEF  ALIASPTR     #   0#;    # INDEX INTO ALIAS ARRAY            #002493
      DEF  AREA         #   1#;    # AREA TYPE                         #
      DEF  BLANKS       #"          "#;  # BLANKS                      #
      DEF  CWPTR        #   0#;    # INDEX  INTO THE CONTROL WORDS     #
      DEF  DEFINED      #   1#;    # ENTRY BEING HASHED IS DEFINED, AS #
                                   # OPPOSED TO BEING REFERENCED       #
      DEF  DITPTR       #   0#;    # INDEX INTO DIT (ARRAY DITSC)      #002495
      DEF ELEMITM   #1#;                # ITEM TYPE IS ELEMENTRY.      #
      DEF GROUPITM   #0#;               # ITEM TYPE IS GROUP           #
      DEF ITEMS  #3#;                  # ITEM TYPE.                    #
      DEF MAXAREAS #4095#;              # MAXIMUM NUMBER OF AREAS.     #
      DEF MAXRECDS #4095#;              # MAXIMUM NUMBER OF RECORDS.   #
      DEF MAXITEMS #32767#;             # MAXIMUM NUMBER OF ITEMS.     #
      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 QC       #  4#;              # COMPILATION MODE IS QU/CDCS   #
      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 RESERVEP1 #O"1000"#;          # EXTRA MEMORY IN RESERVE      #
      DEF RESMAXP1 #O"2000"#;           # THRESHOLD FOR RELEASING MEM  #
      DEF RLMINCR  #O"0050"#;           # INCREMENT FOR REALM LIST SIZE#
      DEF RPGRPINRPGRP   #3#;           # ITEM TYPE IS REPEATING GROUP #
                                        # WITHIN A REPEATING GROUP.    #
      DEF SCPTR #0#;
      DEF  SQ           #   0#;    # INDEX INTO SQUASHBUF ARRAY        #002500
      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.              #
      XDEF
        BEGIN 
          ARRAY PICTEMP [31];              # CONTAINS THE PICTURE      #
            ITEM PICWORD U(0,0,60);       # SPECIFICATION.             #
          ARRAY MURAL [0:31];           # PICTURE MURAL GENERATED BY   #
            ITEM PICTURWORD U(0,0,60);  # ROUTINE PICTUR               #
  
          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.    #
        END 
      XDEF ITEM MXPICSZ I = 32767;     # MAXIMUM SIZE OF ALPHA-NUMERIC #
                                       # ITEMS                         #
      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 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 DDLCOMP I;              # DDL COMPILATION MODE          #
                                       #    3 = QU SUBSCHEMA           #
                                       #    5 = COBOL SUBSCHEMA        #
          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.                   #
          ITEM REALMSZ;                # REALM LIST LENGTH IN WORDS    #
          ITEM RELFLAG B;                # TRUE = RELATION DIVISION    #
                                         #        SPRCIFIED.           #
          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 SYNTBL;        # D #    # ADDRESS OF THE SYNTAX TABLE.  #000410
          ITEM SYNTBLE;     #   #      # ADDRESS OF THE SYNTAX TABLE.  #000420
          ITEM SWITCHVCTR;  #   #      # ADDRESS OF THE SWITCH VECTOR. #000430
*IF DEF,DEBUG,2 
          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 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 CBSIZE;                 # CALCULATES THE RELATIVE POSIT-#
                                       # IONS OF THE ITEMS WITHIN THE  #
                                       # RECORD.                       #
          PROC DCTINIT;                # ENTRY POINT IN CTLSCAN.       #
          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 DDLPRNT;                # PRINTS WHAT EVER IS IN THE  #
                                       # WORKING STORAGE AREA PASSED #
                                       # TO IT.                      #
          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
        END                                                             000650
  
  
      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
      ARRAY CLASS [0:6];                  # THE VALUES STORED ARE INDEX#
        ITEM CDCSCLASS    U(00,00,60) =   # VALUES TO A SWITCH VECTOR  #
  
           [O"00040512061011121212",      # CLASS 0 - UNSPECIFIED      #
            O"03031312131413121212",      # CLASS 1 - ALPHABETIC       #
            O"02020212071411151212",      # CLASS 2 - NUMERIC          #
            O"01011312131413121212",      # CLASS 3 - ALPHANUMERIC     #
            O"12121212121212121212",      #     UNUSED                 #
            O"03031312131413131212",      # CLASS 5 - ALPHANUMERIC EDIT#
            O"02010512071411151212"];     # CLASS 6 - NUMERIC EDITED   #
      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); 
  
  
      BASED ARRAY RA [0];          # SYSTEM COMMUNICATION AREA(RA+*)   #
        ITEM RAWORD U(0,0,60);
      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 SQEDITLENG U(10,55,05);    # EDIT MURAL LENGTH IN WORDS #
          ITEM SQPICTURE U(10,59,1);      # 1 = PICTURE CLAUSE PRESENT.#001650
          ITEM SQPICTSIZE U(11,54,6);     # PICTURE LENGTH IN CHARACTRS#001670
          ITEM SQNUMINSRTS U(11,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
  
  
      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 BBPOS U;                    # BEGINNING BYTE POSITION FOR   #
                                       # CHARACTER MOVE--L88 ENTRY     #
      ITEM BYTINDX U;                  # BYTE INDEX INTO COLLATING #
                                       # TABLE.                    #
      ITEM DFLAG B;                    # DIAGNOSTIC FLAG.              #
      ITEM DEFAULTUSAGE B = FALSE;     # FLAG TO SET DEFAULT USAGE     #
                                       # IF TRUE USAGE MUST BE SET TO  #
                                       # DISPLAY                       #
      ITEM DTEMP;                      #CONTAINS DISPLAY CODE VALUES   #
                                       # TO BE OR HAVE BEEN CONVERTED  #002160
      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 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
                                       # THE FIRST ITEM OF A RECORD.   #
      ITEM H;                          # SCRATCH ITEM.                 #
      ITEM HASHLENW;
      ITEM HSHADDR;                    # CONTAINS THE WORD ADDRESS OF  #002290
                                       # AN ENTRY NAME PASSED TO THE   #002300
                                       # SYMBOL TABLE HASH ROUTINE.    #002310
      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 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#
                                       # - 25 OF THE 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 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 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 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 SSIGN B;                    # TRUE IF LITERAL -VE           #
  
      ITEM TDECPT I;                   # TARGET DEC. PT. LOCATION      #
      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 WBPTR      I;               # POINTER IN WORKBUF THAT POINTS#
                                       # TO THE CURRENT OR VARIABLE ENT#
      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
           ALIASQLNME,                                                  003130
           ALIASQALLST ,                                                003140
           ALIASLQAL   ,                                                003150
           ALIASRQAL   ,                                                003160
           ALIASSTORNME,                                                003170
           ALIASINIT   ,                                                003180
           REALMALL    ,                                                003190
           REALMALIAS  ,                                                003200
           REALMNAME   ,                                                003210
           RECD1STCK   ,                                                003220
           RECDNAME    ,                                                003230
           RECDWITHIN  ,                                                003240
           ITEMF1CK    ,                                                003250
           ITEMNAME    ,                                                003260
           ITEMDOM     ,                                                003270
           ITEMPICTR   ,                                                003280
           ITEMLOG     ,          # ITEM USAGE IS LOGICAL              #
           ITEMCMPLX   ,          # ITEM USAGE IS COMPLX               #
           ITEMDISP    ,                                                003320
           ITEMUSECK   ,                                                003340
           ITEMOC1INT  ,                                                003350
           ITEMTIMES   ,                                                003360
           ITEMOC2INT  ,                                                003370
           ITEMVOCCK   ,                                                003380
           ITEMOCHSHNM ,                                                003390
           ITEMOCNM1CK ,                                                003400
           ITEMOCNM2CK ,                                                003410
           ITEMVARORD  ,                                                003420
           ITEMASCEND  ,                                                003430
           ITEMOCKYNME ,                                                003440
           ITEMDESCEND ,                                                003450
           ITEMOCQALKY ,                                                003460
           ITEMRESETKY ,                                                003470
           ITEMTYPINDX ,                                                003480
           ITEMSYNC    ,                                                003490
           ITEMLFTSYNC ,                                                003500
           ITEMJUST    ,                                                003510
           LEVELCONVRT ,                                                003520
           LEVEL01     ,                                                003530
           ITEMNMEINDX,                                                 003570
           ENDPASS1,
           CHECKEOT,                                                    003600
           SETEOT,                                                      003610
           ENDSS, 
           ABORT3,
           ITEMEND, 
           REDFINIT,
           REDFCK,
           REDFSIZE,
           REDFOCC, 
           REDFSCN, 
           REDFTERM,
           LEVEL66, 
           LEVEL88, 
           FIND66ITM, 
           CK66LEVEL, 
           CK66ITMTYP,
           SET66GRP,
           FIND266ITM,
           CK66SUBOR, 
           ITMNAME88, 
           ITEMCHK, 
           SETVALUE,
           SETFCONST, 
           SETALLLIT, 
           SETDFLAG,
           CHKLIT1, 
           CHKLIT2, 
           CHKTHRU, 
           VALRTRN, 
           SETWBPTR,
           SPECIALLVL,
           CKOCCKEY,
           SETKEYPTR, 
           STOREKEYADR, 
           ISCOBOL, 
           ADJWBPTR,
           CKFORINDEX,
           STOREDPNME,
           OCCRECISQAL, 
           STOREQAL,
           RECISQAL,
           REDEFEND,
           REDEFLVL66  ,          # SET BWP,BBP AND SIZE OF L66, REDEF #001701
           SETRELFG,
           SETSSFGT,
           CHKMSS,
           ABORT4,
           SETRECPTR, 
           INCRWBPTR; 
      SWITCH FCVECT 
           SETHVALUE, 
           SETLVALUE, 
           SETSPACE,
           SETZEROS;
      SWITCH SETCLASS 
           GROUPCLAS, 
           ALPHACLAS, 
           NUMERICCLAS, 
           ALPHANMCLAS, 
           DISPUSAGE, 
           COMPUSAGE, 
           COMP1USAGE,
           PICNUMCLAS,
           COMP1USAGE,
           COMP2USAGE,
           ERROR166,
           ERROR167,
           ERROR168,
           DOUBLEUSAGE; 
  
#**********************************************************************#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;
      IF DDLCOMP EQ QC THEN        # IF QU/CDCS SUBSCHEMA              #
        SBCWSSTYPE[CWPTR] = "QUC";
      ELSE                         # IF COBOL SUBSCHEMA                #
        SBCWSSTYPE[CWPTR] = "COB";
      SBCWCDCS2SB[CWPTR] = TRUE;   # SET NEW SUBSCHEMA FLAG            #
      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.                                                 #
      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.     #
      IF  SBSCHMA + WBPTR + 25 GR DDLSU  THEN   # UPDATE STORAGE USED. #
        DDLSU = SBSCHMA + WBPTR + 25 ;
      IF ABORTFLAG GR 0 AND RELFLAG THEN
        STDNO;               #ERRORS ENCOUNTERED,SKIP REMAINING SOURCE# 
      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. 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] = C<7,3> HDR4 ;        #DDL VERSION          #
      SBCWCRMVER[CWPTR] = C<0,3>CRMLEV;          #CRM VERSION          #
      SBCWBDATE[CWPTR]  =C<4,5>HDR3A;            #DDL BUILD DATE       #
      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
      HSHTYPE = CURP1;                                                  004290
      STDNO;                                                            004300
  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
  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
  ALIASQALLST:                                                          004960
#**********************************************************************#004970
#                  A L I A S Q A L L S T                               #004980
#                                                                      #004990
#   STORES INTO QUALIFIER LIST POINTER THE OFFSET POINTER TO THE       #005000
#   QUALIFIER LIST ENTRY. RETURN IS TO STDNO.                          #005010
#                                                                      #005020
#**********************************************************************#005030
      ALIASQALPTR[ALIASPTR] = ALPTR;                                    005040
      ALIASLISTP = ALPTR;   # STORE ALIAS LIST LOCATION INTO SCRATCH   #005050
                            # POINTER                                  #005060
      STDNO;                                                            005070
  ALIASQLNME:                                                           005080
#**********************************************************************#005090
#                  A L I A S Q A L N M E                               #005100
#                                                                      #005110
#   STORES THE QUALIFIER NAME INTO SCRATCHBUF. RETURN IS TO STDNO.     #005120
#                                                                      #005130
#**********************************************************************#005140
      FOR I=0 STEP 1 UNTIL CURLENW DO                                   005150
        SCRATCHWRD[SCRTCHPTR+I] = CURWORD[I];                           005160
      QUALNUMBER = QUALNUMBER + 1;   # INCREMENT THE QUALIFICATION     #005170
                                     # COUNTER.                        #005180
      SCRTCHPTR = SCRTCHPTR + CURLENW;   # INCREMENT SCRTCHPTR TO THE  #005190
                                         # NEXT AVAILABLE WORD.        #005200
      STDNO;                                                            005210
  ALIASLQAL:                                                            005220
#**********************************************************************#005230
#                  A L I A S L Q A L                                   #005240
#                                                                      #005250
#   STORES THE LENGTH IN WORDS OF THE QUALIFIER NAME INTO THE LEFT     #005260
#   MOST ITEM OF THE QUALIFIER LIST ENTRY. RETURN IS TO STDNO.         #005270
#                                                                      #005280
#**********************************************************************#005290
      ALIASLQALLEN[ALPTR] = CURLENW;                                    005300
      STDNO;                                                            005310
  ALIASRQAL:                                                            005320
#**********************************************************************#005330
#                  A L I A S R Q A L                                   #005340
#                                                                      #005350
#   STORES THE LENGTH IN WORDS OF THE QUALIFIER NAME INTO THE RIGHT    #005360
#   MOST ITEM OF THE QUALIFIER LIST ENTRY. RETURN IS TO STDNO.         #005370
#                                                                      #005380
#**********************************************************************#005390
      ALIASRQALLEN[ALPTR] = CURLENW;                                    005400
      ALPTR = ALPTR + 1;   # INCREMENT ALPTR TO THE NEXT AVAILABLE WORD#005410
      STDNO;                                                            005420
  ALIASSTORNME:                                                         005430
#**********************************************************************#005440
#                  A L A I S S T O R N M E                             #005450
#                                                                      #005460
#   MOVES THE QUALIFIER NAMES FROM SCRATCHBUF TO THE ALIAS ENTRY.      #005470
#   STORES QUALIFIER POINTER AND NUMBER OF QUALIFIERS. RETURN IS TO    #005480
#   STDNO.                                                             #005490
#                                                                      #005500
#**********************************************************************#005510
      IF ALIASWRD[ALPTR] NQ 0 THEN   # CHECK IF ALPTR POINTS TO THE    #005530
        ALPTR = ALPTR + 1;          # NEXT AVAILABLE WORD.             #005540
      ALIASQALNUMB[ALIASPTR] = QUALNUMBER;   # STORE THE NUMBER OF     #005550
                                            # QUALIFIERS.              #005560
      J = ALPTR;   # STORE QUALIFIER NAME POINTER INTO SCRATCH ITEM.   #005570
    ALIASCONT:                                                          005580
      ALIASLQALPTR[ALIASLISTP] = J;       # STORE POINTER TO QALIFIER. #005590
      J = J + ALIASLQALLEN[ALIASLISTP];   # INCREMENT TO NEXT QAL NAME.#005600
     QUALNUMBER = QUALNUMBER - 1;   # DECREMENT QALIFIER ENTRY NUMBER. #005610
      IF QUALNUMBER EQ 0 THEN   # CHECK IF ALL QUALIFIER POINTERS ARE  #005620
        BEGIN                  # SET. IF SO MOVE THE QUALIFIER NAMES   #005630
          FOR I=0 STEP 1 UNTIL SCRTCHPTR - 1 DO   # FROM SCRATCHBUF TO #005640
            BEGIN               # ALIASBUF.                            #005650
              ALIASQALNME[ALPTR+I] = SCRATCHWRD[I];                     005660
            END                                                         005670
          GOTO ALIASEXIT;                                               005680
       END                                                              005690
      ALIASRQALPTR[ALIASLISTP] = J;   # STORE POINTER TO QALIFIER NAME #005700
      J = J + ALIASRQALLEN[ALIASLISTP];   # INCREMENT POINTER TO NEXT  #005710
                                          # QUALIFIER NAME.            #005720
      ALIASLISTP = ALIASLISTP + 1;   # INCREMENT QUALIFIER LIST POINTER#005730
                                     # TO THE NEXT WORD.               #005740
      QUALNUMBER = QUALNUMBER - 1;   # DECREMENT QUALIFIER ENTRY NUMBER#005750
      IF QUALNUMBER EQ 0 THEN   # CHECK IF ALL QUALIFIER POINTERS ARE  #005760
        BEGIN                   # SET. IF SO MOVE THE QUALIFIER NAMES  #005770
        FOR I=0 STEP 1 UNTIL SCRTCHPTR - 1 DO                           005780
            BEGIN               # FROM SCRATCHBUF TO ALIASBUF.         #005790
              ALIASQALNME[ALPTR+I] = SCRATCHWRD[I];                     005800
            END                                                         005810
         GOTO ALIASEXIT;                                                005820
        END                                                             005830
      GOTO ALIASCONT;   # PROCESS NEXT QUALIFIER POINTER.              #005840
    ALIASEXIT:                                                          005850
      ALPTR = ALPTR + SCRTCHPTR;   # CALC ENTRY LENGTH.                #005860
      FOR I=0 STEP 1 UNTIL SCRTCHPTR-1 DO # ZERO OUT SCRATCHBUF        #005870
        SCRATCHWRD[I] = 0;                                              005880
      ALIASLISTP = 0;                                                   005890
      QUALNUMBER = 0;                                                   005900
      SCRTCHPTR = 0;                                                    005910
      STDNO;                                                            005920
  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
        CURWORD[I] = SCHAREANAME[SCARNAMEPTR[SCPTR]+I]; 
      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
              GOTO ALIAS2;         # IF UNEQUAL, CHECK THE SYNONYM     #
                                   # 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;  # INCREMENT WORD BOUND POINTER  #
            CHECKFL;               # CHECK FIELD LENGTH                #
  
            FOR I=0 STEP 1
              UNTIL K - 1          # ALIAS OR NEW NAME                 #
            DO
              SBARNAME[WBPTR+I] = ALIAS2NME[ALPTR+I]; 
            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
              SBARALIASNME[WBPTR+I] = ALIAS1NME[ALIASPTR+I];
            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] = CURLENW;  # NAME WORD LENGTH           #
          WBPTR = WBPTR + DFSBARLG;  # SET POINTER TO AREA NAME WORD   #
          CHECKFL;                   # CHECK FIELD LENGTH              #
  
          SBARNAMEPTR[ARPTR] = WBPTR - ARPTR;  # AREA NAME POINTER     #
          FOR I=0 STEP 1
            UNTIL CURLENW - 1      # AREA NAME                         #
          DO
            SBARNAME[WBPTR+I] = SCHAREANAME[SCARNAMEPTR[SCPTR]+I];
          WBPTR = WBPTR + CURLENW; # SET POINTER 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 
      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
          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 STDYES.                        #
#                                                                      #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 - 1;   # STORE SOURCE LINE NUMBER.  #
      FOR I=0 STEP 1 UNTIL CURLENW - 1 DO                               007060
        SBARNAME[WBPTR+I] = CURWORD[I];     # STORE AREA NAME.         #
      WBPTR = WBPTR + CURLENW;
      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; 
  
  RECD1STCK:                                                            007320
#**********************************************************************#007330
#                  R E C D 1 S T C K                                   #007340
#                                                                      #007350
#   CONVERTS LEVEL NUMBER FROM DISPLAY CODE TO BINARY. CHECKS LEVEL    #007360
#   NUMBER TO DETERMINE IF SUBJECT ENTRY BEING DEFINED IS A RECORD     #007370
#   ENTRY. RETURNS TO STDYES IF IT IS A RECORD ENTRY, ELSE RETURN IS TO#007380
#   STDNO.                                                             #007390
#                                                                      #007400
#**********************************************************************#007410
      RECPTR = WBPTR;       # SET POINTER TO FIRST WORD OF ENTRY.      #007420
      DTEMP = CURWORD[0]; # STORE DISPLAY CODE LEVEL NUMBER.           #
      DISPDECTOBIN;   # PROC THAT CONVERTS DISPLAY CODED DECIMAL VALUES#007440
                      # TO BINARY.                                     #007450
      SBRECTYPE[RECPTR] = RECORD;   # SET ENTRY TYPE TO RECORD.        #007460
      IF ITEMP EQ 1 THEN   # CHECK IF 01 LEVEL NUMBER (RECORD).        #007470
      SBCWFRSTRECA[CWPTR] = RECPTR; # STORE THE WORD ADDRESS OF THE    #
                                    # FIRST RECORD ENTRY.              #
      TEMPERRCNT = ERRCNTR; 
      IF ITEMP EQ 1 THEN  # CHECK IF 01 LEVEL NUMBER (RECORD).         #
        STDYES;                                                         007480
      STDNO;                                                            007490
  
  SETRECPTR:  
#**********************************************************************#
#                                                                      #
#                  S E T R E C P T R                                   #
#                                                                      #
#   SETS POINTER TO FIRST WORD OF RECORD ENTRY. ON SUBSEQUENT CALLS,   #
#   SETS POINTER TO FIRST WORD OF NEXT RECORD.  RETURN IS TO STDYES.   #
#                                                                      #
#**********************************************************************#
      RECPTR = WBPTR; 
      STDYES; 
  
  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#
      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 - 1;   # STORE SOURCE LINE NUMBER.#
      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); 
      SBRECWITHINO[RECPTR] = SBARORDINAL[M];  # STORE AREA ORDINAL.    #
      SBRECRLMADR[RECPTR] = M; # STORE THE WORD ADDRESS OF THE OWNER   #
                               # REALM.                                #
      ARPTR = M;
      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
  ITEMF1CK:                                                             008860
#**********************************************************************#008870
#                  I T E M F 1 C K                                     #008880
#                                                                      #008890
#   CONVERTS THE DISPLAY CODE VALUE OF THE LEVEL NUMBER TO BINARY AND  #008900
#   CHECKS TO SEE IF IT FALLS IN THE ITEM RANGE OF FORMAT-1. IF LEVEL  #008910
#   NUMBER IS WITH IN FORMAT-1 RANGE THEN RETURN IS TO STDYES ELSE     #008920
#   RETURN IS TO STDNO.                                                #008930
#                                                                      #008940
#**********************************************************************#008950
      ITEMPTR = WBPTR; # SET POINTER TO THE 1ST WRD OF THE ITEM ENTRY. #
      DTEMP = CURWORD[0]; # STORE DISPLAY CODE LEVEL NUMBER.           #
      DISPDECTOBIN;  # PROC THAT CONVERTS DISPLAY CODED DECIMAL VALUES #008970
                     # TO BINARY.                                      #008980
      IF ITEMP LS 2 OR ITEMP GR 49 THEN # CHECK FORMAT 1 RANGE.        #008990
        BEGIN                                                           009000
          SBITMLEVEL[WBPTR] = 2;  # READJUST LEVEL NUMBER.             #009010
          STDNO;                                                        009020
        END                                                             009030
      SBITMLEVEL[WBPTR] = ITEMP; # STORE LEVEL NUMBER IN SQUASHBUF.    #009040
      SBRECNXITEMP[RECPTR] = ITEMPTR - RECPTR; # STORE OFFSET POINTER  #
                                            # TO THE FIRST ITEM ENTRY. #
      IWSA[9] = "** ORDINAL"; 
      STDYES;                                                           009050
  ITEMNAME:                                                             009060
#**********************************************************************#009070
#                  I T E M N A M E                                     #009080
#                                                                      #009090
#   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
      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.         #
      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 
  
                # CHECK IF ALIAS-NAME-2 IS QUALIFIED.                  #
                IF ALIASQALPTR[ALIASPTR] GR 0 THEN
                  BEGIN 
                    J = ITEMPTR;
                    M = 0;              # BBP OF QUALIFIER NAME PTR.   #
                    K = ALIASPTR + ALIASQALPTR[ALIASPTR]; 
                                        # GET OFFSET TO QUALIFIER LIST.#
  
                    # STEP THROUGH QUALIFIER NAME(S), COMPARING THEM   #
                    # AGAINST THE DOMINANT ITEM(S).                    #
                    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 
  
                            # COMPARE RECORD NAME TO QUALIFIER NAME.   #
                            FOR N=0 STEP 1 UNTIL
                             SBRECNMELENW[RECPTR] - 1 DO
                              BEGIN 
  
                              # IF NAMES DO NOT MATCH, THEN SEARCH     #
                              # SYNONYM CHAIN.  FOR THE CASE WHERE TWO #
                              # ALIAS NAMES ARE THE SAME BUT ARE       #
                              # QUALIFIED TO BE IN DIFFERENT RECORDS.  #
                              IF SBRECNAME[SBRECNAMEPTR[RECPTR]+RECPTR
                                 +N] NQ 
                               ALIASQALNME[L+N] THEN
                                BEGIN 
                                  GOTO NEXTALIAS; 
                                END 
                              END 
                            TEST I; 
                          END 
  
                          # COMPARE DOMINANT ITEM NAME TO QUALIFIER    #
                          # NAME.                                      #
                          FOR N=0 STEP 1 UNTIL SBITMNELENW[J] - 1 DO
                            BEGIN 
  
                            # IF NAMES DO NOT MATCH, THEN GET THE NEXT #
                            # HIGHER LEVEL DOMINANT ITEM.              #
                            IF SBITMNAME[SBITMNAMEPTR[J]+J+N] NQ
                               ALIASQALNME[L+N] 
                             THEN 
                               BEGIN
                                 GOTO CKDOM;
                               END
                            END 
  
                          # ADJUST BBP OF QUALIFIER NAME PTR TO GET    #
                          # NEXT NAME.                                 #
                          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
NEXTALIAS:  
              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 - 1;  # STORE SOURCE LINE NUMBER.#
      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.                        #
          IF SBITMCLASS[J] EQ 0 AND SBITMUSAGE[J] EQ 0 THEN # CHECK IF #
                # PICTURE OR USAGE WAS SPECIFIED IN THE PRIOR ITEM ENTY#
            IF SBITMTYPE[J] EQ ELEMITM OR 
              SBITMTYPE[J] GR RPGRPINRPGRP AND
                SBITMTYPE[J] LS REPGRPVD OR 
                  SBITMTYPE[J] EQ VECTORVD THEN 
                    BEGIN 
                    J = DOMADR; 
                    FOR I=0 WHILE J NQ RECPTR DO # NO PICTURE OR USAGE #
                      BEGIN # WAS SPECIFIED FOR ELEMENTRY ITEM. CHECK  #
                                            # IF USAGE WAS SPECIFIED AT#
                                            # THE GROUP ITEM LEVEL.    #
                        IF SBITMCLASS[J] EQ 0 AND SBITMUSAGE[J] EQ 0
                          THEN
                              BEGIN 
                                J = SBITMDOMADR[J]; 
                                TEST I; 
                              END 
                        GOTO CKREPDOM;
                      END 
                    DIAGDL(165);
                    END 
          GOTO CKREPDOM;
        END                                                             010040
      IF SBITMLEVEL[J] LS ITEMP THEN  # CHECK IF THE PRIOR ITEM ENTRY  #010050
        BEGIN                     # HAS SMALLER LEVEL NUMBER.          #010060
          IF SBITMCLASS[J] GR 0 THEN # CHECK IF PICTURE WAS SPECIFIED.# 
            IF SBITMLEVEL[ITEMPTR] LS 50 THEN 
      # CHECK IF ITEM IS LEVEL 66 OR 88.                               #
              DIAGDL(170);
          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;
          SBITMXPICSIZ[J] = 0;
          SBITMUSESIZE[J] = 0;
          GOTO CKREPDOM;
        END                                                             010100
      IF SBITMLEVEL[J] EQ O"62" AND NOT L66ERRFLG THEN
        BEGIN 
          L66ERRFLG = TRUE; 
          DIAGDL(196);
        END 
       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 ITEMS SUBORDINATE TO NON-REPEATING GROUP, THEN ZERO  #
# OUT THE DOMINANT ORDINAL FIELD.  CDCS NEEDS THE DOMINANT ORDINAL     #
# NUMBER ONLY IF ITEM IS SUBORDINATOR OF THE REPEATING GROUP.  DDL     #
# NEEDS THE ADDRESS OF THE DOMINANT ITEM WHETHER IT SUBORDINATE TO A   #
# REPEATING GROUP OR NOT.                                              #
#       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.                #
              STDYES;                # RETURN YES IF IT IS             #
            END 
          J = SBITMDOMADR[J];        # ELSE GET NEXT DOMINANT ITEM     #
        END 
      SBITMDOMORD[ITEMPTR] = 0;    # DOMINANT ITEM IS A NON-REPEATING  #
      STDYES;                      # GROUP, HENCE ZERO OUT THE DOMINANT#
                                   # ORDINAL FIELD OF THE CURRENT ITEM #
  ITEMPICTR:                                                            010150
#**********************************************************************#010160
#                  I T E M P I C T R                                   #010170
#                                                                      #010180
#   SETS THE PICTURE FLAG IN SQASHBUF. CHECKS IF THE PICTURE IS GREAT  #010190
#   ER THAN 30 CHARACTERS. IF SO THE PICTURE IS MOVED INTO PICTEMP,    #010200
#   WORD BY WORD, TRUNCATING THE RIGHT MOST CHARACTERS. RETURN IS TO   #010210
#   STDNO. IF THE PICTURE LITERAL IS NOT GREATER 30 CHARACTERS, THE    #010220
#   PICTURE LITERAL IS MOVED INTO PICTEMP AND A SPACE IS STORED        #010230
#   AFTER THE LAST CHARACTER OF THE LITERAL. RETURN IS TO STDYES.      #010240
#                                                                      #010250
#**********************************************************************#010260
      SQPICTURE[SQ] = 1; # SET PICTURE FLAG.                           #010270
      I = 0;   # INITIALIZE SCRATCH ITEMS.                             #
      J = 0;
      K = 0;
      IF NEXLENG GR 30 THEN   # CHECK IF PICTURE LITERAL EXCEEDED ITS  #
        BEGIN                 # MAXIMUM SIZE.                          #
          SQPICTSIZE[SQ] = 30;   # STORE LENGTH IN CHARACTERS OF THE   #
          NEXLENG = 30;          # PICTURE LITERAL.                    #
          DIAGDL( 127 );
        END 
      FOR I=0 STEP 1 UNTIL NEXLENG - 1 DO 
        BEGIN 
          PICWORD[I] = B<J*6,6>NEXWRD[K];   # STORE PIC CHARACTER, ONE #
          IF J EQ 9 THEN  # CHECK IF AT LAST CHARACTER IN WORD.        #
            BEGIN 
              K = K + 1;   # INCREMENT WORD POINTER TO THE NEXT WORD.  #
              J = 0;  # SET THE CHARACTER POINTER TO THE 1ST CHARACTER.#
            END 
           ELSE 
            J = J + 1;  # INCREMENT CHARACTER POINTER TO THE NEXT CHAR.#
        END 
      IF PICWORD[0] EQ O"45"             # IF LEADING + SIGN           #
        OR PICWORD[0] EQ O"46"           # OR LEADING - SIGN           #
        OR PICWORD[NEXLENG-1] EQ O"45"   # OR TRAILING + SIGN          #
        OR PICWORD[NEXLENG-1] EQ O"46"   # OR TRAILING - SIGN          #
      THEN
        SQSIGNFLG[SQ] = 1;               # SET SIGN FLAG               #
      PICWORD[NEXLENG] = O"55"; # PICTURE CRACKING ROUTINE NEEDS A     #
                              # TERMINATOR.                            #
      SQPICTSIZE[SQ] = NEXLENG;   # STORE LENGTH IN CHARACTERS OF THE  #010430
                                        # PICTURE LITERAL.             #
      PICTUR(LOC(SQUASHBUF));  # CALL THE PICTURE KRACKING ROUTINE.    #
      IF SQITEMSIZE[SQ] EQ 0 THEN  # IF PICTURE IN ERROR,              #
        SQCLASS[SQ] = 1;           # SET CLASS TO 1.                   #
      SBITMIPICSIZ[ITEMPTR] = SQITEMSIZE[SQ]; # STORE PICTURE SIZE     #
                            # INCLUDING INSERTS.                       #
      SBITMXPICSIZ[ITEMPTR] = SBITMIPICSIZ[ITEMPTR] - SQNUMINSRTS[SQ];
                                   # PICTURE SIZE EXCLUDING INSERTS    #
      SBITMCLASS[ITEMPTR] = SQCLASS[SQ];  # STORE ITEM CLASS ( CB CLAS)#
      SBITMPTLOC[ITEMPTR] = SQPOINTCONT[SQ]; # STORE POINT LOCATION.   #
      IF SBITMPTLOC[ITEMPTR] GR 0 THEN # CHECK IF DECIMAL POINT IS SPEC#
                                       # IFIED IN THE PICTURE LITERAL. #
        SBITMLFTPT[ITEMPTR] = -SQPOINTLORR[SQ]; # STORE INDICATOR.     #
                          # DECIMAL POINT IS TO THE LEFT OT RIGHT.     #
      IF SQSIGNFLG[SQ] EQ 1 THEN
        SBITMSIGNF[ITEMPTR] = TRUE;    # SET SIGN FLAG.                #
      IF SQITEMSIZE[SQ] EQ 0       # IF ERROR IN PICTURE               #
      THEN
        STDNO;                     # RETURN                            #
  
      IF DDLCOMP NQ QC THEN           # IF COMPILATION MODE IS NOT QU  #
        BEGIN 
          IF SQPOINTACTL[SQ] GR 0 
            OR SQNUMINSRTS[SQ] GR 0 
            OR SQEDITLENG[SQ] GR 0 THEN  # IF EDITING CHARACTERS WERE  #
                                      # SPECIFIED                      #
              DIAGDL(157);           # DIAGNOSTIC - EDITING NOT ALLOWED#
        END 
  
      STDNO;                                                            010740
  ITEMDISP:                                                             010750
#**********************************************************************#010760
#                  I T E M D I S P                                     #010770
#                                                                      #010780
#   SETS A FLAG INDICATING THAT NO USAGE CLAUSE HAS BEEN SPECIFIED.    #
#   USAGE WILL DEFAULT TO DISPLAY.                                     #
#                                                                      #010810
#**********************************************************************#010820
      DEFAULTUSAGE = TRUE;                # SET DEFAULT USAGE FLAG     #
      STDNO;                                                            010840
  
ITEMLOG:  
#**********************************************************************#
#                  I T E M L O G                                       #
#                                                                      #
#     SET FIELDS INDICATING THAT THE ITEM HAS USAGE LOGICAL            #
#     IF COMPILATION MODE IS NOT QU/CDCS RETURN IS TO STDYES.          #
#     OTHERWISE ITEMCLASS AND USE SIZE ARE SET AND RETURN IS TO STDNO. #
#     RETURN IS TO STDNO.                                              #
#                                                                      #
#**********************************************************************#
  
      IF DDLCOMP NQ QC                 # IF COMPILATION MODE IS QC/CDCS#
      THEN
        STDYES; 
  
      USAGETYPE = 0;
      SBITMDBCLASS[ITEMPTR] = 17;      # SET CLASS                     #
      SBITMUSESIZE[ITEMPTR] = 10;      # SET USE SIZE                  #
      STDNO;
  
  
ITEMCMPLX:  
#**********************************************************************#
#                  I T E M C M P L X                                   #
#                                                                      #
#     SET FIELDS INDICATING THAN THE ITEM HAS USAGE COMPLEX            #
#     IF COMPILATION MODE IS NOT QU/CDCS, RETURN IS TO STDYES.         #
#     OTHERWISE, RETURN IS TO STDNO.                                   #
#                                                                      #
#**********************************************************************#
  
      IF DDLCOMP NQ QC                 #IF COMPILATION MODE NOT QU/CDCS#
      THEN
        STDYES; 
  
      USAGETYPE = 0;
      SBITMDBCLASS[ITEMPTR] = 15;      # SET CLASS                     #
      SBITMUSESIZE[ITEMPTR] = 20;      # SET USE SIZE                  #
      STDNO;
  
  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 USAGETYPE WAS NOT SPECIFIED IN THE GROUP ITEM, A     #
#   CHECK IS MADE TO SEE IF DEFAULT USAGE SHOULD BE USED (DISPLAY)     #
#   IF TRUE, CURP1 IS SET TO 1. IF DEFAULT USAGE IS NOT TO BE USED     #
#   (USAGE CLAUSE PRESENT), THEN THE VALUE OF CURP1 IS USED AS THE     #
#   USAGE TYPE.                                                        #
#                                                                      #011070
#**********************************************************************#011080
      IF DEFAULTUSAGE THEN
        BEGIN 
          CURP1 = 1;
          DEFAULTUSAGE = FALSE; 
        END 
      USAGETYPE = CURP1;
      J = SBITMDOMADR[ITEMPTR]; # STORE ADDRESS OF DOMINANT ITEM.      #
      IF J NQ RECPTR THEN    # CHECK IF DOMINANT ITEM IS A             #
        BEGIN                        # RECORD ENTRY                    #011110
          IF SBITMUSAGE[J] NQ 0 THEN # CHECK IF USAGE TYPE IS SPECIFIED#011120
            BEGIN                    # IN THE DOMINANT ITEM.           #011130
              IF SBITMUSAGE[J] NQ USAGETYPE THEN # COMPASE USAGETYPE OF#011140
                BEGIN  # THE DOMINANT ITEM WITH THE CURRENT ITEM.      #011150
                  SBITMUSAGE[ITEMPTR] = SBITMUSAGE[J]; # STORE USAGE   #011160
                  STDNO;                                                011170
               END                                                      011180
            END                                                         011190
        END                                                             011200
      SBITMUSAGE[ITEMPTR] = USAGETYPE; # STORE USAGE TYPE.             #011210
      STDYES;                                                           011220
  ITEMOC1INT:                                                           011230
#**********************************************************************#011240
#                  I T E M O C 1 I N T                                 #011250
#                                                                      #011260
#   CONVERTS DISPLAY CODED INTEGER VALUE SPECIFIED IN THE OCCURS CLAUSE#011270
#   TO BINARY AND STORES IT INTO A TEMPORARY CELL. RETURN IS TO STDNO. #011280
#                                                                      #011290
#**********************************************************************#011300
      DTEMP = CURWORD[0]; # STORE DISPLAY CODE LEVEL NUMBER.           #
      DISPDECTOBIN;  # PROC THAT CONVERTS DISPLAY CODED DECIMAL VALUES #011340
                     #TO BINARY.                                       #011350
      SEPTR = WBPTR;         # SET SUB-ENTRY POINTER #
                                                         # CHECK IF    #
      ITEMINT1 = ITEMP; # STORE BINARY VALUE.                          #011360
      DTEMP = O"55";   # INITIALIZE DTEMP.                             #
      STDYES;                                                           011370
  ITEMTIMES:                                                            011380
#**********************************************************************#011390
#                  I T E M T I M E S                                   #011400
#                                                                      #011410
#   STORES AN OFFSET POINTER IN THE HEADER WORDS OF THE CURRENT ITEM   #011420
#   ENTRY TO THE OCCURS ENTRY. STORE THE NUMBER OF OCCURENCES INTO THE #011430
#   OCCURS ENTRY. RETURN IS TO STDNO                                   #011440
#                                                                      #011450
#**********************************************************************#011460
      SBITMOCCURP[ITEMPTR] = WBPTR - ITEMPTR; # STORE OFFSET POINTER TO#
                                              # THE OCCURS ENTRY.      #
      SBITMHIBNDS[WBPTR] = ITEMINT1; # STORE NUMBER OF OCCURENCES.     #011490
      WBPTR = WBPTR + 1;
      IF DOMADR NQ RECPTR THEN # CHECK IF THE DOMINANT ITEM IS THE REC #
        BEGIN                  # ENTRY.                                #
          IF SBITMOCCURP[DOMADR] GR 0 THEN  # CHECK IF THE DOMINANT    #
                 # ITEM IS SUBORDINATE TO AN OCCURS OR HAS AN OCCURS.  #
          BEGIN 
            SBITMTYPE[ITEMPTR] = VECTINRPG;   # ITEM IS A VECTOR IN A  #
                                              # REPEATING GROUP.       #
            STDNO;
          END 
        END 
      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
#   CONVERTS DISPLAY CODED INTEGER VALUE SPECIFIED IN THE OCCURS CLAUSE#011550
#   TO BINARY. COMPARES THE VALUE OF INT-1 WITH CURRENT INTEGER VALUE  #011560
#   TO INSURE THAT THE CURRENT VALUE IS GREATER. INT-1 AND INT-2 IS    #011570
#   THEN STORED IN THE OCCURS ENTRY OF THE SUBJECT ENTRY ALONG WITH THE#011580
#   OFFSET POINTER TO THE OCCURS ENTRY. IF INT-1 IS LARGER THAN INT-2  #011590
#   RETURN IS TO STDNO WHERE STD ISSUES DIAGNOSTIC 132, ELSE RETURN IS #011600
#   TO STDYES.                                                         #011610
#                                                                      #011620
#**********************************************************************#011630
      DTEMP = CURWORD[0]; # STORE DISPLAY CODE LEVEL NUMBER.           #
      DISPDECTOBIN;  # PROC THAT CONVERTS DISPLAY CODED DECIMAL VALUES #011650
                     # TO BINARY.                                      #011660
      SBITMDEPNDON[WBPTR] = TRUE; # SET DEPENDING ON FLAG.             #011670
      SBITMOCCURP[ITEMPTR] = WBPTR - ITEMPTR; # STORE OFFSET POINTER TO#
                                              # THE OCCURS ENTRY.      #
                                    # ENTRY.                           #011690
      SBITMLOWBNDS[WBPTR] = ITEMINT1; # STORE INTEGER-1 VALUE.         #011700
      SBITMTYPE[ITEMPTR] = VECTORVD; # ITEM IS A VECTOR OF VARIABLE DEM#
      IF ITEMINT1 GQ ITEMP         # IF INTEGER-1 GT INTEGER-2         #
      THEN
        STDNO;
      SBITMHIBNDS[WBPTR] = ITEMP;     # STORE INTEGER-2 VALUE.         #011780
      WBPTR = WBPTR + 1;   # INCREMENT POINTER TO THE NEXT AVAILABLE   #011790
      STDYES;              # WORD IN WORKBUF.                          #011800
  ITEMVOCCK:                                                            011810
#**********************************************************************#011820
#                  I T E M V O C C K                                   #011830
#                                                                      #011840
#   CHECK THE WITHIN OCCURS FIELD AND THE OFFSET POINTER TO THE OCCURS #011850
#   ENTRY OF THE DOMINANT POINTER TO SEE IF THERE NON-ZERO. IF NON-ZERO#011860
#   THE SUBJECT ITEM DEFINITION IS ILEGAL BECAUSE A VARIABLE OCCURENCE #011870
#   DATA ITEM CAN BE SUBORDINATE TO A DATA ITEM WITH AN OCCURS CLAUSE. #011880
#   RETURN IS TO STDNO. AND STD ISSUES DIAGNOSTIC 135. IF ZERO RETURN  #011890
#   IS TO STDYES.                                                      #011900
#                                                                      #011910
#**********************************************************************#011920
      IF DOMADR NQ RECPTR THEN # CHECK IF THE DOMINANT ITEM IS THE REC-#
                               # ORD ENTRY.                            #
        IF SBITMOCCURP[DOMADR] GR 0 THEN  # CHECK IF DOMINANT ITEM HAS #
                                          # AN OCCURS.                 #
          STDNO;
      STDYES; 
  ITEMOCHSHNM:                                                          011960
#**********************************************************************#011970
#                  I T E M O C H S H N M                               #011980
#                                                                      #011990
#   SETS UP THE ENTRY CONDITIONS FOR THE SYMBOL TABLE HASH ROUTINE.    #012000
#   RETURN IS TO STDNO.                                                #012010
#                                                                      #012020
#**********************************************************************#012030
      DUPFLAG = 0;                                                      012040
      HSHUNDEF = 0;                                                     012050
      HSHTYPE = ITEMS;                                                  012060
      HSHREFDEF = REFERENCE;                                            012070
      STDNO;                                                            012080
  ITEMOCNM1CK:                                                          012090
#**********************************************************************#012100
#                  I T E M O C N M 1 C K                               #012110
#                                                                      #012120
#   USING THE PRIOR POINTER, A BACKWARD SCAN TAKES PLACE LOOKING FOR  # 
#   THE DEPENDING ON NAME. IF FOUND, RETURN IS TO STDYES. IF NOT FOUND# 
#   RETURN IS TO STDNO WHERE STD ISSUES DIAGNOSTIC 134.               # 
#                                                                     # 
#*********************************************************************# 
      HASHNAME; 
      IF HSHADDR EQ 0 OR HSHADDR LS RECPTR OR HSHADDR GR ITEMPTR THEN 
        BEGIN 
          ZEROQAL;
          STDNO;
        END 
      STDYES; 
  ITEMOCNM2CK:                                                          012270
#**********************************************************************#012280
#                  I T E M O C N M 2 C K                               #012290
#                                                                      #012300
#   CHECKS IF THE DEPENDING ON DATA NAME IS NOT COMP-2 OR  DISPLAY.    #012310
#   IF COMP-2 OR DISPLAY RETURN IS TO STDNO AND STD ISSUES DIAGNOSTIC  #012320
#   136. ELSE RETURN IS TO STDNO.                                      #012330
#                                                                      #012340
#**********************************************************************#012350
      IF SBITMRNRDPTR[HSHADDR] NQ 0 THEN
        STDNO;  # CHECK IF DEPENDING ON NAME IS SPECIFIED IN A REDEFINE#
                # CLAUSE.                                              #
      IF SBITMUSAGE[HSHADDR] EQ 6 OR SBITMUSAGE[HSHADDR] EQ 1 THEN      012360
        STDNO;                                                          012370
      STDYES;                                                           012380
  ITEMVARORD:                                                           012390
#**********************************************************************#012400
#                  I T E M V A R O R D                                 #012410
#                                                                      #012420
#   STORES THE ADDRESS AND THE ORDINAL NUMBER OF THE DEPENDING ON DATA #012430
#   NAME INTO THE SUBJECT ITEM ENTRY. RETURN IS TO STDNO.              #012440
#                                                                      #012450
#**********************************************************************#012460
      SBITMOCCLDNA[WBPTR]  = HSHADDR; # STORE ADDRESS OF DATA NAME.    #012470
      SBITMOCCLDNO[WBPTR]  = SBITMORDINAL[HSHADDR]; # STORE ORDINAL    #012480
                              # NUMBER OF DEPENDING ON DATA NAME.      #012490
      WBPTR = WBPTR + 1;
      FOR QALPTR = 0 STEP 4 WHILE QALNME[QALPTR] NQ 0 DO
        BEGIN 
          SBITMOCCLNXT[WBPTR-1] = TRUE; 
          SBITMOCCLQAL[WBPTR-1] = TRUE; 
          SBITMOCCLDNA[WBPTR] = QALADR[QALPTR]; 
          SBITMOCCLDNO[WBPTR] = QALORD[QALPTR]; 
          WBPTR = WBPTR + 1;
        END 
      ZEROQAL;
      STDNO;                                                            012500
  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;
    STOREQAL:   #   # 
      QALNME[QALPTR] = CURWORD[0];
      QALNME[QALPTR+1] = CURWORD[1];
      QALNME[QALPTR+2] = CURWORD[2];
      QALPTR = QALPTR + 4;
      STDNO;
  STOREDPNME:   #   # 
      HSHNAME[0] = CURWORD[0];
      HSHNAME[1] = CURWORD[1];
      HSHNAME[2] = CURWORD[2];
      HASHLENW = CURLENW; 
      STDNO;
   OCCRECISQAL:   #   # 
      FOR I=0 STEP 1 UNTIL SBRECNMELENW[RECPTR] - 1 DO
        QALNME[QALPTR+I] = SBRECNAME[RECPTR+SBRECNAMEPTR[RECPTR]+I];
      QALPTR = QALPTR + 4;
      STDNO;
  ITEMASCEND:                                                           012510
#**********************************************************************#012520
#                  I T E M A S C E N D                                 #012530
#                                                                      #012540
#   STORES THE ASCENDING TYPE INTO A SCRATCH CELL. RETURN IS TO STDNO. #012550
#                                                                      #012560
#**********************************************************************#012570
      ITEMASCDESC = 2;                                                  012580
      OCCKEYFLAG = SBITMLEVEL[ITEMPTR]; # STORE THE LEVEL NUMBER OF THE#
                # ITEM THAT THE OCCURS KEY ARE ARE DEFINED IN.         #
      STDNO;                                                            012590
  ITEMOCKYNME:                                                          012600
#**********************************************************************#012610
#                  I T E M O C K Y M E                                 #012620
#                                                                      #012630
#   STORES THE KEY NAME AND ITS LENGTH IN WORDS INTO SCRATCHBUF. RETURN#012640
#   IS TO STDNO.                                                       #012650
#                                                                      #012660
#**********************************************************************#012670
      SCRTOCCKYA[SCRTCHPTR] = ITEMPTR; # STORE ADDRESS OF CURRENT ITEM #012680
                                   # ENTRY.                            #012690
      SCRTOCCKYTY[SCRTCHPTR] = ITEMASCDESC; # STORE KEY TYPE           #012700
      SCRTOCCKYLN[SCRTCHPTR] = CURLENW; # STORE LENGTH IN WORDS OF KEY #012710
                                        # NAME.                        #012720
      SCRTOCCKYLC[SCRTCHPTR] = CURLENG; # STORE THE LENGTH OF ITEM OR  #
                                        #INDEX NAME IN CHARACTERS.     #
      SCRTOCCKYNX[SCRTCHPTR] = CURLENW + 1; # SET NEXT POINTER TO THE  #012730
                                            # NEXT KEY ENTRY.          #012740
      FOR I=0 STEP 1 UNTIL CURLENW - 1 DO                               012750
        SCRTOCCKYNM[SCRTCHPTR+I] = CURWORD[I]; # STORE KEY NAME.       #012760
      IF ITEMASCDESC EQ 1 THEN # CHECK IF ENTRY IS INDEX. IF SO STORE  #
                 # THE NUMBER OF WORDS FOR THE INDEX NAME ENTRY.       #
        WBPTRCNTR = WBPTRCNTR + CURLENW + 1;
       ELSE 
        WBPTRCNTR = WBPTRCNTR + 1;
      SCRTCHPTR = SCRTCHPTR + CURLENW + 1;  # INCREMENT POINTER TO THE #012770
                                           # NEXT ENTRY.               #012780
      SCRATCHWRD[SCRTCHPTR] = 0;   # ZERO OUT FIRST WORD OF THE NEXT   #012790
                                   # ENTRY. WHEN READING SCRATCHBUF THE#012800
                                   # READ STOPS WHEN A ZERO WORD IS    #012810
                                   # REACHED.                          #012820
      STDNO;                                                            012830
  STOREKEYADR:   #   #
      FRSTADDR = SCRTOCCKYA[SCRTCHPTR]; 
      J = FRSTADDR + SBITMOCCURP[FRSTADDR] + 1; 
      I = J;
      SBITMOCCKNXT[J-1] = TRUE; 
      FOR J = J STEP 1 WHILE SBITMOCCWRD[J] NQ 0 DO 
        TEST J; 
      IF J NQ I THEN
        SBITMOCCLNXT[J-1] = TRUE; 
    SCANKEY:   #   #
      I = SCRTCHPTR;
      FOR K=0 STEP 1 UNTIL SCRTOCCKYLN[I] - 1 DO
        HSHNAME[K] = SCRTOCCKYNM[I+K];
      HASHLENW = SCRTOCCKYLN[I];   # STORE KEY NAME LENGTH IN WORDS    #
      FOR I=I+SCRTOCCKYNX[I] STEP SCRTOCCKYNX[I]
        WHILE SCRTOCCKYTY[I] EQ 0 AND SCRATCHWRD[I] GR 0 DO 
          FOR K=0 STEP 1 UNTIL SCRTOCCKYLN[I] - 1 DO
            BEGIN 
              QALNME[QALPTR + K] = SCRTOCCKYNM[I + K];
              QALPTR = QALPTR + 4;
            END 
      HASHNAME; 
      IF HSHADDR EQ 0 OR HSHADDR LS FRSTADDR THEN 
        BEGIN 
          C<0,10>N = NBRLINE; 
          CONVLNENBR(SBITMSRCLNEN[FRSTADDR]); 
          DIAGDL(195);
          NBRLINE = C<0,10>N; 
        END 
      IF HSHADDR NQ FRSTADDR THEN 
        BEGIN 
          N = SBITMDOMADR[HSHADDR]; 
          FOR M=0 WHILE N GR FRSTADDR DO
            N = SBITMDOMADR[N]; 
          IF N LS FRSTADDR THEN 
          BEGIN 
          C<0,10>N = NBRLINE; 
            CONVLNENBR(SBITMSRCLNEN[FRSTADDR]); 
          DIAGDL(193);
          NBRLINE = C<0,10>N; 
          END 
        END 
      IF HSHADDR GR LASTADDR THEN 
        LASTADDR = HSHADDR; 
      KEYSTORE; 
      SCRTCHPTR = I;
      IF SCRATCHWRD[SCRTCHPTR] NQ 0 AND SCRTOCCKYTY[SCRTCHPTR] NQ 1 THEN
        # CHECK IF THERE IS ANOTHER KEY ENTRY IN SCRATCHBUF.           #
        GOTO SCANKEY; # THERE IS ANOTHER KEY ENTRY.                    #
      FOR K=FRSTADDR STEP SBITMNEXTP[K] WHILE K LQ LASTADDR 
        AND SBITMNEXTP[K] NQ 0 DO  # CHECK                             #
                   # IF THE ENTRIES FROM THE ITEM ENTRY WHERE THE KEY  #
                   # ITEMS WHERE DEFINED TO THE LAST KEY ITEM DEFINED  #
                   # CONTAINS AN OCCURS CLAUSE ( WHICH IS INVALID).    #
        IF SBITMOCCURP[K] GR 0 AND K NQ FRSTADDR THEN 
          BEGIN 
          C<0,10>N = NBRLINE; 
            CONVLNENBR(SBITMSRCLNEN[FRSTADDR]); 
          DIAGDL(194);
          NBRLINE = C<0,10>N; 
          END 
      IF SCRTOCCKYTY[SCRTCHPTR] NQ 1 THEN 
        IF SCRTOCCKYTY[0] NQ 1 THEN # CHECK FOR INDEX ENTRY.           #
          GOTO INITINDEX; # DOWN THE LINE.                             #
         ELSE 
          SCRTCHPTR = 0; # THERE IS AN INDEX ENTRY AND IT IS THE FIRST #
                         # ENTRY IN SCRATCHBUF.                        #
      STOREINDEX; # STORES THE INDEX INFO FROM SCRATCHBUF INTO WORKBUF.#
    INITINDEX:   #   #
        # INITIALIZE SCRATCH BUFFERS AND SCRATCH CELLS.                #
      ZEROSCRTCH(100);
      OCCKEYFLAG = 0; 
      FRSTADDR = 0; 
      LASTADDR = 0; 
      WBPTRCNTR = 0;
      INDEXCNT = 0; 
      STDYES; 
  RECISQAL:   #   # 
      SCRTOCCKYTY[SCRTCHPTR] = 0; 
      J = SBRECNMELENW[RECPTR]; 
      SCRTOCCKYLN[SCRTCHPTR] = J; 
      SCRTOCCKYLC[SCRTCHPTR] = SBRECNMELENC[RECPTR];
      SCRTOCCKYNX[SCRTCHPTR] = J + 1; 
      FOR I=0 STEP 1 UNTIL J - 1 DO 
        SCRTOCCKYNM[SCRTCHPTR+I] = SBRECNAME[SBRECNAMEPTR[RECPTR]+
                                     RECPTR + I]; 
      SCRTCHPTR = SCRTCHPTR + I + 1;
      WBPTRCNTR = WBPTRCNTR + 1;
      STDNO;
  ITEMDESCEND:                                                          012840
#**********************************************************************#012850
#                  I T E M D E S C E N D                               #012860
#                                                                      #012870
#   STORES THE DESCENDING TYPE INTO A SCRATCH CELL. RETURN IS TO STDNO.#012880
#                                                                      #012890
#**********************************************************************#012900
      ITEMASCDESC = 3;                                                  012910
      OCCKEYFLAG = SBITMLEVEL[ITEMPTR]; # STORE THE LEVEL NUMBER OF THE#
                # ITEM THAT THE OCCURS KEY ARE ARE DEFINED IN.         #
      STDNO;                                                            012920
  ITEMOCQALKY:                                                          012930
#**********************************************************************#012940
#                  I T E M O C Q A L K Y                               #012950
#                                                                      #012960
#   STORES THE QUALIFIER TYPE INTO A SCRATCH CELL. RETURN IS TO STDNO. #012970
#                                                                      #012980
#**********************************************************************#012990
      J = ITEMASCDESC; # STORE IN SCRATCH CELL SO ITEMASCDESC CAN BE   #013000
      ITEMASCDESC = 0; # SET TYPE TO INDICATE QUALIFIER.               #
      STDNO;                                                            013020
  ITEMRESETKY:                                                          013030
#**********************************************************************#013040
#                  I T E M R E S E T K Y                               #013050
#                                                                      #013060
#   RESETS KEY TYPE TO ORIGINAL VALUE. RETURN IS TO STDNO.             #013070
#                                                                      #013080
#**********************************************************************#013090
      ITEMASCDESC = J;                                                  013100
      STDNO;                                                            013110
  ITEMTYPINDX:                                                          013120
#**********************************************************************#013130
#                  I T E M T Y P I N D X                               #013140
#                                                                      #013150
#   STORES THE INDEX TYPE INTO A SCRATCH CELL. RETURN IS TO STDNO.     #013160
#                                                                      #013170
#**********************************************************************#013180
      ITEMASCDESC = 1;                                                  013190
      INDEXCNT = INDEXCNT + 1; # INCREMENT CNTR THAT TALLIES THE NUMBER#
                            # INDEX ENTRIES SPECIFIED.                 #
      STDNO;                                                            013200
  
ISCOBOL:  
#**********************************************************************#
#                                                                      #
#                  I S C O B O L                                       #
#                                                                      #
#     CHECKS IF COMPILATION MODE IS COBOL OR QU/CDCS                   #
#     RETURN IS TO STDYES IF COBOL, STDNO IF QU/CDCS                   #
#                                                                      #
#**********************************************************************#
      IF DDLCOMP EQ QC THEN 
        STDNO;
      STDYES; 
  
  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.             #
      IF (WBPTR-SEPTR) GR MAXSELENG THEN
        MAXSELENG = WBPTR - SEPTR;  # SET NEW SUB-ENTRY LENGTH(MAX).   #
      STDNO;
  CKOCCKEY:   #   # 
      IF OCCKEYFLAG GQ ITEMP OR 
        OCCKEYFLAG GR 0 AND ITEMP GR O"61" OR 
        OCCKEYFLAG GR 0 AND (EOFFLAG EQ 1 OR RELFLAG OR MULTSS) THEN
        STDYES; 
      STDNO;
  SETKEYPTR:   #   #
      FOR SCRTCHPTR=0 STEP SCRTOCCKYNX[SCRTCHPTR] WHILE 
        SCRTOCCKYTY[SCRTCHPTR] EQ 1 DO
          TEST SCRTCHPTR; 
      STDNO;
  CKFORINDEX:   #   # 
      IF OCCKEYFLAG GR 0 THEN # CHECK IF KEYS WHERE SPECIFIED.         #
        STDYES; # THEY WHERE, RETURN FOR NORMAL PROCESSING.            #
      IF INDEXCNT EQ 0 THEN # CHECK IF INDEXED WAS SPECIFIED.          #
        STDYES; # INDEX WAS NOT SPECIFIED.                             #
      J = SBITMOCCURP[ITEMPTR] + ITEMPTR; # SET TEMPORARY POINTER TO   #
                     # POINT TO THE FIRST WORD OF THE OCCURS ENTRY.    #
      FOR WBPTR = WBPTR STEP 1 WHILE SBITMOCCWRD[WBPTR] NQ 0 DO 
        TEST WBPTR;          # SKIP TO FIRST ZERO WORD                 #
      IF SBITMDEPNDON[J] THEN 
        SBITMOCCLNXT[WBPTR-1] = TRUE; 
      SBITMOCCKNXT[J] = TRUE; 
      SCRTCHPTR = 0; # RE-INITIALIZE POINTER TO POINT TO THE 1ST ENT# 
      J = WBPTR; # J IS REQUIRED BY THE PROC -STOREINDEX-.             #
      STOREINDEX; 
      WBPTR = J + I; # INCREMENT POINTER TO THE NEXT AVAILABLE      # 
                   # WORD WHERE THE NEXT ITEM ENTRY IS TO BE WRITTEN.  #
      IF (WBPTR-SEPTR) GR MAXSELENG THEN
        MAXSELENG = WBPTR - SEPTR;  # SET NEW SUB-ENTRY LENGTH(MAX).   #
      INDEXCNT = 0; 
      WBPTRCNTR = 0;
      FRSTADDR = 0; 
      LASTADDR = 0; 
      ZEROSCRTCH(30); 
      STDNO;
  ITEMSYNC:                                                             013210
#**********************************************************************#013220
#                  I T E M S Y N C                                     #013230
#                                                                      #013240
#   SETS THE SYNCHRONIZED FLAG TO INDICATE THAT THE SYNCHRONIZED CLAUSE#013250
#   WAS SPECIFIED. RETURN IS TO STDNO.                                 #013260
#                                                                      #013270
#**********************************************************************#013280
      SBITMSYNC[ITEMPTR] = TRUE;                                        013290
      STDNO;                                                            013300
   ITEMLFTSYNC:                                                         013310
#**********************************************************************#013320
#                  I T E M L F T S Y N C                               #013330
#                                                                      #013340
#   SET THE LEFT INDICATOR TO INDICATE THAT SYNCRONIZED LEFT WAS       #013350
#   SPECIFIED. RETURN IS TO STDNO.                                     #013360
#                                                                      #013370
#**********************************************************************#013380
      SBITMSYNCLFT[ITEMPTR] = TRUE;                                     013390
      STDNO;                                                            013400
  ITEMJUST:                                                             013410
#**********************************************************************#013420
#                  I T E M J U S T                                     #013430
#                                                                      #013440
#   SETS THE JUSTIFIED FLAG TO INDICATE THAT THE JUSTIFIED RIGHT       #013450
#   CLAUSE WAS SPECIFIED. RETURN IS TO STDNO.                          #013460
#                                                                      #013470
#**********************************************************************#013480
      SBITMJUST[ITEMPTR] = TRUE;                                        013490
      STDNO;                                                            013500
  LEVELCONVRT:                                                          013510
#**********************************************************************#013520
#                  L E V E L C O N V R T                               #013530
#                                                                      #013540
#   CONVERTS DISPLAY CODED LEVEL NUMBER TO BINARY AND CHECKS FOR       #013550
#   VALIDITY OF NUMBER. IF LEVEL NUMBER IS VALID, RETURN IS TO STDYES. #013560
#   ELSE RETURN IS TO STDNO AND STD ISSUES DIAGNOSTIC 123.             #013570
#                                                                      #013580
#**********************************************************************#013590
      DTEMP = CURWORD[0]; # STORE DISPLAY CODE LEVEL NUMBER.           #
      DISPDECTOBIN;     # PROC THAT DISPLAY CODED VALUES TO BINARY.    #013610
      IF ITEMP GR 49 AND ITEMP NQ 66 AND ITEMP NQ 88 THEN 
        STDNO;  # COMPARE RETURNED VALUE FROM DISPDECTOBIN AGAINS VALID#013630
      STDYES;   # LEVEL NUMBERS. 1-49, 66, 88.                         #013640
  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.                             #
          IF ERRCNTR LQ TEMPERRCNT THEN  # TO ELIMINATE THE PROBLEM OF #
                                         # DIAGNOSTIC 165 BEING ISSUED #
                                         # UNNECESSARILY.              #
          IF SBITMLEVEL[ITEMPTR] NQ 50 AND SBITMLEVEL[ITEMPTR] NQ 52
          THEN
          IF (SBITMOCCURP[ITEMPTR] NQ 0 AND SBITMXPICSIZ[ITEMPTR] EQ 0) 
            OR (SBITMOCCURP[ITEMPTR] EQ 0 AND SBITMXPICSIZ[ITEMPTR] EQ 0
                   AND SBITMUSAGE[ITEMPTR] EQ 0) THEN 
            DIAGDL(165);
          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.   #
          SBITMPRIORP[WBPTR] = 0;  # ZERO OUT THE PRIOR ITEM POINTER.  #
          SBRECTYPE[WBPTR] = 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.    #
      IWSA[10] = "** ORDINAL";
      STDNO;
    CHECKEOT:   #   # 
#**********************************************************************#
#                                                                      #
#                  C H E C K E O T                                     #
#                                                                      #
#   CHECKS FOR END OF RECORD DESCRIPTION BY CHECKING FOR VARIOUS FLAGS.#
#   IF SET,RETURN TO STDYES. IF NOT SET, RETURN TO STDNO.              #
#                                                                      #
#**********************************************************************#
#**********************************************************************#
      IF EOFFLAG EQ 1 OR RELFLAG OR MULTSS THEN 
          STDYES; 
      STDNO;
    SETEOT:   #   # 
#**********************************************************************#
#                                                                      #
#                   S E T E O T                                        #
#                                                                      #
#   SETS A FLAG TO INDICATE END OF SOURCE INPUT.                       #
#                                                                      #
#**********************************************************************#
      EOFFLAG = 1;
      STDNO;
  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 
          IF SBITMLEVEL[ITEMPTR] NQ 50 AND SBITMLEVEL[ITEMPTR] NQ 52
          THEN
          BEGIN 
          IF (SBITMOCCURP[ITEMPTR] NQ 0 AND SBITMXPICSIZ[ITEMPTR] EQ 0) 
            OR (SBITMOCCURP[ITEMPTR] EQ 0 AND SBITMXPICSIZ[ITEMPTR] EQ 0
                   AND SBITMUSAGE[ITEMPTR] EQ 0) THEN 
            BEGIN 
            DIAGDL(165);
            STDNO;
            END 
          END 
          CBSIZE; 
        END 
      STDNO;
                                                                        001676
REDEFLVL66:                                                             001677
#**********************************************************************#001678
#                                                                      #001679
#                        R E D E F L V L 6 6                           #001680
#                                                                      #001681
#     IF COMPILATION MODE IS QU/CDCS, THEN CBSIZE IS CALLED TO         #001682
#     COMPUTE BWP, BBP AND SIZE OF RENAMES/REDEFINES ITEMS.            #001683
#     RETURN IS TO STDNO.                                              #001684
#                                                                      #001685
#**********************************************************************#001686
                                                                        001687
      IF DDLCOMP EQ QC             # IF COMPILATION MODE IS QU/CDCS    #001688
      THEN                                                              001689
        BEGIN                                                           001690
        TEMPREDLVL = REDEFLEVEL;   # SAVE REDEFLEVEL                   #001691
        REDEFLEVEL = -1;           # SET FLAG TELLING CBSIZE TO COMPUTE#001692
        CBSIZE;                    # BWP, BBP AND SIZE OF REDEFINES AND#001694
                                   # LEVEL 66 ITEMS                    #001695
        REDEFLEVEL = TEMPREDLVL;   # RESTORE REDEFLEVEL                #001696
        END                                                             001697
      STDNO;                                                            001698
                                                                        001699
  ITEMEND:   #   #
#*********************************************************************# 
#                                                                     # 
#                   I T E M E N D                                     # 
#   STORES THE PICTURE MURAL IN THE ITEM ENTRY                        # 
#   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 SQEDITLENG[SQ] NQ 0 THEN                # IF MURAL GENERATED  #
        BEGIN 
          SBITMURALPTR[ITEMPTR] = WBPTR - ITEMPTR;  # POINTER TO MURAL #
          FOR I = 0 STEP 1 UNTIL SQEDITLENG[SQ] - 1 DO
            SBITMEDITMRL[WBPTR+I] = PICTURWORD[I];   # MOVE MURAL      #
          WBPTR = WBPTR + SQEDITLENG[SQ]; 
        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 31 DO
        PICTURWORD[I] = 0;     # ZERO OUT PICTURE WORD                 #
      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; 
      IF SBITMDBCLASS[ITEMPTR] EQ 15   # IF ITEM USAGE IS COMPLEX      #
      THEN
        GOTO CMPLXCLASS;
  
      IF SBITMDBCLASS[ITEMPTR] EQ 17  # IF ITEM USAGE IS LOGICAL       #
      THEN
        GOTO LOGICLASS; 
  
      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.                                                #
  ITEMNMEINDX:                                                          014810
#**********************************************************************#014820
#                  I T E M N M E I N D X                               #014830
#                                                                      #014840
#   HASHES THE INDEX NAME AND VERIFIES IF INDEX IS UNIQUE. IF UNIQUE,  #014850
#   RETURN IS TO STDYES. IF NOT UNIQUE, RETURN IS TO STDNO. STD WILL   #014860
#   ISSUE DIAGNOSTIC 139.                                              #014870
#                                                                      #014880
#**********************************************************************#014890
  SETHVALUE:  
#**********************************************************************#
#                  S E T H V A L U E                                   #
#                                                                      #
#   SETS THE LITERAL FIELD WITH DISPLAY CODE "44" ( 9"S), THE HIGHEST  #
#   VALUE IN THE COBOL COLLATING SEQUENCE(ASSUMED), IF THE TARGET      #
#   ITEM IS ALPHANUMERIC, ELSE RETURN STDNO.                           #
#                                                                      #
#**********************************************************************#
      I = PRIORITEM;
      IF SBITMDBCLASS[I] NQ 0 THEN
        STDNO;
      SBITMLLITTYP[LITSTART] = TRUE; #SET BIT TO INDICATE LIT. NON-NUM.#
      FCONST = "9"; 
      STORFC; 
      STDYES; 
  SETLVALUE:  
#**********************************************************************#
#                  S E T L V A L U E                                   #
#                                                                      #
#   SETS THE LITERAL FIELD WITH DISPLAY CODE "55"( BLANKS ) WHICH IS   #
#   THE LOWEST VALUE IN THE COBOL COLLATING SEQUENCE (ASSUMED ),IF     #
#   THE TARGET ITEM IS ALPHA OR ALPHANUMERIC, ELSE RETURN STDNO.       #
#                                                                      #
#**********************************************************************#
      I = PRIORITEM;
      IF SBITMDBCLASS[I] GR 1 THEN
        STDNO;
      SBITMLLITTYP[LITSTART] = TRUE; #SET BIT TO INDICATE LIT. NON-NUM.#
      FCONST = " "; 
      STORFC; 
      STDYES; 
  SETSPACE: 
#**********************************************************************#
#                  S E T S P A C E                                     #
#                                                                      #
#   SETS THE LITERAL FIELD WITH DISPLAY CODE "55" WHICH ARE ALL BLANKS #
#   IF THE TARGET ITEM IS ALPHA OR ALPHANUMERIC, ELSE RETURN STDNO.    #
#                                                                      #
#**********************************************************************#
      I = PRIORITEM;
      IF SBITMDBCLASS[I] GR 1 THEN
        STDNO;
      SBITMLLITTYP[LITSTART] = TRUE; #SET BIT TO INDICATE LIT. NON-NUM.#
      FCONST = " "; 
      STORFC; 
      STDYES; 
  SETZEROS: 
#**********************************************************************#
#                  S E T Z E R O S                                     #
#                                                                      #
#   SETS THE LITERAL FIELD WITH DISPLAY CODE "33". IF TARGET ITEM      #
#   IS ALPHABETIC, RETURN STDNO. ELSE RETURN STDYES.                   #
#                                                                      #
#**********************************************************************#
      I = PRIORITEM;
      IF SBITMDBCLASS[I] EQ 1 THEN
        STDNO;
      FCONST = "0"; 
      STORFC; 
      STDYES; 
  GROUPCLAS:   #   #
#**********************************************************************#
#                  G R O U P C L A S                                   #
#   CHECKS IF SUBJECT ITEM IS A GROUP ITEM. IF NOT A GROUP ITEM DIAG-  #
#   NOSTIC MESSAGE IS ISSUED. RETURN IS TO STDNO.                      #
#                                                                      #
#**********************************************************************#
      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] = SBITMXPICSIZ[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] = SBITMXPICSIZ[ITEMPTR];
      STDNO;
  ALPHANMCLAS:   #   #
#**********************************************************************#
#                  A L P H A N M C L A S                               #
#                                                                      #
#   PICTURE IS NUMERIC, USAGE COULD BE DISPLAY OR NOT SPECIFIED AT ALL.#
#   SET USE SIZE TO THE PICTURE SIZE. DBMS CLASS IS ALREADY SET TO ZERO#
#   RETURN IS TO STDNO.                                                #
#                                                                      #
#**********************************************************************#
      SBITMUSESIZE[ITEMPTR] = SBITMXPICSIZ[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;
      SBITMXPICSIZ[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;
      IF SBITMIPICSIZ[ITEMPTR] EQ 0    # IF NO PICTURE SPECIFIED       #
      THEN
        BEGIN 
        SBITMIPICSIZ[ITEMPTR] = 1;     # SET DEFAULT SIZES             #
        SBITMXPICSIZ[ITEMPTR] = 1;
        END 
      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; 
      IF SBITMIPICSIZ[ITEMPTR] EQ 0    # IF NO PICTURE SPECIFIED       #
      THEN
        BEGIN 
        SBITMIPICSIZ[ITEMPTR] = 1;     # SET DEFAULT SIZES             #
        SBITMXPICSIZ[ITEMPTR] = 1;
        END 
      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 SBITMXPICSIZ[ITEMPTR] LS 15 THEN 
        SBITMDBCLASS[ITEMPTR] = 10; 
      ELSE
        DIAGDL(199);
      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;
          SBITMXPICSIZ[ITEMPTR] = 1;
        END 
      STDNO;
  
  
DOUBLEUSAGE:  
#**********************************************************************#
#                                                                      #
#                  D O U B L E U S A G E                               #
#                                                                      #
#     PICTURE COULD BE NUMERIC OR NO PICTURE SPECIFIED AT ALL, AND     #
#     USAGE IS DOUBLE. SET DBMS CLASS TO 14 AND USAGE SIZE TO 20.      #
#     RETURN IS TO STDNO                                               #
#                                                                      #
#**********************************************************************#
  
      SBITMDBCLASS[ITEMPTR] = 14; 
      SBITMUSESIZE[ITEMPTR] = 20; 
      IF SBITMIPICSIZ[ITEMPTR] EQ 0 THEN    # IF NO PIC SPECIFIED      #
        BEGIN 
          SBITMIPICSIZ[ITEMPTR] = 1;        # DEFAULT PIC SIZE IS 1    #
          SBITMXPICSIZ[ITEMPTR] = 1;
        END 
      STDNO;
  
CMPLXCLASS: 
#**********************************************************************#
#                 C M P L X C L A S S                                  #
#                                                                      #
#     SET PICTURE SIZE INCLUDING AND EXCLUDING INSERTS                 #
#                                                                      #
#**********************************************************************#
  
      IF SBITMIPICSIZ[ITEMPTR] EQ 0    # IF NO PICTURE SPECIFIED       #
      THEN
        BEGIN 
        SBITMIPICSIZ[ITEMPTR] = 1;
        SBITMXPICSIZ[ITEMPTR] = 1;
        END 
      STDNO;
  
LOGICLASS:  
#**********************************************************************#
#                    L O G I C L A S S                                 #
#                                                                      #
#     SET DEFAULT PICTURE SIZES, EXCLUDING AND INCLUDING INSERTS       #
#                                                                      #
#**********************************************************************#
  
      IF SBITMIPICSIZ[ITEMPTR] EQ 0    # IF NO PICTURE SPECIFIED       #
      THEN
        BEGIN 
        SBITMIPICSIZ[ITEMPTR] = 1;
        SBITMXPICSIZ[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(167);
      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;
  REDFINIT:   #   # 
#**********************************************************************#
#                  R E D F I N I T                                     #
#                                                                      #
#   CHECKS IF THE PRIOR ITEM IS A REDIFINES ITEM. IF SO THE REDEFINES  #
#   FLAG, SIZE COUNTER, LEVEL INDICATOR ARE ZEROED OUT. RETURN IS      #
#   ALWAYS TO STDNO.                                                   #
#                                                                      #
#**********************************************************************#
      IF SBITMREDEFFG[ITEMPTR - SBITMPRIORP[ITEMPTR]] THEN
        BEGIN 
          IF SBITMLEVEL[ITEMPTR] GR REDEFLEVEL AND REDEFLEVEL NQ 0 THEN 
            BEGIN 
              RSTACKLVL[RSTACKPTR] = REDEFLEVEL; # STORE LEVEL NUMBER  #
              RSTACKREDA[RSTACKPTR] = REDEFPTR; # AND WORD ADDRESS OF  #
                 # PRIOR REDEFINES ENTRY INTO THE REDEFINES STACK.     #
              RSTACKWRDA[RSTACKPTR] = REDEFWRDA;
              RSTACKPTR = RSTACKPTR + 1;
              REDEFLEVEL = 0; 
              REDEFWRDA = 0;
              STDNO;
            END 
        END 
      RSTACKPTR = 0;
      STDNO;
  REDFSCN:   #   #
#**********************************************************************#
#                  R E D F S C N                                       #
#                                                                      #
#   VALIDATES THE LEVEL NUMBER OF THE CURRENT ITEM. IF INVALID, DIAG-  #
#   NOSTIC 175 IS ISSUED AND NORMAL PROCESSING IS RESUMED. THEN A SCAN #
#   IS MADE SEARCHING THROUGH THE ITEM ENTRIES OF THE CURRENT RECORD   #
#   BEING PROCESSED, LOOKING FOR AN ITEM NAME THAT IS  THE SAME        #
#   AS DATA-NAME-2. IF THE NAME IS FOUND, ITS LEVEL NUMBER IS COMPARED #
#   AGAINST THE LEVEL NUMBER OF THE CURRENT ITEM FOR EQUALITY. IF THE  #
#   LEVEL NUMBERS DO NOT EQUAL, DIAGNOSTIC 176 IS ISSUED AND THE LEVEL #
#   NUMBER OF THE ORIGINALLY DEFINED ITEM IS STORED IN THE CURRENT ITEM#
#   . THEN THE WORD ADDRESS AND ORDINAL NUMBER OF THE ORIGINALLY DEFIN-#
#   ED ITEM IS STORED IN THE CURRENT ITEM. RETURN IS TO STDYES. IF     #
#   DATA-NAME-2 WAS NEVER FOUND, RETURN IS TO STDNO WHERE STD ISSUES   #
#   DIAGNOSTIC 173.                                                    #
#                                                                      #
#**********************************************************************#
      DFLAG = FALSE;               # CLEAR DIAGNOSTIC FLAG             #
      IF ITEMP EQ 1 OR ITEMP GR 44 THEN # CHECK FOR INVALID LEVEL      #
        DIAGDL(175); # NUMBER FOR REDEFINES.                           #
      J = ITEMPTR; # STORE THE WORD ADDRESS OF THE CURRENT ITEM ENTRY. #
      FOR I=0 WHILE SBITMPRIORP[J] NQ 0 DO
        BEGIN # ITEM NAME. WHEN FOUND CHECK TO SEE THAT THE LEVEL NUM- #
              # ER OF DATA-NAME-1 MATCHES THE LEVEL NUMBER OF DATA-    #
              # NAME-2.                                                #
          J = J - SBITMPRIORP[J];  # ADJUST WORD POINTER TO THE        #
                                   #  PREVIOUS ITEM ENTRY.             #
  
                                   # COMPARE THE CURRENT ITEM 'S NAME  #
                                   # TO THE PREVIOUS ITEM 'S NAME      #
  
          IF SBITMNELENW[J] NQ CURLENW  # LENGTH OF PREVIOUS ITEM NAME #
          THEN                     # IS NOT EQUAL TO THE LENGTH OF THE #
            BEGIN                  # CURRENT ITEM NAME                 #
            TEST I; 
            END 
  
          FOR K=0 STEP 1 UNTIL CURLENW - 1
          DO
            BEGIN 
            IF SBITMNAME[SBITMNAMEPTR[J]+J+K] NQ CURWORD[K] THEN # NOT #
              BEGIN 
              IF SBITMLEVEL[J] EQ ITEMP 
                AND NOT SBITMREDEFFG[J] 
              THEN
                DFLAG = TRUE;      # SET DIAGNOSTIC FLAG               #
              TEST I; 
  
              END 
            END 
          IF ITEMP NQ SBITMLEVEL[J] THEN # CHECK IF LEVEL NUMBERS ARE  #
            BEGIN                        # EQUAL.                      #
              DIAGDL(176); # ISSUE DIAGNOSTIC MESSAGE - INVALID LEVEL  #
                           # NUMBER.                                   #
              SBITMLEVEL[ITEMPTR] = SBITMLEVEL[J]; # STORE CORRECT     #
            END                                    # LEVEL NUMBER.     #
          REDEFLEVEL = SBITMLEVEL[ITEMPTR]; # STORE LEVEL NUMBER. USE  #
             # AS A FLAG AND AS A TERMINATOR - STOP WHEN AN ITEM WITH  #
             # EQUAL LEVEL NUMBER IS ENCOUNTERED.                      #
          SBITMREDEFFG[ITEMPTR] = TRUE;   # SET REDEFINES FLAG.        #
          SBITMLRNDNAD[WBPTR] = J; # STORE THE WORD ADDRESS OF THE ITEM#
          REDEFWRDA = J;           # BEING REDEFINED.                  #
          SBITMRNRDPTR[ITEMPTR] = WBPTR - ITEMPTR; # STORE OFFSET POIN-#
                                   # TER TO THE REDEFINE ENTRY.        #
          WBPTR = WBPTR + 1; # INCREMENT POINTER TO THE NEXT AVAILABLE #
                              # WORD.                                  #
          REDEFPTR = ITEMPTR; 
          IF DFLAG                 # IF DIAGNOSTIC FLAG IS SET         #
          THEN
            DIAGDL(207);           # ISSUE DIAGNOSTIC                  #
  
          STDYES; 
        END 
      STDNO;
  REDFOCC:   #   #
#**********************************************************************#
#                  R E D F O C C                                       #
#                                                                      #
#   CHECK IF DATA-NAME-2 IN THE REDEFINES CLAUSE HAS AN OCCURS CLAUSE  #
#   SPECIFIED IN IT. IF SO RETURN IS TO STDNO WHERE STD ISSUES DIAG-   #
#   NOSTIC 174, ELSE RETURN IS TO STDYES.                              #
#                                                                      #
#**********************************************************************#
      IF SBITMREDEFFG[REDEFWRDA] AND SBITMRNRDPTR[REDEFWRDA] GR 0 THEN
                 # CHECK IF ITEM BEING REDEFINED IS A REDEFINES ITEM.  #
        DIAGDL(156); # ED IS A REDEFINES ITEM OR SUBORDINATE TO A REDEF#
      IF SBITMOCCURP[REDEFWRDA] GR 0 THEN 
        STDNO;
      STDYES; 
  REDFCK:   #   # 
#**********************************************************************#
#                  R E D F C K                                         #
#                                                                      #
#   CHECKS WHEN THE REDEFINES DEFINITION ENDS. TALLIES THE SIZE OF THE #
#   REDEFINITION AND CHECKS IF THE CURRENT ITEM HAS AN OCCURS CLAUSE OF#
#   VARIABLE DEMENSION SPECIFIED IN IT. IF THE LATER IS TRUE DIAGNOSTIC#
#   177 IS ISSUED. IF THE LAST ITEM OF THE REDEFINITION WAS ENCOUNTERED#
#   RETURN IS TO STDYES, ELSE RETURN IS TO STDNO.                      #
#                                                                      #
#**********************************************************************#
      IF REDEFLEVEL EQ 0 THEN # CHECK IF ITEM IS ASSOCIATED WITH A     #
                              # REDEFINES CLAUSE.                      #
        STDNO; # NOT ASSOCIATED WITH REDEFINES.                        #
      IF REDEFLEVEL GQ SBITMLEVEL[ITEMPTR] OR 
                 SBITMLEVEL[ITEMPTR] GR 49 THEN 
        BEGIN 
          FOR I=REDEFPTR STEP SBITMNEXTP[I] WHILE I NQ ITEMPTR DO 
            BEGIN  # STEP THRU THE REDEFINE ITEM TO CHECK IF ANY HAVE  #
                   # OCCURS DBI.                                       #
              IF SBITMOCCURP[I] GR 0 THEN # CHECK IF OCCURS IS SPECIF- #
                                          # IED                        #
                IF SBITMDEPNDON[I+SBITMOCCURP[I]] THEN
                  BEGIN 
                    C<0,10>J = C<0,10>NBRLINE;
                    CONVLNENBR(SBITMSRCLNEN[I]);
                    DIAGDL(177);
                    C<0,10>NBRLINE = C<0,10>J;
                  END 
              IF SBITMNEXTP[I] EQ 0 
              THEN
                BEGIN 
                STDYES; 
                END 
            END 
          STDYES; 
        END 
         ELSE 
          IF NOT SBITMREDEFFG[ITEMPTR] THEN 
            SBITMREDEFFG[ITEMPTR] = TRUE; 
      STDNO;
  REDFSIZE:   #   # 
#**********************************************************************#
#                  R E D F S I Z E                                     #
#                                                                      #
#   COMPARES THE TALLIED SIZE OF THE REDEFINED ITEMS AGIANST THE SIZE  #
#   OF THE ORGINALLY DEFINED ITEM / S. IF THE TWO SIZES ARE NOT EQUAL, #
#   DIAGNOSTIC 178 IS ISSUED. RETURN IS ALWAYS TO STDNO.               #
#                                                                      #
#**********************************************************************#
      IF ERRCNTR LQ TEMPERRCNT THEN 
        BEGIN 
          CBSIZE; 
  REDLOOP:       #     #
          TARGETADDR[REDFPTR] = REDEFWRDA;
          REDEFADDR[REDFPTR] = REDEFPTR;
          REDFPTR = REDFPTR + 1;
          IF RSTACKPTR GR 0 THEN
            BEGIN 
              RSTACKPTR = RSTACKPTR - 1;  # POP STACK TO LAST ENTRY.   #
              REDEFWRDA = RSTACKWRDA[RSTACKPTR];
              REDEFLEVEL = RSTACKLVL[RSTACKPTR];
              REDEFPTR = RSTACKREDA[RSTACKPTR]; 
              IF RSTACKLVL[0] LS SBITMLEVEL[ITEMPTR]
              THEN
                BEGIN 
                SBITMREDEFFG[ITEMPTR] = TRUE; 
                END 
  
              IF REDEFLEVEL GQ ITEMP  # USING ITEMP INSTEAD OF SBITM-  #
              THEN                    # LEVEL[ITEMPPTR], BECAUSE IF THE#
                BEGIN                 # CURRENT ITEM IS THE RECORD     #
                CBSIZE;               # ENTRY (ITEMP=1) THEN SBITMLEVEL#
                GOTO REDLOOP;         # [ITEMPTR] IS THE LEVEL OF THE  #
                END                   # LAST ITEM OF PREVIOUS RECORD   #
  
              STDNO;
            END 
        END 
      REDEFLEVEL = 0; 
      REDEFWRDA = 0;   # RE-INITIALIZE REDEFINE CELLS.                 #
      TEMPREDLVL = 0; 
      STDNO;
  REDFTERM:   #   # 
#**********************************************************************#
#                  R E D F T E R M                                     #
#                                                                      #
#   CHECKS TO SEE IF THE LAST ITEM SPECIFIED IN THE SUB-SCHEMA IS A    #
#   REDEFINE ITEM OR SUBORDINATE TO A REDEFINE ITEM. IF TRUE RETURN IS #
#   STDYES, ELSE RETURN IS TO STDNO.                                   #
#                                                                      #
#**********************************************************************#
      REDEFLEVEL = TEMPREDLVL;
      IF REDEFLEVEL GR 0 THEN 
        BEGIN 
          FOR I=REDEFPTR STEP SBITMNEXTP[I] UNTIL ITEMPTR DO
            BEGIN  # SEARCH THRU THE REDEFINES ITEMS FOR OCCURS DEPEND #
              IF SBITMOCCURP[I] GR 0 THEN  # ING ON.                   #
                IF SBITMDEPNDON[I+SBITMOCCURP[I]] THEN
                  BEGIN 
                    C<0,10>J = C<0,10>NBRLINE; # STORE THE SOURCE LINE #
                            # NUMBER OF THE CURRENT INPUT RECORD.      #
                    CONVLNENBR(SBITMSRCLNEN[I]);
                    DIAGDL(177);
                    C<0,10>NBRLINE = C<0,10>J;
                  END 
              IF SBITMNEXTP[I] EQ 0 
              THEN
                BEGIN 
                STDYES; 
                END 
            END 
          STDYES; 
        END 
      STDNO;
  REDEFEND:   #   # 
      IF REDFPTR GR 0 AND ERRCNTR LQ TEMPERRCNT THEN
        BEGIN 
          FOR I=0 STEP 1 UNTIL REDFPTR - 1 DO 
            BEGIN 
              IF (SBITMUSESIZE[TARGETADDR[I]] NQ
                  SBITMUSESIZE[REDEFADDR[I]]) THEN
                BEGIN 
                  C<0,10>J = C<0,10>NBRLINE;
                  CONVLNENBR(SBITMSRCLNEN[REDEFADDR[I]]); 
                  DIAGDL(178);
                  C<0,10>NBRLINE = C<0,10>J;
                END 
            END 
        END 
      REDEFLEVEL = 0;               # RE-INITIALIZE REDEFINE CELLS #
      REDEFWRDA  = 0; 
      TEMPREDLVL = 0; 
      TEMPERRCNT = ERRCNTR; 
      STDNO;
  SPECIALLVL:   #   # 
#**********************************************************************#
#                   S P E C I A L L V L                                #
#    CHECKS IF A SPECIAL LEVEL NUMBER WAS SPECIFIED. IF SO RETURN IS TO#
#    STDYES, ELSE RETURN IS TO STDNO.                                  #
#                                                                      #
#**********************************************************************#
      IF ITEMP GR 49 THEN 
        STDYES; 
      STDNO;
  LEVEL66:   #   #
#**********************************************************************#
#                  L E V E L 6 6                                       #
#                                                                      #
#   CHECKS IF THE LEVEL NUMBER IS 66. IF SO , IT STORES THE LEVEL NUMB-#
#   ER IN TO THE LEVEL 66 ITEM ENTRY. RETURN IS TO STDYES IF LEVEL 66, #
#   ELSE RETURN IS TO STDNO.                                           #
#                                                                      #
#**********************************************************************#
      IF ITEMP NQ 66 THEN 
        STDNO;
      SBITMLEVEL[ITEMPTR] = O"62";
      SBITMREDEFFG[ITEMPTR] = TRUE; # SET FLAG SO PASS2 WILL IGNORE ITM#
      SBITMDOMADR[ITEMPTR] = RECPTR; # STORE THE RECORD ADDR AS THE   # 
                                     # DOMINANT ITEM.                 # 
      STDYES; 
  LEVEL88:   #   #
#**********************************************************************#
#                  L E V E L 8 8                                       #
#                                                                      #
#   CHECKS IF THE LEVEL NUMBER IS 88. IF SO, IT STORES THE LEVEL NUMB- #
#   ER IN TO THE LEVEL88 ITEM. RETURN IS TO STDYES IF LEVEL 88 ELSE    #
#   STDNO.                                                             #
#                                                                      #
#**********************************************************************#
      IF ITEMP NQ 88 OR DDLCOMP EQ QC THEN
        STDNO;
      SBITMLEVEL[ITEMPTR] = O"64";
      SBITMREDEFFG[ITEMPTR] = TRUE; # SET FLAG SO PASS2 WILL IGNORE ITM#
      STDYES; 
  FIND66ITM:   #   #
#**********************************************************************#
#                  F I N D 6 6 I T M                                   #
#                                                                      #
#   SEARCHES BACKWARDS THRU WORKBUF LOOKING FOR DATA-NAME-2 THATS SPEC-#
#   -3 THAT IS SPECIFIED IN THE RENAMES CLAUSE. WHEN FOUND, THE WORD   #
#   ADDRESS OF THE DATA-NAME ENTRY IS STORED ALONG WITH THE ORDINAL    #
#   NUMBER IN TO THE RENAMES ENTRY OF THE RENAMES ITEM ( DATA-NAME-1). #
#   IF THE NAME IS NOT FOUND, RETURN IS TO STDNO WHERE STD ISSUES DIAG #
#   NOSTIC181. ELSE RETURN IS TO STDYES.                               #
#                                                                      #
#**********************************************************************#
      HASHNAME; 
      IF HSHADDR EQ 0 OR HSHADDR LS RECPTR THEN 
        STDNO;
      L66WA = HSHADDR;
      SBITMRDRNI[WBPTR] = TRUE; 
      SBITMRNRDPTR[ITEMPTR] = WBPTR - ITEMPTR;
      SBITMLRNDNAD[WBPTR] = L66WA;
      STORQALINFO;
      STDYES; 
  CK66LEVEL:   #   #
#**********************************************************************#
#                  C K 6 6 L E V E L                                   #
#                                                                      #
#   CHECKS IF DATA-NAME-2 OR DATA-NAME-3 ARE NOT LEVEL NUMBERS 66 OR 88#
#   CHECKS THAT DATA-NAME-2 OR DATA-NAME-3 DONOT CONTAIN OCCURS CLAUSE #
#   OR BE SUBORDINATE TO AN ITEM THAT HAS AN OCCURS CLAUSE. IF OCCURS  #
#   CLAUSE IS SPECIFIED OR LEVEL NUMBER IS 88 OR 66. RETURN IS TO STDNO#
#   ELSE RETURN IS TO STDYES.                                          #
#                                                                      #
#**********************************************************************#
      IF SBITMLEVEL[L66WA] EQ O"62" OR SBITMLEVEL[L66WA] EQ O"64" THEN
        BEGIN 
          DIAGDL(182);
          STDNO;
        END 
      IF SBITMOCCURP[L66WA] GR 0 THEN 
        BEGIN 
          DIAGDL(183);
          STDNO;
        END 
      J = L66WA;
      FOR I=0 WHILE SBITMENTRY[J] NQ RECORD DO
          BEGIN 
          J = SBITMDOMADR[J]; # GET THE DOMINANT ADDRESS OF THE CURRENT#
                              # ITEM.                                  #
          IF SBITMOCCURP[J] GR 0 THEN 
            BEGIN 
              DIAGDL(183);
              STDNO;
            END 
        END 
      STDYES; 
  CK66ITMTYP:   #   # 
#**********************************************************************#
#                  C K 6 6 I T M T Y P                                 #
#   IF DATA-NAME-2 IS A GROUP ITEM, THEN DATA-NAME-1 IS SET TO GROUP.  #
#   IF DATA-NAME-2 IS AN ELEMENTRY ITEM, THEN DATA-NAME-1 IS SET TO    #
#   ELEMENTRY. ALSO IF DATA-NAME-2 IS A GROUP ITEM, A CHECK IS MADE TO #
#   SEE IF ANY OF THE SUBORDINATE ITEMS ARE VARIABLE-OCCURENCE ITEMS.  #
#   IF A VARIABLE-OCCURENCE ITEM IS FOUND DIAGNOSTIC 184 IS ISSUED AND #
#   RETURN IS TO STDNO, ELSE RETURN IS TO STDNO.                       #
#                                                                      #
#**********************************************************************#
      IF SBITMTYPE[L66WA] EQ ELEMITM THEN 
        SBITMTYPE[ITEMPTR] = ELEMITM; 
       ELSE 
        BEGIN 
          SBITMTYPE[ITEMPTR] = GROUPITM;
          FOR I=L66WA STEP SBITMNEXTP[I] WHILE I NQ ITEMPTR DO
            BEGIN 
              IF SBITMTYPE[I] GR 5 THEN # CHECK SUBORDINATE ITEMS FOR  #
                   # OCCURS OF VARIABLE DIMENISION. ITEM TYPE 6 = REPEA#
                   # TING GROUP OF VARIABLE DIMENSION. 7 = VECTOR OF   #
                   # VARAIBLE DIMENSION.                               #
                BEGIN 
                  DIAGDL(184);
                  STDNO;
                END 
              IF SBITMLEVEL[I] LQ SBITMLEVEL[L66WA] THEN
                STDNO;
            END 
        END 
      STDNO;
  SET66GRP:   #   # 
#**********************************************************************#
#                  S E T 6 6 G R P                                     #
#                                                                      #
#   SETS THE THRU FLAG TO 1 TO INDICATE DATA-NAME-3 WAS SPECIFIED. SETS#
#   THE ITEM TYPE TO GROUP AND RETURNS TO STDNO.                       #
#                                                                      #
#**********************************************************************#
      SBITMTYPE[ITEMPTR] = GROUPITM;
      IF SBITMLRNDNAD[WBPTR] EQ 0 THEN
        SBITMRRNTHRU[WBPTR-1] = TRUE; 
       ELSE 
        SBITMLRNTHRU[WBPTR] = TRUE; 
      STDNO;
  FIND266ITM:    #   #
#**********************************************************************#
#                  F I N D 2 6 6 I T M                                 #
#                                                                      #
#   COMPARES DATA-NAME-2 WITH DATA-NAME-3. IF THEY ARE THE SAME DIAG-  #
#   NOSTIC 185 IS ISSUED AND RETURN IS TO STDNO. IF NOT THE SAME A SCAN#
#   BACKWARDS THRU WORKBUF IS MADE SEARCHING FOR THE DATA-NAME-3 ENTRY.#
#   IF DATA-NAME-3 IS NOT FOUND DIAGNOSTIC187 IS ISSUED AND RETURN IS  #
#   TO STDNO. IF DATA-NAME-3 IS FOUND, A CHECK IS MADE TO SEE IF DATA- #
#   NAME-3S ENTRY FOLLOWS DATA-NAME-2S ENTRY. IF IT DOSENT, DIAGNOSTIC #
#   186 IS ISSUED AND RETURN IS TO STDNO. IF EVERYTHING IS DEFINED PROP#
#   ERLY, THEN THE WORD ADDRESS AND ORDINAL NUMBER OF DATA-NAME-3 IS   #
#   STORED INTO THE LEVEL 66 ENTRY. RETURN IS TO STDYES.               #
#                                                                      #
#**********************************************************************#
      FOR I=0 STEP 1 UNTIL CURLENW - 1 DO # CHECK IF DATA-NAME-2 AND   #
        IF CURWORD[I] NQ SBITMNAME[SBITMNAMEPTR[L66WA]+L66WA+I] THEN
          GOTO FINDITM;      # DATA-NAME-3 ARE THE SAME.               #
      DIAGDL(185);
      STDNO;
    FINDITM:   #   #
      HASHNAME; 
      IF HSHADDR EQ 0 OR HSHADDR LS RECPTR THEN 
        BEGIN 
          DIAGDL(187);
          STDNO;
        END 
      IF HSHADDR LS L66WA THEN
        BEGIN 
          DIAGDL(186);
          STDNO;
        END 
      L66WA = HSHADDR;
      IF SBITMLRNDNAD[WBPTR] EQ 0 THEN
        BEGIN 
          SBITMRRNNXT[WBPTR-1] = TRUE;
          SBITMLRNDNAD[WBPTR] = L66WA;
        END 
         ELSE 
        BEGIN 
          SBITMLRNNXT[WBPTR] = TRUE;
          SBITMRRNDNAD[WBPTR] = L66WA;
          WBPTR = WBPTR + 1;
      END 
      STORQALINFO;
      STDYES; 
  CK66SUBOR:   #   #
#**********************************************************************#
#                  C K 6 6 S U B O R                                   #
#                                                                      #
#   CHECKS TO SEE IF ANY OF THE ITEMS WITHIN THE RANGE OF DATA-NAME-2  #
#   AND DATA-NAME-3 VARIABLE-OCCURENCE DATA ITEMS. IF SO RETURN IS TO  #
#   STDNO WHERE DIAGNOSTIC 184 IS ISSUED. ELSE RETURN IS TO STDYES.    #
#                                                                      #
#**********************************************************************#
      J = ITEMPTR + SBITMRNRDPTR[ITEMPTR];
      FOR I=SBITMLRNDNAD[J] STEP SBITMNEXTP[I] WHILE I NQ L66WA DO
        BEGIN # STEP THRU WITHIN RANGE ITEMS.                          #
          IF SBITMTYPE[I] GR 5 THEN # CHECK IF ITEM IS A REPEATING     #
            STDNO; # GROUP OF VARIABLE DIMENSION OF VECTOR OF VARIABLE #
        END       # DIMENSION.                                         #
      IF SBITMTYPE[L66WA] EQ GROUPITM THEN # CHECK IF DATA-NAME-3 IS A #
        BEGIN                              # GROUP ITEM.               #
          FOR I=L66WA STEP SBITMNEXTP[I] WHILE I  NQ ITEMPTR DO 
            BEGIN 
              IF SBITMTYPE[I] GR 5 THEN 
                STDNO;
            END 
        END 
      K = SBITMLRNDNAD[J]; # GET THE WORD ADDRESS OF DATA-NAME-2.      #
      J = SBITMDOMADR[L66WA]; # GET THE DOMINANT ITEM ADDRESS.        # 
      FOR I=0 STEP 1 WHILE J GQ K DO
        BEGIN 
          IF J EQ K THEN
            BEGIN 
              DIAGDL(188);
              STDYES; 
            END 
          J = SBITMDOMADR[J]; 
        END 
      STDYES; 
  ITMNAME88:  
#**********************************************************************#
#                  I T M N A M E 8 8                                   #
#                                                                      #
#   CALLS THE SYMBOL TABLE HASH ROUTINE TO VERIFY THAT THE ITEM NAME IS#
#   UNIQUE. IF THE ITEM NAME IS NOT UNIQUE THE ENTRY IS IGNORED AND    #
#   RETURN IS TO STDNO. IF THE ITEM NAME IS UNIQUE THE NAME IS         #
#   STORED INTO THE ITEM ENTRY. RETURN IS TO STDYES.                   #
#                                                                      #
#**********************************************************************#
      I = PRIORITEM;
      FOR K = K WHILE SBITMLEVEL[I] GR 49 AND SBITMLEVEL[I] EQ 52 DO
        I = I - SBITMPRIORP[I];  # CHECK BACKWARDS FOR TARGET ITEM #
      SBITMDOMADR[ITEMPTR] = I;  # STORE DOMINANT ADDRESS # 
      HSHTYPE = ITEMS;
      HSHREFDEF = DEFINED;    # SYMBOL TABLE HASH ROUTINE              #
      SBWRDADR = ITEMPTR;     # STORE THE WORD ADDRESS OF THE ITEM     #
                              # ENTRY FOR THE HASH ROUTINE             #
      HASHTABLE;              # CALL SYMBOL HASH ROUTINE               #
      IF DUPFLAG EQ 1 THEN    # IF ITEM NOT UNIQUE THEN RETURN STDNO   #
        BEGIN 
          DUPFLAG = 0;
          STDNO;
        END 
      WBPTR = WBPTR + DFSBITMLG;   # INCREMENT POINTER TO THE FIRST    #
                                   # VARIABLE WORD.                    #
      CHECKFL;
      FOR I = 0 STEP 1 UNTIL CURLENW - 1 DO 
        SBITMNAME[WBPTR+I] = CURWORD[I];          # STORE ITEM NAME.   #
        SBITMNAMEPTR[ITEMPTR] = WBPTR - ITEMPTR;  # STORE NAME POINTER.#
        WBPTR = WBPTR + CURLENW;
      SBITMNELENW[ITEMPTR] = CURLENW; 
      SBITMNMELENC[ITEMPTR] = CURLENG;
      SBITMENTRY[ITEMPTR] = ITEMS;
      ITEMCNTR = ITEMCNTR + 1; # ADD CURRENT ITEM TO ITEM COUNTER      #
      SBITMSRCLNEN[ITEMPTR] = LINENBR - 1;  # STORE SOURCE LINE NUMBER #
      STDYES; 
  ITEMCHK:  
#**********************************************************************#
#                  I T E M C H K                                       #
#                                                                      #
#   CHECKS TO SEE IF THE PRECEEDING( TARGET ) ITEM IS AN ELEMENTARY    #
#   ITEM OR A VECTOR( BECAUSE SUBJECT ITEM IS A LEVEL 88 ITEM ). IF    #
#   SO RETURN IS TO STDYES, ELSE STDNO. IT ALSO SETS THE ITEM TYPE     #
#   AND LEVEL NUMBER.                                                  #
#                                                                      #
#**********************************************************************#
#**********************************************************************#
#         WARNING!!           WARNING!!          WARNING!!             #
#                                                                      #
#   THE VALUE OF PRIORITEM HAS BEEN MODIFIED TO POINT TO THE TARGET    #
#   ITEM, THE CONDITION-NAME ENTRY PERTAINS TO. ON COMPLETION OF THIS  #
#   ENTRY THE VALUE OF PRIORITEM IS RESET TO POINT TO THE PREVIOUS     #
#   ITEM ENTRY.                                                        #
#                                                                      #
#**********************************************************************#
      I = SBITMDOMADR[ITEMPTR]; 
      IF SBITMENTRY[I] EQ ITEMS THEN  # CHECKS TO SEE IF PRECEEDING    #
        BEGIN                         # ENTRY IS AN ITEM ENTRY         #
          IF SBITMXPICSIZ[I] NQ 0 THEN          # CHECK IF PRECEEDING  #
            BEGIN    # ITEM IS NOT A REPEATING GROUP OR RENAME ITEM    #
              SBITMTYPE[ITEMPTR] = ELEMITM;  # ITEM TYPE IS SET TO ELEM#
              SBITMLEVEL[ITEMPTR] = 52;      # STORES LEVEL 88 IN ITEM #
              PRIORITEM = I;
              STDYES;                        # ENTRY, RETURNS STDYES.  #
            END 
        END 
      STDNO;
  SETVALUE: 
#**********************************************************************#
#                  S E T V A L U E                                     #
#                                                                      #
#   INITIALIZES COUNTERS AND POINTERS AND SETS UP TEMPORARY STORAGE    #
#   FOR LITERALS IN SCRATCHBUF.                                        #
#                                                                      #
#**********************************************************************#
      DFLAG = FALSE;         # INITIALIZE DIAGNOSTIC FLAG.             #
      LITCTR = 0;            # LITERAL COUNTER INITIALIZED             #
      LITSTART = WBPTR;      # STORES THE POINTER FOR START OF LITERAL #
                             # ENTRY                                   #
      SBITMVALLITP[ITEMPTR] = WBPTR - ITEMPTR; # STORES THE OFFSET     #
                                       # POINTER TO START OF LITERAL   #
                                       # ENTRY.                        #
      SCRTCHPTR = 0;     # INITIALIZES POINTER FOR SCRATCHBUF          #
      STDNO;
  SETFCONST:  
#**********************************************************************#
#                  S E T F C O N S T                                   #
#                                                                      #
#   SETS UP THE INDEX FOR BRANCH IN THE SWITCH VECTOR FO FIGURATIVE    #
#   CONSTANTS.                                                         #
#                                                                      #
#**********************************************************************#
      DFLAG = FALSE;
      FCVAR = 0;
      FCVAR = FCVAR LOR CURP1;
      FOR I = 59 STEP -1 UNTIL 55 DO   # SETS UP THE INDEX IN THE     # 
        BEGIN 
          IF B<I,1>FCVAR EQ 1 THEN      # SWITCH VECTOR AND BRANCHES #
            GOTO FCVECT[59-I];
          ELSE                          # ACCORDINGLY.               #
            TEST; 
        END 
                                # ACCORDINGLY.                         #
  SETALLLIT:  
#**********************************************************************#
#                  S E T A L L L I T                                   #
#                                                                      #
#   SETS THE LITERAL FIELD WITH THE LITERAL SPECIFIED IN THE FIG-      #
#   URATIVE CONSTANT( ALL "LIT" ). DEPENDING ON THE SIZE OF THE TARGET #
#   ITEM, THE LITERAL IS REPEATEDLY STORED IF SMALLER THEN TARGET      #
#   SIZE, AND A DIAGNOSTIC IS ISSUED IF LARGER. TARGET ITEM CLASS      #
#   SHOULD BE ALPHANUMERIC, ELSE RETURN STDNO.                         #
#                                                                      #
#**********************************************************************#
      I = PRIORITEM;
      DFLAG = FALSE;
      IF SBITMDBCLASS[I] NQ 0 THEN             # IF TARGET             #
        STDNO;    # NOT ALPHANUMERIC RETURN STDNO                      #
      IF CURLENG GR SBITMXPICSIZ[I] THEN     #IF LITERAL GREATER THAN  #
        STDNO;   # TARGET SIZE, RETURN STDNO                           #
      L = CURLENG;   # INITIALIZE SCRATCH VRIABLES                     #
      M = -1; 
      N = 0;
      J = 9;
      K = -1; 
      FOR I = 1 STEP 1 UNTIL SBITMXPICSIZ[PRIORITEM] DO     # LOOP     #
        BEGIN  # TO STORE LITERAL                                      #
          IF L EQ 0 THEN  #IF END OF LITERAL ,REPEAT PSTARTING AT      #
            BEGIN    # FIRST CHARACTER                                 #
              J = 9;  # REINITIALIZE VARIABLES                         #
              K = -1; 
              L = CURLENG;
            END 
          GETLITCHAR;   # PROC TO SGET CHARACTER FROM SOURCE         #
          IF M LS 9 THEN  # CHECK AND REINITIALIZING TAGRGET ARRAY     #
            M = M + 1;   #FOR WORD BOUNDARY.                           #
          ELSE
            BEGIN 
              M = 0;
              N = N + 1;
            END 
          C<M>CURWORD[N] = NXCHAR;  # STORE CHARACTER IN TARGET ARRAY  #
          L = L - 1;
        END 
      CURLENG = SBITMXPICSIZ[PRIORITEM];  # SET LIT LENG = TARGET LENG #
      STDYES; 
  SETDFLAG: 
#**********************************************************************#
#                  S E T D F L A G                                     #
#                                                                      #
#   SETS DFLAG TO TRUE IF A FIGURATIVE CONSTANT IS SPECIFIED ADND IS   #
#   NOT A VALID LITERAL.                                               #
#                                                                      #
#**********************************************************************#
      DFLAG = TRUE; 
      STDNO;
  CHKLIT1:  
#**********************************************************************#
#                  C H K L I T 1                                       #
#                                                                      #
#   LITERALS SPECIFIED IN THE CONDITION NAME ENTRY ARE CHECKED FOR     #
#   VALIDITY AGAINST THE PICTURE OR USAGE SPECIFICATIONS OF THE        #
#   TARGET ITEM. THIS LABEL SECTION IS FURTHER BROKEN UP INTO SUB-     #
#   SECTIONS DEPENDING ON DBMS CLASS, AND THE LITERALS, IF VALID, ARE  #
#   POINT AND SIZE ALIGNED( BLANK OR ZERO FILLED ) DEPENDING ON THE    #
#   SIZE OF TARGET ITEM. IF SUBJECT ITEM LITERAL IS NOT VALID, RETURN  #
#   IS TO STDNO, ELSE RETURN STDYES.                                   #
#                                                                      #
#**********************************************************************#
      MVBUFFER = "000000000000000000000000000000";
      SSIGN = FALSE;
      TSIGN = 0;
      SACPNT = FALSE; 
      SDECPT = 0; 
      BBPOS = 0;
      J = 9;
      K = -1; 
      IF SBITMDBCLASS[PRIORITEM] EQ 0 THEN  # IF TARGET CLASS = 0      #
        GOTO TCLASS0; 
      IF SBITMDBCLASS[PRIORITEM] EQ 1 THEN  # IF DBMS CLASS = 1        #
        GOTO TCLASS1; 
      FOR I = 0 STEP 1 UNTIL (SBITMXPICSIZ[PRIORITEM]-1)/10 DO  # INIT-#
        LITCHK2[I] = 0;     # IALIZE TARGET ARRAY TO ZEROS             #
      IF CURTYPE EQ 103 THEN
        STDNO;
  
 # CHECK FIRST CHARACTER FOR EXPLICIT SIGN  # 
      GETLITCHAR; 
      IF NXCHAR EQ "+" THEN  # IF LITERAL +VE THEN                     #
        BEGIN 
          BBPOS = 1;    # SET BEGINNING BYTE POSITION TO 1.            #
          POSSIGN = TRUE;  # AND SET FLAG TO INDICATE LITERAL +VE      #
        END 
      IF NXCHAR EQ "-" THEN  # IF LITERAL -VE THEN                     #
        BEGIN 
          BBPOS = 1;  # SET BEG. BYTE TO 1.                            #
          SSIGN = TRUE;  # AND INDICATE LITERAL -VE.                   #
        END 
  
 # CHECK FOR DECIMAL POINT.  #
      FOR I = 1 STEP 1 UNTIL CURLENG DO 
        BEGIN 
          IF NXCHAR EQ "." THEN 
            BEGIN 
              SACPNT = TRUE; # SET FLAG TO INDICATE DEC. PT. SPECIFIED #
              SDECPT = CURLENG - I;  # POSITION OF DEC. PT. FROM RIGHT #
              CURLENG = CURLENG - 1;  # DIGIT COUNT                    #
            END 
          GETLITCHAR; 
        END   # END OF FOR LOOP # 
  
      IF SACPNT AND SDECPT EQ 0 THEN  # CHECK IF DEC. PT IS THE LAST   #
        SACPNT = FALSE;  # CHARACTER ,IF SO SET FLAG TO FALSE.         #
      CURLENG = CURLENG - BBPOS;  # DIGIT COUNT                        #
      SIGDIGITS = CURLENG - SDECPT;  # COUNT OF SIG. DIGITS BEFORE DEC.#
      IF SBITMSIGNF[PRIORITEM] THEN 
        TSIGN = 1;                 # STORE TARGET SIGN.                #
      TDECPT = SBITMPTLOC[PRIORITEM];  #TARGET DEC. PT. LOCATION       #
      IF SSIGN AND TSIGN NQ 1 THEN # IF LITERAL -VE AND TARGET NOT    # 
        STDNO;     # SIGNED( S NOT SPECIFIED ), RETURN STDNO.         # 
      IF SBITMDBCLASS[PRIORITEM] EQ 3 THEN  # IF TARGET CLASS = 3      #
        GOTO TCLASS3; 
      ELSE
        GOTO TCLASSC;  # COMMON CLASS---4,12,13,14                     #
  
    TCLASS0:       # TARGET ITEM DBMS CLASS---ALPHANUMERIC( A,X,9 ).   #
      IF CURLENG GR SBITMXPICSIZ[PRIORITEM] THEN  # IF LENGTH OF LIT - #
        STDNO;     # ERAL GREATER THAN TARGET SIZE, RETURN STDNO.      #
      FOR I = 0 STEP 1 UNTIL (SBITMXPICSIZ[PRIORITEM]-1)/10 DO  # BLANK#
        LITCHK2[I] = BLANKS;  # FILL TARGET ARRAY                      #
      FOR I = 1 STEP 1 UNTIL CURLENG DO  # STORE LITERAL LEFT-JUSTIFIED#
        BEGIN                            # BLANK FILLED.               #
          GETLITCHAR; # GET NEXT CHARACTER                             #
          C<J>LITCHK2[K] = NXCHAR;
        END  # END OF FOR LOOP  # 
      K = (SBITMXPICSIZ[PRIORITEM]-1)/10;  # LENGTH IN WORDS OF TARGET #
      SBITMLLITTYP[LITSTART] = TRUE;
      STDYES; 
  
  TCLASS1:         # TARGET ITEM DBMS CLASS 1---ALPHABETIC( A ).       #
      IF CURLENG GR SBITMXPICSIZ[PRIORITEM] THEN  # IF LENGTH OF LIT-  #
        STDNO;   # ERAL GREATER THAN TARGET SIZE ,RETURN STDNO.        #
      FOR I = 0 STEP 1 UNTIL (SBITMXPICSIZ[PRIORITEM]-1)/10 DO # BLANK #
        LITCHK2[I] = BLANKS;      # TARGET ARRAY.                      #
      FOR I = 1 STEP 1 UNTIL CURLENG DO  # CHECKS TO SEE IF LITERAL    #
        BEGIN         # HAS ALL ALPHABETIC CHARACTERS OR BLANXS.       #
          GETLITCHAR;   # IF NOT ,RETURN STDNO. ELSE STORE CHARACTER IN#
          IF NXCHAR GR O"32" AND NXCHAR NQ O"55" THEN 
            STDNO;
          ELSE
            C<J>LITCHK2[K] = NXCHAR;  #TARGET ARRAY.                   #
        END  # END OF FOR LOOP  # 
      K = (SBITMXPICSIZ[PRIORITEM]-1)/10;  # LENGTH IN WORDS OF TARGET #
      SBITMLLITTYP[LITSTART] = TRUE;
      STDYES; 
  
  TCLASS3:         # TARGET ITEM DBMS CLASS 3---DISP. CODE NUMERIC(P,S)#
      IF CURLENG GR SBITMXPICSIZ[PRIORITEM] OR SACPNT THEN  # IF LIT-  #
        STDNO;  #ERAL > TARGET SIZE OR ACT. DEC. PT. SPEC.,RETURN STDNO#
  
 # MOVE LITERAL TO AN INTERMEDIATE BUFFER( MVBUFFER ).  # 
      CHARMOVE(LOC(CWORD),BBPOS,SIGDIGITS,LOC(MVBUFFER),
                             SBITMXPICSIZ[PRIORITEM]-SIGDIGITS);
  # MOVE LITERAL FROM INTER. BUFFER TO TARGET.  # 
      CHARMOVE(LOC(MVBUFFER),0,SBITMXPICSIZ[PRIORITEM],LOC(LITSTOR2),0);
      K = (SBITMXPICSIZ[PRIORITEM]-1)/10;  # LENGTH IN WORDS OF TARGET #
      STDYES; 
  
  TCLASSC:         # TARGET ITEM DBMS CLASS---4,10,13,14.              #
      LEFTPS = 0;  # INITIALIZE SCALING DIGITS COUNT                   #
      RIGHTPS = 0;
      IF TDECPT GR SBITMXPICSIZ[PRIORITEM] AND SBITMLFTPT[PRIORITEM]
        EQ 1 THEN 
        BEGIN  # IF SCALING LEFT, THEN                                 #
          IF SDECPT NQ CURLENG THEN  # IF IF LITERAL DEC. PT. NOT      #
            STDNO;  # FIRST CHARACTER, THEN STDNO.                     #
          ELSE
            BEGIN 
              J = BBPOS;  # BEGINNING BYTE FOR CHAR. FETCH.            #
              K = 0;
              FOR I = 1 STEP 1 UNTIL CURLENG DO  # IDENTIFY LEAD ZEROS #
                BEGIN 
                  GETLITCHAR; 
                  IF NXCHAR NQ O"33" THEN  # IDENTIFY LEAD ZEROS       #
                    GOTO LEFTZEROS; 
                  ELSE
                    LEFTPS = LEFTPS + 1;  # COUNT OF LEAD ZEROS.       #
                END  # END OF FOR LOOP  # 
  LEFTZEROS:   # THRU IDENTIFYING LEAD ZEROS.  #
              IF LEFTPS LS (TDECPT - SBITMXPICSIZ[PRIORITEM]) THEN  #IF#
                STDNO;  # COUNT OF SCALING DIGITS NOT EQ TARGET -STDNO #
              IF CURLENG GR TDECPT THEN  # LITERAL > TARGET SIZE-STDNO #
                STDNO;
  # MOVE LITERAL TO INTER. BUFFER.      # 
              CHARMOVE(LOC(CWORD),BBPOS+1,CURLENG,LOC(MVBUFFER),0); 
   # MOVE FROM INTER BUFFER TO TARGET  #
              CHARMOVE(LOC(MVBUFFER),0,TDECPT,LOC(LITSTOR2),0); 
              K = (TDECPT-1)/10;  # LENGTH IN WORDS OF TARGET ITEM   #
              STDYES; 
            END 
        END 
  
      IF SBITMPTINFO[PRIORITEM] EQ 0 AND (TDECPT GR 0) THEN #IF TARGET #
        BEGIN     # DEC.PT. BITS EQ 0 ,BUT DEC.PT. LOC. NQ 0 THEN      #
          IF SDECPT NQ 0 THEN  # IF LITERAL DEC.PT. LOC. NOT EQ 0      #
            STDNO;    # THEN RETRUN STDNO.                             #
          K = ((CURLENG-1)/10); # LAST WORD POSITION OF LITERAL        #
          J = 10 - (((K+1)*10)-CURLENG);  # LAST CHAR. POSITION OF LIT.#
          FOR I = CURLENG+BBPOS STEP -1 UNTIL BBPOS DO
            BEGIN 
              IF J GR 0 THEN
                J = J - 1;
              ELSE
                BEGIN 
                  J = 9;
                  K = K - 1;
                END 
              NXCHAR = C<J>CURWORD[K];
              IF NXCHAR NQ O"33" THEN 
                GOTO RIGHTZEROS;
              ELSE
                RIGHTPS = RIGHTPS + 1;  # COUNT OF RIGHT ZEROS.        #
            END  # END OF FOR LOOP  # 
  RIGHTZEROS:  # THRU IDENTIFYING RIGHT ZEROS,.     # 
          IF RIGHTPS LS TDECPT THEN  # IF SCALING ZEROS NOT EQ TO      #
            STDNO;     # TARGET SCALING SIZE, THEN RETURN STDNO.       #
          IF CURLENG GR (SBITMXPICSIZ[PRIORITEM]+TDECPT) THEN     # IF #
            STDNO;  # LITERAL LENGTH > TARGET SIZE ,RETURN STDNO.      #
  # MOVE LITERAL TO INTERMEDIATE BUFFER( MVBUFFER ).  # 
          CHARMOVE(LOC(CWORD),BBPOS,CURLENG,LOC(MVBUFFER),
                         (SBITMXPICSIZ[PRIORITEM]+TDECPT)-CURLENG); 
  # MOVE ALIGNED LITERAL FROM INTER. BUFFER TO TARGET ARRAY            #
        CHARMOVE(LOC(MVBUFFER),0,SBITMXPICSIZ[PRIORITEM]+TDECPT,
                           LOC(LITSTOR2),0);
        K = (SBITMXPICSIZ[PRIORITEM]+TDECPT-1)/10;  # LENGTH OF TARGET #
          STDYES; 
        END 
  
      IF SDECPT GR TDECPT THEN  #  LOCATION OF DEC. PT IN SOURCE      # 
        STDNO;  # GREATER THAN LOC. IN TARGET, RETURN STDNO.           #
      IF SIGDIGITS GR (SBITMXPICSIZ[PRIORITEM]-TDECPT) THEN       # IF #
        STDNO;  # DIGITS TO LEFT OF DEC. PT. IN SOURCE GREATER THAN    #
              # CORRESPONDING DIGITS IN TARGET, THEN RETURN STDNO.     #
      I = SBITMXPICSIZ[PRIORITEM] - TDECPT - SIGDIGITS; # BYTE POSITION#
                # FOR START OF SOURCE MOVE INTO INTER. BUFFER.         #
  
      # MOVE SIGNIFICANT DIGITS OF LITERAL INTO INTER. BUFFER.  # 
      CHARMOVE(LOC(CWORD),BBPOS,SIGDIGITS,LOC(MVBUFFER),I); 
  
      I = I + SIGDIGITS;  # BEGINNING BYTE POSITION OF FOR DEC. DIGITS #
  
     # MOVE DECIMAL DIGITS INTO INTER. BUFFER.  # 
      CHARMOVE(LOC(CWORD),(SIGDIGITS+BBPOS+1),SDECPT,LOC(MVBUFFER),I);
  
     # MOVE FROM INTER. BUFFER TO TARGET ARRAY.  #
      CHARMOVE(LOC(MVBUFFER),0,SBITMXPICSIZ[PRIORITEM],LOC(LITSTOR2),0);
      K = (SBITMXPICSIZ[PRIORITEM]-1)/10;  # LENGTH IN WORDS OF TARGET #
  
      STDYES; 
  CHKLIT2:  
#**********************************************************************#
#                  C H K L I T 2                                       #
#                                                                      #
#   LITERALS ARE COMPARED FOR ASCENDING ORDER---ALPHABETIC AND ALPHA-  #
#   NUMERIC LITERALS ARE COMPARED ACCORDIND TO THEIR COLLATING SEQUEN- #
#   CE VALUES. NUMERIC LITERALS ARE COMPARED ACCORDING TO THEIR DISPLAY#
#   CODE VALUES. IF LITERAL1GQ LITERAL2 GQ LITERAL3---, THEN RETURN    #
#   TO STDNO. LITERALS ARE THEN STORED TEMPORARILY IN SCRATCHBUF AND   #
#   LITERAL INFORMATION( LENGTH,TYPE,SIGN INFO,) ARE ENTERED IN TABLES #
#                                                                      #
#**********************************************************************#
      J = 0;
      FOR I = SCRTCHPTR STEP 1 UNTIL (K+SCRTCHPTR) DO  # STORE LITERAL #
        BEGIN 
          SCRATCHWRD[I] = LITCHK2[J];                  # IN SCRATCHBUF #
          J = J + 1;
        END 
      SCRTCHPTR = I;    # INCREMENT POINTER TO POINT TO NEXT AVAIL-    #
                             # ABLE WORD IN SCRATCHBUF.                #
  
     # INSERT CHECK FOR SCRATCHBUF OVERFLOW, IF NEED ARISES AT SOME    #
     # LATER DATE.                                                     #
  
      IF LITCTR NQ 0 THEN    # IF NOT FIRST LITERAL                    #
        BEGIN 
        IF THRUSPECFD THEN    # IF THE THRU OPTION SPECIFIED THEN      #
          BEGIN               # LITERALS ASSOCIATED ARE TO BE CHECK-   #
                              # ED FOR VALID ASCENDING ORDER SEQUENCE. #
          FOR I = 0 STEP 1 UNTIL K DO 
            BEGIN   # BEGIN OF FOR LOOP--1 #
              THRUSPECFD = FALSE; 
              IF SBITMDBCLASS[PRIORITEM] LQ 1 THEN # IF LITERAL        #
                BEGIN                                    # NON-NUMERIC #
                  FOR J = 0 STEP 6 UNTIL 54 DO  # CONVERT DISPLAY CODE #
                    BEGIN  # BEGIN OF FOR LOOP-2 #
                      WRDINDX = B<J,3>LITCHK1[I];  # VALUE INTO COBOL  #
                      BYTINDX = B<J+3,3>LITCHK1[I]*6; #COLLATING SEQ-  #
                      B<J,6>LITALPH1 = B<BYTINDX,6>CBLCS[WRDINDX];
                      WRDINDX = B<J,3>LITCHK2[I];  # UENCE VALUE.      #
                      BYTINDX = B<J+3,3>LITCHK2[I]*6; 
                      B<J,6>LITALPH2 = B<BYTINDX,6>CBLCS[WRDINDX];
                      IF B<J,6>LITALPH1 LS B<J,6>LITALPH2 THEN
                        GOTO SKPCHK;
                      IF B<J,6>LITALPH1 EQ B<J,6>LITALPH2 AND 
                               ((I LS K) OR (J LS 54)) THEN 
                        TEST; 
                       STDNO; 
                     END   # END OF FOR-LOOP--2 # 
                   TEST I;
                END 
              IF SFLAG THEN    # IF FIRST LITERAL -VE                  #
                BEGIN 
                  IF SSIGN THEN  # AND SECOND LITERAL ALSO -VE THEN    #
                    LITCHK1[I] == LITCHK2[I];  # EXCHANGE LITERALS     #
                  ELSE            # AND FALL TO COMPARE                #
                    GOTO SKPCHK; # IF SECOND LITERAL NOT -VE, THEN     #
                END              # SKIP COMPARE AS SECOND LIT. GREATER #
              ELSE
                IF SSIGN THEN      # IF FIRST LITERAL +VE AND SECOND   #
                  STDNO;  # LITERAL -VE, THEN RETURN STDNO.            #
  
              IF LITCHKC1[I] GR LITCHKC2[I] THEN # IF LIT1 > LIT2     # 
                STDNO;     # THEN RETURN TO STDNO.                     #
              IF LITCHKC1[I] EQ LITCHKC2[I] THEN # IF LIT1 = LIT2 THEN# 
                BEGIN 
                  IF K GR I THEN  # IF LENGTH GREATER 1 WORD THEN      #
                    TEST;          # GO BACK AND INCREMENT WORD POINTER#
                  ELSE    # TO POINT TO NEXT WORD. IF LENGTH NOT > 1   #
                    STDNO;         # THEN RETURN STDNO.                #
                END 
              ELSE GOTO SKPCHK;  # LITERAL < LITERL2.                  #
            END     # END OF FOR LOOP # 
          END 
        END 
  SKPCHK:   #   # 
      SBITMLLTWLEN[LITSTART] = K + 1;  # LENGTH OF LIT. IN WORDS      # 
      SBITMLLITLEN[LITSTART] = SBITMXPICSIZ[PRIORITEM];  # LENGTH IN   #
                                        # CHARACTERS                   #
      SBITMLPTLOC[LITSTART] = TDECPT;  # STORE DECIMAL POINT LOCATION. #
      IF SSIGN THEN 
        SBITMLLITSGN[LITSTART] = 2;  # LITERAL -VE                     #
      ELSE
        BEGIN 
          IF POSSIGN THEN 
            SBITMLLITSGN[LITSTART] = 1;  # LITERAL +VE                 #
        END 
      FOR I = 0 STEP 1 UNTIL K DO  # STORE LITERAL FOR COMPARISON      #
        LITCHK1[I] = LITCHK2[I];
      LITCTR = LITCTR + 1;   # INCREMENT LITERAL COUNT                 #
      LITSTART = LITSTART + 1;  # INCREMENT WORD POINTER FOR LIT. ENTRY#
      SFLAG = SSIGN;  # SET SIGN FLAG                                  #
      STDYES; 
  CHKTHRU:  
#**********************************************************************#
#                  C H K T H R U                                       #
#                                                                      #
#   SETS THE THRU BIT IN THE TABLES AND RETURNS STDYES.                #
#                                                                      #
#**********************************************************************#
      SBITMLLITTHU[LITSTART - 1] = TRUE;
      SBITMLLITTHU[LITSTART] = TRUE;
      THRUSPECFD = TRUE;
      STDYES; 
  VALRTRN:  
#**********************************************************************#
#                  V A L R T R N                                       #
#                                                                      #
#   POINTERS TO CORRESPONDING LITERALS AND THE NEXT BIT IS SET IN      #
#   THE LITERAL HEADERS. LITERALS STORED IN SCRATCHBUF ARE MOVED TO    #
#   THE DIRECTORY WORK BUFFER. IF THE LITERALS CAUSE A BUFFER OVERFLOW,#
#   DDL IS ABORTED.                                                    #
#                                                                      #
#**********************************************************************#
      IF DFLAG THEN 
        BEGIN 
          ZEROSCRTCH(SCRTCHPTR);   # ZERO OUT SCRATCHBUF               #
          STDNO;
        END 
  
#   STORE THE NEXT BIT IN LITERAL HEADER #
      FOR I = 0 STEP 1 UNTIL LITCTR-2 DO
        SBITMLNXTLIT[WBPTR+I] = TRUE; 
      J = LITCTR;      # NUMBER OF WORDS OCCUPIED BY LITERAL HEADERS.  #
#   STORE OFFSET POINTERS TO CORRESPONDING LITERALS IN LITERAL HEADER  #
      FOR I = 0 STEP 1 UNTIL LITCTR-1 DO
        BEGIN 
          SBITMLLITPTR[WBPTR+I] = J + WBPTR - ITEMPTR;
          J = J + ((SBITMXPICSIZ[PRIORITEM]-1)/10) + 1; 
        END 
      WBPTR = WBPTR + LITCTR;      # NEXT AVAILABLE WORD FOR LITERAL   #
                                   # MOVE.                             #
      CHECKFL;
  
#   MOVE LITERALS FROM SCRATCHBUF TO DIRECTORY WORK BUFFER #
      FOR I = 0 STEP 1 UNTIL SCRTCHPTR-1 DO 
        BEGIN 
          SBITMLITERAL[WBPTR] = SCRATCHWRD[I];
          WBPTR = WBPTR + 1;
          CHECKFL;
        END 
  
      ZEROSCRTCH(SCRTCHPTR);       # ZERO OUT SCRATCHBUF.              #
      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; 
      STDNO;
  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 BEING 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;
  
  
  
  PROC BUILDINDEX;
    BEGIN 
#**********************************************************************#
#                                                                      #
#                  B U I L D I N D E X                                 #
#                                                                      #
#   BUILDS THE REALM LIST. STORES THE REALM NAME AND WORD ADDRESS.     #
#                                                                      #
#**********************************************************************#
  
#   TEST IF THE REALM LIST ENTRY WILL FIT IN THE REALM LIST.           #
  
      IF REALMLSTPTR +4 GQ REALMSZ
      THEN                   # ENLARGE THE REALM LIST                  #
        BEGIN 
  
#   MAKE A DUMMY EXPANSION OF CBWORKBUF, THEN REDUCE IT AGAIN.         #
  
        WBPTR = WBPTR + RLMINCR;
        CHECKFL;             # GET FIELD LENGTH IF REQUIRED.           #
        WBPTR = WBPTR - RLMINCR;
  
#   MOVE UP THE SUBSCHEMA DIRECTORY (CBWORKBUF) TO MAKE ROOM.          #
  
        FOR I = WBPTR STEP -1 UNTIL 0 
        DO
          BEGIN 
          BUFWORD[I + RLMINCR] = BUFWORD[I];
          END 
        SBSCHMA = SBSCHMA + RLMINCR;
        P<CBWORKBUF> = SBSCHMA; 
  
#   ENLARGE THE REALM LIST AND CLEAR THE EXTENDED WORDS.               #
  
        FOR I = REALMSZ + RLMINCR -1 STEP -1 UNTIL REALMSZ
        DO
          BEGIN 
          REALMLISTNME[I] = 0;
          END 
        REALMSZ = REALMSZ + RLMINCR;
        END 
  
#   GET THE REALM LIST NAME FROM THE REALM ENTRY                       #
#   AND STORE IT IN THE REALM LIST.                                    #
  
      FOR I=0 STEP 1 UNTIL SBARLENGWRDS[ARPTR] - 1
      DO
        REALMLISTNME[REALMLSTPTR+I] = SBARNAME[ARPTR +
                                       SBARNAMEPTR[ARPTR] + I]; 
  
#   STORE THE WORD ADDRESS OF THE REALM ENTRY.                         #
  
      REALMADR[REALMLSTPTR] = ARPTR;
  
#   STORE THE LENGTH OF THE REALM ENTRY.                               #
  
      REALMENTRYLG[REALMLSTPTR] = WBPTR - ARPTR;
  
#   INCREMENT THE REALM LIST POINTER TO THE NEXT REALM LIST ENTRY.     #
  
      REALMLSTPTR = REALMLSTPTR + 4;
  
      RETURN; 
  
    END 
  
  
  
  
  PROC HASHTABLE;                                                       014970
      BEGIN 
#**********************************************************************#
#                                                                      #
#                  H A S H T A B L E                                   #
#                                                                      #
#   VALIDATE THE UNIQUENESS OF AREA, RECORD AND ITEM NAMES             #
#                                                                      #
#**********************************************************************#
                                                                        002204
      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                    # IF NO NEXT SYNONYM EXISTS         #002280
      THEN                                                              002290
        BEGIN                                                           002300
        IF ENTRYTYPE EQ ITEMS      # IF ITEM ENTRY                     #002310
        THEN                                                            002320
          SBITMSYNADDR[SBWRDADR] = SBPTR;  # STORE SYNONYM WORD ADDRESS#002340
        ELSE                       # IF NOT AN ITEM ENTRY              #002370
          BEGIN                                                         002380
          IF ENTRYTYPE EQ RECORD   # IF RECORD ENTRY                   #002390
          THEN                                                          002400
            SBRECSYNADR[SBWRDADR] = SBPTR;  # STORE SYNONYM WRD ADDRESS#002420
          ELSE                     # MUST BE AN AREA ENTRY             #002450
            BEGIN                                                       002451
            SBARSYNADDR[SBWRDADR] = SBPTR;  # STORE SYNONYM WRD ADDRESS#002460
            RETURN;                                                     002461
            END                                                         002462
          END                                                           002470
          IF HSHTYPE EQ ITEMS                                           002471
          THEN                                                          002472
            SBITMUNIQFLG[SBPTR] = TRUE;  # SET UNIQUE FLAG IN CUR ENTRY#002473
          IF HSHTYPE EQ RECORD                                          002474
          THEN                                                          002475
            SBRECUNIQFLG[SBPTR] = TRUE;  # SET UNIQUE FLAG IN CUR ENTRY#002476
          RETURN;                                                       002480
        END                                                             002490
      SBWRDADR = J; 
      GOTO CONTSYNM;
  
CKSMENAME:  
      IF ENTRYTYPE EQ ITEMS              # IF ENTRY TYPE IS ITEM       #002206
      THEN                                                              002207
        SBITMUNIQFLG[SBWRDADR] = FALSE; 
      IF ENTRYTYPE EQ RECORD             # IF ENTRY TYPE IS RECORD     #002220
      THEN                                                              002221
        SBRECUNIQFLG[SBWRDADR] = FALSE;  # CLEAR UNIQUE RECORD NAME FLG#002230
      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
          IF HSHTYPE  EQ ITEMS THEN  # CHECK IF ENTRIES ARE ITEM ENTRIE#015570
            BEGIN                                                       015580
              J = ITEMPTR;
              FOR J = J WHILE SBITMDOMADR[J] NQ RECPTR DO  # SEARCH FOR#
                J = J - SBITMPRIORP[J]; # DOMINANT ITEM AT HIGHEST LVL.#
              IF SBITMDOMADR[SBWRDADR] NQ SBITMDOMADR[ITEMPTR] AND
                 SBWRDADR LS J THEN  # CHECK FOR SAME DOMINANT ADDRESS.#
                GOTO CKSAMECONT;   # SAME-NAME IS NOT A PART OF THE    #
                                   # REPEATING GROUP THE SUBJECT ITEM  #
                                   # BELONGS TO --- GET NEXT ENTRY IN  #
                                   # THE SAME-NAME CHAIN.              #
            END                                                         015640
          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 HSHTYPE EQ ITEMS THEN          # IF ENTRY TYPE IS ITEM        #
        SBITMUNIQFLG[SBWRDADR] = TRUE;  # SET UNIQUE NAME FLAG         #
      IF HSHTYPE EQ RECORD               # IF ENTRY TYPE IS RECORD     #002250
      THEN                                                              002251
        SBRECUNIQFLG[SBWRDADR] = TRUE;   # SET UNIQUE RECORD NAME FLAG #002260
      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 ;
      S = SBSCHMA + WBPTR ; 
      IF S + 25 GR DDLSU THEN      # UPDATE STORAGE USED               #
        DDLSU = S + 25; 
      IF S GR LASTWORD             # IF BEYOND CURRENT FIELD LENGTH    #
        OR                         # OR WASTING EXCESS MEMORY          #
          S + RESMAXP1 LS LASTWORD
      THEN
        BEGIN 
          S = ((S + 25 + 63) / 64) * 64 ; 
          IF S GR MAXFL                     # IF GREATER THAN MAXIMUM  #
          THEN                              # FIELD LENGTH ALLOWED     #
            BEGIN 
              DIAGDL(171) ;                 # ISSUE DIAGNOSTIC         #
              ABRT1 ;                       # AND ABORT                #
            END 
  
#         EXTRA MEMORY IS REQUESTED AND KEPT IN RESERVE.               #
  
          S = S + RESERVEP1;
          IF S GR MAXFL 
          THEN
            BEGIN 
            S = MAXFL;
            END 
          MEMORY (S) ;                      # ADJUST THE FIELD LENGTH  #
  
#         CLEAR THE NEWLY ACQUIRED MEMORY BLOCK.                       #
  
          S = B<0,30>DDLMEM -4; 
          FOR I = LASTWORD + 25 STEP 4 UNTIL S
          DO
            BEGIN 
            RAWORD[I] = 0;
            RAWORD[I+1] = 0;
            RAWORD[I+2] = 0;
            RAWORD[I+3] = 0;
            END 
          LASTWORD = B<0,30>DDLMEM -25; 
        END 
      RETURN; 
    END 
  
  
      XDEF PROC CONVLNENBR; 
  PROC CONVLNENBR(LNENBR);
#**********************************************************************#
#                  C O N V L N E N B R                                 #
#                                                                      #
#   CONVERTS A BINARY LINE NUMBER TO DISPLAY CODE.                     #
#   RETURNS A FIVE DIGIT NUMBER, RIGHT JUSTIFIED IN NBRLINE.           #
#                                                                      #
#**********************************************************************#
    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.  #
#   RETURNS A VARIABLE NUMBER OF DIGITS LEFT JUSTIFIED IN ORDNUM.      #
#                                                                      #
#**********************************************************************#
    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 
          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
      CONTROL EJECT;
  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 KEYSTORE;
    BEGIN 
      SBITMOCCLTYP[J] = SCRTOCCKYTY[SCRTCHPTR]; 
      SBITMOCCLDNA[J] = HSHADDR;
      SBITMOCCLDNO[J] = SBITMORDINAL[HSHADDR];
      J = J + 1;
      FOR QALPTR=0 STEP 4 WHILE QALNME[QALPTR] NQ 0 DO
        BEGIN 
          SBITMOCCLQAL[J-1] = TRUE; 
          SBITMOCCLNXT[J-1] = TRUE; 
          SBITMOCCLDNA[J] = QALADR[QALPTR]; 
          SBITMOCCLDNO[J] = QALORD[QALPTR]; 
          J = J + 1;
        END 
      ZEROQAL;
      IF SCRATCHWRD[I] GR 0 OR SCRTOCCKYTY[0] EQ 1 THEN 
      SBITMOCCLNXT[J-1] = TRUE;    # SET NEXT ENTRY BIT # 
      RETURN; 
    END 
  PROC STOREINDEX;
    BEGIN 
      K = J + 200;  # SET POINTER TO SCRATCH AREA DOWN AWAYS IN WORKBUF#
      FRSTADDR = K; 
      LASTADDR = J; 
      H = INDEXCNT; 
      M = 0;
      FOR I=SCRTCHPTR STEP SCRTOCCKYNX[I] WHILE INDEXCNT NQ 0 DO
            # PROCESS THE INDEX ENTRIES IN SCRATCHBUF. INDEXCNT CONTAIN#
            # THE NUMBER OF INDEX ENTRIES.                             #
        BEGIN 
          SBITMOCCLTYP[J] = SCRTOCCKYTY[I];   # STORE TYPE.            #
          SBITMOCCLINL[J] = SCRTOCCKYLC[I];   # INDEX NAME LENGTH(CHAR)#
          SBITMOCCLINP[J] = (LASTADDR + H + M) - SCRTOCCKYA[I]; 
            # STORE OFFSET POINTER FROM                                #
                  # THE FIRST WORD OF THE ITEM ENTRY TO POINT TO THE   #
                  # INDEX NAME.                                        #
          INDEXCNT = INDEXCNT - 1; # DECREMENT THE INDEX ENTRY COUNT.  #
          FOR N=0 STEP 1 UNTIL SCRTOCCKYLN[I] - 1 DO
            # STORE INDEX FROM SCRATCHBUF INTO WORKBUF.                #
            SBITMINDEXNM[K+N] = SCRTOCCKYNM[I+N]; 
          K = K + N; # INCREMENT POINTER TO THE NEXT AVAILABLE WORD FOR#
          N = I + SCRTOCCKYNX[I]; 
          IF SCRTOCCKYNX[I] NQ 0 AND SCRTOCCKYTY[N] EQ 1 THEN 
            SBITMOCCLNXT[J] = TRUE; #ANOTHER INDEX ENTRY-SET NEXT FLAG.#
          M = M + SCRTOCCKYLN[I]; # INCREMENT COUNTER THAT             #
              # CONTAINS THE WORD COUNT OF ALL THE INDEX NAME LENGTHS. #
          J = J + 1;         # INCREMENT POINTER TO NEXT AVAILABLE WORD#
        END 
      FOR I=0 STEP 1 UNTIL M - 1 DO # MOVE THE INDEX NAMES FROM THE    #
            # SCRATCH PART OF WORKBUF TO THE INDEX ENTRY OF THE GROUP  #
            # ITEM WHERE THE INDEX NAMES WHERE ORIG DEFINED.           #
        BEGIN 
          SBITMINDEXNM[J+I] = SBITMOCCWRD[FRSTADDR+I];
          SBITMOCCWRD[FRSTADDR + I] = 0; # ZERO OUT THE INDEX NAME.    #
        END 
      RETURN; 
    END 
PROC STORFC;  #STORES THE VALUE OF FIG CONST. IN ARRAY LITSTOR2        #
#**********************************************************************#
#                  S T O R F C                                         #
#                                                                      #
#    FILLS CURWORD WITH THE VALUE OF THE FIGURATIVE CONSTANT UPTO      #
#    TARGET ITEM SIZE.                                                 #
#                                                                      #
#**********************************************************************#
    BEGIN 
      FOR I = 0 STEP 1 UNTIL CURLENW-1 DO 
        CURWORD[I] = 0; 
      CURLENG = SBITMXPICSIZ[PRIORITEM];
      K = -1; 
      J = 9;
      FOR I = 1 STEP 1 UNTIL SBITMXPICSIZ[PRIORITEM] DO 
        BEGIN 
          IF J LS 9 THEN
            J = J+1;
          ELSE
            BEGIN 
              J = 0;
              K = K+1;
            END 
          C<J>CURWORD[K] = FCONST;
        END 
    END 
  PROC STORQALINFO; 
#**********************************************************************#
#                   S T O R Q A L I N F O                              #
#                                                                      #
#   STORES THE QUALIFIER INFORMATION FOR A RENAMES ENTRY IN THE APPR-  #
#   OPRIATE PORTION OF THE WORD(LEFT OR RIGHT 30 BITS) IN THE DIRECTORY#
#                                                                      #
#**********************************************************************#
    BEGIN 
      FOR QALPTR=0 STEP 4 WHILE QALNME[QALPTR] NQ 0 DO
        BEGIN 
          IF SBITMLRNDNAD[WBPTR] EQ 0 THEN
            BEGIN 
              SBITMRRNNXT[WBPTR-1] = TRUE;
              SBITMRRNQALF[WBPTR-1] = TRUE; 
              SBITMLRNDNAD[WBPTR] = QALADR[QALPTR]; 
            END 
          ELSE
            BEGIN 
              SBITMLRNNXT[WBPTR] = TRUE;
              SBITMLRNQALF[WBPTR] = TRUE; 
              SBITMRRNDNAD[WBPTR] = QALADR[QALPTR]; 
              WBPTR = WBPTR + 1;
            END 
        END 
      ZEROQAL;
      RETURN; 
    END 
  PROC ZEROQAL; 
    BEGIN 
      FOR N=0 STEP 1 UNTIL 39 DO
        QALNME[N] = 0;
      QALPTR = 0; 
      RETURN; 
    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
