*DECK QDLSYN                                                            000150
      PRGM DL30301;                # THIS IS 3,1 OVERLAY               # DL3A030
  
  
       BEGIN
      CONTROL NOLIST;               # TURN OFF LISTING OF COMDDIAG     # D2A130 
*CALL COMDDIAG - DIAGNOSTIC MESSAGES                                     D2A130 
      CONTROL LIST;                                                      D2A130 
                                                                         D2A130 
      DEF  ASCEND    #   0#; # SORTED ASCENDING                        # D20134 
      DEF  DESCEND   #  01#;       # SORTED DESCENDING                 #
      DEF  DFCOMP    #  02#;       # USAGE IS COMP/COMPUTATIONAL       #
      DEF  DFCOMPLEX #  07#;       # USAGE IS COMPLEX                  #
      DEF  DFCOMP1   #  09#;       # USAGE IS COMP-1                   #
      DEF  DFCOMP2   #  04#;       # USAGE IS COMP-2                   #
      DEF  DFDISPLAY #  01#;       # USAGE IS DISPLAY                  #
      DEF  DFDOUBLE  #  05#;       # USAGE IS DOUBLE                   #
      DEF  DFINTEGER #  03#;       # USAGE IS INTEGER                  #
      DEF  DFLOGICAL #  06#;       # USAGE IS LOGICAL                  #
      DEF  DFNMERICED # 06#;       # CLASS IS NUMERIC EDIT             #
      DEF  DFNUMDBPS #   7#;       # MAX NUMBER OF DBPS-1 ALLOWED      #
      DEF  DFNUMERIC #  02#;       # CLASS IS NUMERIC                  #
      DEF  SQ        #   0#;       # INDEX INTO SQBUF                  #
      DEF  NL        #  42#;       # NAME LENGTH IN BITS               #
      DEF  WC        #  10#; # WORD LENGTH IN CHARACTERS               # D20134 
      DEF  WL        #  60#; # WORD LENGTH IN BITS                     # D20134 
       DEF NUMWDS #B<0,6>#; 
       DEF UNSPECIFIED    #0#   ; 
       DEF SPECIFIED       #1#  ; 
       DEF POINTLEFT    #0#     ; 
       DEF POINTRIGHT   #1#     ; 
       DEF ASSUMEPOINT  #0#     ; 
           DEF  ZEROVAL #4#;
           DEF CHARCNT  #CURLENG#;
           DEF WORDLEN  #CURLENW#;
          DEF DNTBASE #FIRSTWO#;
           DEF DOWNBOT  #DDLMEM# ;
           DEF SADNO # STDNO#;
           DEF SADYES #STDYES#; 
     #    THESE ARE ALTERNATE ENTRY POINTS TO SAD                    #
     #    SYMPL DOES NOT PROVIDE A GOTO TO AN EXTERNAL LABEL         #
     #    THAT GENERATES AN EQ OR JP COMPASS INSTRUCTION             #
     #    THEREFOR THE EXTERNAL S MUST BE TREATED AS A PROC  FOR     #
     #    WHICH SYMPL GENERATES AN RJ INSTRUCTION                    #
       DEF COBOL        #0#     ; 
       DEF FORTRAN      #1#     ; 
       DEF INTERNAL     # 1 #;              # BLOCK TYPE = I           #
          DEF CHARCOUNT  #2#;          # BLOCK TYPE =C= #               001670
       DEF FIXEDNUMBER  # 3 #;              # BLOCK TYPE = K           #
       DEF EXACTNUMBER  # 4 #;              # BLOCK TYPE = E           #
       DEF SDA          #5#  ;
       DEF SIS          #3#  ;
       DEF SEQ          #0#  ;
      DEF SAK #6#;
       DEF SYMBOLIC     #1#  ;
       DEF TRAILERCOUNT #5#  ;
         DEF FIXLENRT  #1#;                                             001280
          DEF DCHARCOUNT  #4#;                                          001690
       DEF UNDEFINED    #7#  ;
       DEF CONTROLWORD  #0#  ;
       DEF ZEROBYTE     #3#  ;
       DEF RECORDESCR  #0#; 
       DEF NONE        #0#; 
         DEF  AREATYPE  #2#;
      DEF FITLENGTH   #35#; 
       DEF UPDATE  # 0#;
       DEF RETRIEVAL #1#; 
       DEF  GROUP        #0#; 
       DEF FILLR         #O"3"#;
       DEF FILLER        #"AFILLER"#; 
          DEF BINZEROES     #00000000000000000000#; 
       DEF RECORDONCALL  #O"101"#;
       DEF ELEMENTARY    #O"1"#;
        DEF RECMARK #2#;
       DEF RECORDMARK #O"62"#;
       DEF RECORDS    #1#;
       DEF CHARACTER  #0#;
       DEF MAXOF262142 #O"354135343735"#; 
       DEF RECORDONLY  #0#; 
       DEF DIAGNOSTIC #DIAGNOS#;
        DEF DDITEM #1#; 
        DEF DUPFIRST #1#; 
        DEF DUPLAST  #2#; 
        DEF DUPNOT   #3#; 
        DEF ONOPEN   #0#; 
        DEF ONSEARCH #1#; 
        DEF ONMATCH  #2#; 
        DEF ONMISMATCH #3#; 
        DEF ONUPDATE #4#; 
        DEF ONDISPLAY #5#;
        DEF ONCLOSE  #6#; 
    XDEF BEGIN
           ARRAY PICTEMP[31]; 
            ITEM PICWORD U(0,0,60); 
           ARRAY MURAL[31];                                              D2A164 
                 ITEM PICTURWORD;                                        D2A164 
     END
      XDEF ITEM MXPICSZ I = 2048;  # MAXIMUM SIZE OF ALPHA-NUMERIC     #
                                   # ITEMS                             #
      XREF BEGIN                                                         D2A149 
           PROC STDNO;
           PROC STDYES; 
           PROC ABRT1;                 # ABORT THIS RUN                # TESTFL 
           PROC DDLPRNT;
                PROC ABRT4; 
                ITEM ENDCOMP; 
        PROC DIAGS; 
       PROC PICTUR; 
           ARRAY NAMEID [4];
            ITEM NAMEIDENT U(0,0,60); 
       PROC HASH; 
          PROC PRINTNM; 
          ITEM  ENDDNT; 
          ITEM  LOFANMS;
      ITEM NBRLINE C(10);          # CURRENT LINE NUMBER               #
          ITEM  NUMANMS;
          ITEM  NUMDNMS;
           ITEM  DDLCOMP; 
           ITEM DDLSU;             # STORAGE USED BY THIS COMPILATION  #
       ITEM  HASHTBL; 
       ITEM  SBLOCK;
      ITEM LIBFDB;           #FDB FOR SCHEMA LIBRARY FILE#
       ITEM DNTNDX; 
        ITEM DIAGNOS; 
       ITEM HRSLT;                    # CONTAINS 9 BIT HASH RESULT# 
        ARRAY CWRD[25]; 
      BEGIN 
         ITEM CURNWD U(0,0,60); 
         ITEM CWC9 U(0,6,54); 
         ITEM CWC1 U(0,0,6);
         ITEM CURNWD7 U(0,0,42);
      END 
           ITEM CURLENG ; 
           ITEM NEXLENG ; 
           ITEM CURLENW ; 
           ITEM NEXLENW ; 
          ITEM FIRSTWO; 
         ARRAY CWORD[25]; 
            ITEM CURWORD U(0,0,60); 
           ITEM DDLMEM; 
          ITEM  CURP1;
        ARRAY NEXWORD[25];
          ITEM NEXWRD U(0,0,60);
       ITEM EOMNDX; 
      ITEM OSNAME;   #OPERATING SYSTEM# 
       END
      ITEM BLOCKFLAG B;            # BLOCK CONTAINS N RECORDS FLAG     # D2A130 
      ITEM CALLPTR;                    # NUMBER OF DBPS                #
      ITEM DEFAULTPIC B;           # TRUE IF NO PIC CLAUSE SPECIFIED   # D2A149 
      ITEM KEYLEVEL;               # CONTAINS LEVEL OF KEY-FIELD ITEM  # D20128A
      ITEM LINENUM C(10);          # TEMPORARY STORAGE AREA FOR NBRLINE#
      ITEM NUMCALLS;                   # NUMBER OF DBP CALLS           #
      ITEM PICFLAG I = UNSPECIFIED;    # FLAG TO USE DEFAULT PIC SIZE  #
      ITEM PICLENGTH; 
      ITEM UNIT;                   # UNIT NUMBER FOR PACK              # DL3A042
          ITEM RECNULL;                                                 000730
       ITEM PRIOR;
         ITEM  ADNT;
       ITEM SYNONYMPTR; 
       ITEM SAMENAMEPTR;
       ITEM SYNLINK;
       ITEM DOMPTR;                   # DOMINANT ITEM POINTER#
          ITEM EDDNT; 
             ITEM NUMCHARS;                                             000490
           ITEM ADJLEN;                                                 000830
           ITEM ADJPTR;                                                 000840
      ITEM DNTM;  #SAVE DNT FOR MULT REC# 
       ITEM DNT;
       ITEM LASTDNT;                  # LOCATION OF PRIOR DNT ENTRY#
       ITEM EQUALNAME;
      ITEM MODE;             #GETS 0,1,5 OR 6 FOR PF MODE PARAMETER.   #
       ITEM NAMELOC;
           ITEM NBRRC;
       ITEM K;
      ITEM LFNTAB; ITEM AREATAB;
           ITEM SGN = 0;
           ITEM PNTLOC; 
           ITEM INTBUF I = 0; 
           ITEM INTCNT I = 0; 
           ITEM FILL C(10) = "AFILLER   ";
           ITEM SGNFLG I = 0; 
           ITEM CVARDDL I = 0;
           ITEM VALUEBU I = 0;
           ITEM VALUCNT I = 0;
           ARRAY WORDSAVE [3];
            ITEM WRDSAVE U(0,0,60); 
           ARRAY VALUBUFR [25]; 
            ITEM VALUBUF U(0,0,60); 
           ARRAY VARBUFR [25];
            ITEM VARBUFFER U(0,0,60); 
       ITEM RECDEPEND;
        ITEM NUMWORDS;
       BASED ARRAY DLSYNHASH[511];
        ITEM HASH512    U(0,0,60);
      BASED ARRAY DUMMY;           # DUMMY ARRAY                       # D20134 
            ITEM DUMMYITM;                                               D20134 
       ITEM LASTENTRY;
       ITEM SC; 
       ITEM I;
       ITEM J;
      ITEM EOMALT;
       ITEM EOMITEMTYPE;
       ITEM DISPINT;
       ITEM XDTBRSLT; 
        ITEM ASECFLAG;
        ITEM NUMBWORDS; 
        ITEM FIRSTWORD; 
       ITEM  CLIT;
        ITEM AREADNT; 
       ITEM CURNTLEVEL; 
       ITEM RECSECT;
        ITEM  SAAMFLG;
           ITEM AREAPRECEDES; 
          ITEM  BSIZSPEC;                                               001320
          ITEM  RSIZSPEC;                                               001330
          ITEM  BTYPSPEC;                                               001340
          ITEM  RTYPSPEC;                                               001350
          ITEM  RTYP;                                                   001360
          ITEM  BTYP;                                                   001370
          ITEM RSIZTYP;                                                 001380
          ITEM BSIZTYP;                                                 001390
      ITEM SAMENMLOC;        #DNT FOR SAME NAME # 
      ITEM SAMENMLINK;       #LINK TO SAME NAME#
       ARRAY LITINFO[0];
        BEGIN 
         ITEM TEMPPOINT    U(0,46,12);
         ITEM TEMPLITOPT   U(0,42,5); 
        END 
       BASED ARRAY DNT18[17]; 
        ITEM DNT18WD U(0,0,60); 
       BASED ARRAY ENDOFMEMTABL[0]; 
        BEGIN 
          ITEM EOMTWORD     U(0,0,60);
          ITEM  EOMTYPE     U(0,0,6); 
          ITEM EOMTDUP U(0,6,1);
         ITEM EOMTDUPARE U(0,7,1);
          ITEM  EOMTNEXT    U(0,36,6);
          ITEM  EOMTDNTPTR  U(0,42,18); 
        END 
        BASED ARRAY DATANAMETABL[1:100];
        BEGIN 
          ITEM DNTWORD       U(0,0,60); 
         ITEM ARBUFMULTREC U(0,46,1); 
         ITEM DNTAR U(0,42,9);
         ITEM DNTIN U(0,51,9);
          ITEM DNTSYNLINK   U(0,6,18);
          ITEM DNTITEMTYPE U(0,0,3);
          ITEM DNTNEXT      U(0,24,18); 
          ITEM DNTPRIOR     U(0,42,18); 
             ITEM ARNAMELEN    U(0,0,6)   ; 
             ITEM ARNAME1      C(0,6,9)   ; 
         ITEM ARNAME U(0,0,60); 
          ITEM ARFITPTR     U(0,42,18); 
          ITEM AREANEXT    U(0,24,18);  # WORD[0] USED BY DLBUILD # 
                                        # SET  BY DCSXN           # 
          ITEM RECDESCRADDR  U(0,0,30);   # BOTH USED IN DLBUILD  # 
          ITEM AREALOCS      U(0,30,30);  # BOTH IN WORD[7]       # 
             ITEM ARCOLLATE    C(0,0,10)  ; 
             ITEM ARLOGNM   U(0,0,60);
             ITEM RDITEMTYPE   U(0,0,3)  ; # HASH LINK DESCRIPTOR#
             ITEM RDDATATYPE   U(0,3,3)  ;
             ITEM RDSYNLINK    U(0,6,18) ;
             ITEM RDDOMPTR     U(0,24,18);
             ITEM RDSAMENAME   U(0,42,18);
             ITEM RDLEVEL      U(0,0,6)  ; #NEXT / PRIOR POINTERS # 
             ITEM RDNEXT       U(0,24,18);
             ITEM RDPRIOR      U(0,42,18);
          ITEM RDNAMEPTR    U(0,7,8); 
             ITEM RDNAMELENC   U(0,19,5);                               000530
             ITEM RDOCCURSR    U(0,0,1)  ; # ATTRIBUTES # 
             ITEM RDOCCURS     U(0,1,1)  ;
             ITEM RDPOINTAORV  U(0,2,1)  ;
             ITEM RDPOINTLORR  U(0,3,1)  ;
             ITEM RDPOINTCOUNT U(0,4,5)  ;
             ITEM RDUSAGE      U(0,9,4)  ;
             ITEM RDCLASS      U(0,13,4) ;
           ITEM RDKEYITEM   U(0,17,1);
            ITEM RDSIZE      U(0,18,12);         # PICTURE SIZE        # D2A164 
            ITEM RDNUMINSRTS U(0,30,06);         # NUMBER OF INSERTS   # D2A164 
                ITEM RDSIZEINSRT  U(0,18,7);                            000250
                ITEM RDSIZEXINSRT U(0,25,6);                            000260
             ITEM RDPOSITIOM   U(0,36,18);
             ITEM RDBFP        U(0,54,6) ;
             ITEM RDNULLVAL   U(0,0,3); 
             ITEM RDYCLPTLENW U(0,3,6); 
             ITEM RDYCLPTLENC U(0,9,6); 
             ITEM RDEDPTR U(0,15,4);                                    000970
             ITEM RDDEPEND     U(0,0,1)  ;  # SUBSCRIPT RANGE # 
             ITEM RDINTEGER3   U(0,1,1)  ;
             ITEM RDUNIQNME B(0,5,1);  # FALSE = THERE IS ANOTHER ENTRY#
                                       #        WITH THE SAME NAME IN  #
                                       #        ANOTHER AREA.          #
             ITEM RDVALUE3     U(0,6,18) ;
             ITEM RDVALUE4     U(0,24,18);
             ITEM RDDEPOBJECT  U(0,42,18);
         ITEM RDNAME       U(0,0,60); 
             ITEM RDYCLPTNM   U(0,0,60);
             ITEM RDONCALLPROC C(0,0,7);
             ITEM RDONCALLOPTN U(0,58,1); 
             ITEM RDCALLDATAN  U(0,59,1); 
             ITEM RDONCALLDN2  U(0,24,18);
             ITEM RDONCALLDN1  U(0,42,18);
           ITEM RDEDITMRL   U(0,0,60);
             ITEM RDADJLEN U(0,6,1);   # INDICATES SUBJECT ENTRY NAME  #
                                       # LENGTH IN CHARACTERS IS A MULT#
                                       # ABLE OF TEN.                  #
             ITEM RDSIGN U(0,30,30);
        END 
      BASED ARRAY FIT[0]  S(FITLENGTH); 
*CALL FITCOM
        ARRAY SQUASHBU[1]  S(24); 
            BEGIN 
             ITEM SQBUF      U(0,0,60); 
             ITEM SITEMTYPE    U(0,57,3)     ;
             ITEM SDATATYPE    U(1,57,3)     ;
          ITEM SKEYITEM     U(1,00,1);
             ITEM SITEMSIZE    U(2,42,18)    ;
             ITEM SOCCURS      U(3,00,01)    ;
             ITEM SDEPEND      U(3,01,01)    ;
         ITEM SINTFLG      U(3,2,1);
         ITEM SINTEGER3    U(3,6,18); 
         ITEM SINTEGER4    U(3,24,18);
             ITEM SDEPOBJECT   U(3,42,18)    ;
             ITEM SREDEF       U(4,59,01)    ;
             ITEM SPOINTAORV   U(5,53,01)    ;
             ITEM SPOINTLORR   U(5,54,01)    ;
             ITEM SPOINTCOUNT  U(5,55,05)    ;
             ITEM SJUSTIFIED   U(6,59,01)    ;
             ITEM SSYNCH       U(7,58,02)    ;
             ITEM SBWZ         U(8,59,01)    ;
             ITEM SEDIT        U(9,00,01)    ;
             ITEM SPICTURE     U(9,54,06)    ;
             ITEM SVALUE       U(10,0,1)     ;
            ITEM SEDITMRLLEN U(10,55,5); # LENGTH IN WORDS OF MURAL    # D2A164 
             ITEM SEDITCOUNT   U(11,54,06)   ;
             ITEM SNUMINSERTS  U(11,54,06)   ;
             ITEM SLEVELNUM    U(12,54,06)   ;
             ITEM SSIGNED      U(13,00,01)   ;
             ITEM SCLASS       U(14,56,4)    ;
             ITEM SUSAGE       U(15,56,4)    ;
             ITEM SDOMINANT    U(16,42,18)   ;
             ITEM SSAMENAME    U(17,42,18)   ;
             ITEM SLINENUM     U(18,42,18)   ;
             ITEM SGDDEDD      U(19,54,6)    ;
             ITEM SLENGTH      U(20,54,6)    ;
             ITEM SEOMPTR      U(21,42,18)   ;
             ITEM SONCALLPROCN C(22,0,7); 
             ITEM SONCALLOPTIN U(22,58,1);
             ITEM SONCALLDATAN U(22,59,1);
             ITEM SONCALLDN2   U(23,24,18); 
             ITEM SONCALLDN1   U(23,42,18); 
          ITEM  SQNULL  U(19,0,3);
               END
          ITEM  YCLEPTNMLENC; 
          ITEM  YCLEPTNMLENW; 
          ARRAY YCLEPTN[4]; 
            ITEM  YCLEPTNM  U(0,0,60);
       ARRAY AREABUFD[0]; 
        BEGIN 
           ITEM ARBUFASCDSC   U(00,00,01);
           ITEM ARBUFBEF      U(00,01,01);
           ITEM ARBUFAFT      U(00,02,01);
           ITEM ARBUFTRANS    U(00,03,01);
           ITEM ARBUFLOGOPT   U(00,01,03);
           ITEM ARBUFTEMP     U(00,04,01);
           ITEM ARBUFSORT     U(00,05,01);
           ITEM ARBUFDUPS     U(00,06,02);
           ITEM ARBUFCOLLATE  U(00,08,01);
           ITEM ARBUFCLITLEN  U(00,09,06);
           ITEM ARBUFCLITFLG  U(00,15,06);
           ITEM ARBUFCOLLPTR  U(00,15,06);
           ITEM ARBUFLOGPTR   U(00,21,06);
           ITEM ARBUFSDAFL    U(00,27,06);
           ITEM ARBUFSDANPTR  U(00,27,06);
           ITEM ARBUFONCAL    U(00,33,06);
           ITEM ARBUFRECLDEP  U(00,39,01);
           ITEM ARBUFPKEYFLG  U(00,44,01);
           ITEM ARBUFMIPFLG   U(00,45,01);
           ITEM ARBUFCLITLW   U(00,49,06);
           ITEM ARBUFDDLINFO  U(00,00,60);
        END 
          ITEM ARSDAPROCN U;
       ARRAY AREABUFN[3]; 
        ITEM ARBUFNAME    U(0,0,60)    ;
        ITEM ALOGCNT; 
        ARRAY ALOGFILE[14]; 
           BEGIN ITEM 
              ALOGNM U(0,00,60),
              ALOGWD U(0,00,54),
              ALOGCD U(0,54,06);
           END
  
      ARRAY ARBUFONCALL [0:DFNUMDBPS];           # ON CALL DBPS        #
            BEGIN 
            ITEM ARBUFONCWORD    U(00,00,WL);    # WORD IN ARRAY       #
            ITEM ARBUFONCNAME    U(00,00,NL);    # DBP NAME            #
            ITEM ARBUFONCOPTN    U(00,NL,18);    # CALL OPTIONS        #
            ITEM ARBUFONCNEXT    B(00,52,01);    # NEXT FLAG           #
            END 
  
      ARRAY ARBUFONCTYPE [0:0];                  # TYPE OF CALL        #
            BEGIN 
            ITEM ARBUFCWORD      U(00,00,WL);    # TYPE WORD           #
            ITEM ARBUFONOPT      U(00,NL,18);    # CALL OPTIONS        #
            ITEM ARBUFONDISP     B(00,49,01);    # DISPLAY             #
            ITEM ARBUFONMTCH     B(00,50,01);    # MATCH               #
            ITEM ARBUFONMISM     B(00,51,01);    # MISMATCH            #
            ITEM ARBUFONOPEN     B(00,53,01);    # OPEN                #
            ITEM ARBUFONCLSE     B(00,54,01);    #CLOSE                #
            ITEM ARBUFONRETR     B(00,55,01);    # RETRIEVAL           #
            ITEM ARBUFONUPDT     B(00,56,01);    # UPDATE              #
            ITEM ARBUFONSRCH     B(00,57,01);    # SEARCH              #
            END 
  
       ARRAY AREABUFC[25];
        ITEM ARBUFCLIT    U(0,0,60)   ; 
           BASED ARRAY SCHEMABLOCK[5];
         BEGIN
        ITEM SCHEMAWORD   U(0,0,60);
        ITEM SCHEMANAME   U(0,0,60);
         ITEM SCHEMADDL21 B(0,0,1); #FLAG FOR DDL2.1# 
         ITEM SCHEMALIBFG B(0,1,1); #TRUE IF HAS LIBRARY FILE#
        ITEM SCH; 
         END
      ARRAY FITWORK[0]  S(FITLENGTH); 
           ITEM FITWRK      U(0,0,60);
      ITEM ARISPF B;         #FLAG FOR AREA IS PF                      #
      ITEM PFCNT;            #FDB COUNTER                              #
      ITEM PWCNT;            #PF PARAMER PW KEY WORD                   #
      ARRAY PFFLAG[0];
         BEGIN
         ITEM PFFGWORD U(0,0,60); 
         ITEM IDFG B(0,0,1);
         ITEM CYFG B(0,1,1);
         ITEM SNFG B(0,2,1);
         ITEM UNFG B(0,3,1);
         ITEM  MFG B(0,4,1);
         ITEM PNFG B(0,5,1);
         ITEM RFG B(0,6,1);                      # R IS FLAG           # DL3A042
         ITEM ARFG B(0,31,1);#FLAG FOR AREA FILE                       #
         ITEM LBFG B(0,30,1); #FLAG FOR LIBRARY FILE                   #
         ITEM INFG B(0,32,1);#FLAG FOR INDEX FILE                      #
         ITEM LGFG B(0,33,1); #FLAG FOR LOG FILE                       #
         END
      ARRAY AREAFILE[14]; 
         BEGIN
         ITEM AREANM U(0,0,60); 
         ITEM ARLFN U(0,0,42);
         ITEM ARPV  U(0,0,54);
         ITEM ARKW  U(0,54,6);
         END
       ARRAY INDEXFILE[14]; 
         BEGIN
         ITEM INDEXNM U(0,0,60);
         ITEM INLFN U(0,0,42);
         ITEM INPV  U(0,0,54);
         ITEM INKW  U(0,54,6);
         END
      BASED ARRAY LIBFILE[0]; 
         BEGIN
         ITEM LIBNM U(0,0,60);
         ITEM LIBLFN U(0,0,42); 
         ITEM LBPV U(0,0,54); 
         ITEM LBKW U(0,54,6); 
         END
      ARRAY LFN[1:192]; 
         ITEM LFNAME U(0,0,54); 
         SWITCH SUBJUMP 
         ONEBEND, 
          ONEBENE,
                , 
                , 
                , 
                , 
         XADBLK1, 
         XADBLK2, 
         XADBLK3, 
          XADBLK4,
         XADRECN, 
         XADREC1, 
         XADREC2, 
         XADREC3, 
                , 
         XAFT   , 
                , 
         XANAME , 
         XASAAM , 
         XASAAMT, 
         XASC   , 
                , 
         XASET  , 
         XATEMP , 
         XBEF   , 
         XBSIZ  ,                                                       000120
         XBTEN  , 
         XBTFL  , 
         XBTFN  , 
         XBTIN  , 
         XBTYP  ,                                                       000140
                , 
         XCLIT  ,                                                       000160
         XCLNUP , 
         XCOB   , 
         XDATPD , 
         XDDCK  , 
         XDDOC1 , 
         XDDOC2 , 
         XDDOC3 , 
         XDDPC1 , 
         XDDUS1 , 
         XDDUS2 , 
         XDDUS3 , 
         XDDUS4 , 
         XDDUS5 , 
         XDDUS6 , 
         XDDUS7 , 
         XDDUS8 , 
         XDD1   , 
         XDD2   , 
         XDD4   , 
         XDD6   , 
         XDESC  , 
                , 
         XDUPFST, 
         XDUPLST, 
         XDUPNOT, 
         XFLIM  , 
         XFORT  , 
                , 
         XINDBL , 
         XINDEX,
         XINDLV , 
         XINDPD , 
         XINIT  , 
         XINITA , 
         XINITR , 
         XINITS , 
          XLACT,
        XLALTDUP, 
        XLALTFRST,
        XLALTINDX,
        XLALTNAM, 
         XLCALC , 
        XLCKDUP,
          XLCKFO   ,
         XLCKPKY, 
         XLDIR  , 
         XLIT8  , 
         XLNAM  , 
         XLOGNM , 
         XLOGRC , 
         XLOGSET  ,                                                     000180
         XLOGTST  ,                                                     000190
         XLOLD, 
         XLSEQ  , 
         XLSORT , 
               ,
         XNUMBL , 
             XNXTPRC    ,          # SET FLAG FOR NEXT ON CALL CLAUSE  #
             XONCALL    ,          # PROCESS ON CALL OPTIONS           #
             XONCHK     ,          # CHECK AT LEAST ONE OPTION GIVEN   #
             XONTYPS    ,          # CHECK ON CALL TYPES               #
         XPFCY, 
         XPFEND,
         XPFID, 
         XPFLIBNM,
         XPFM,
         XPFNAM,
         XPFPW, 
         XPFPWN,
         XPFPWS,
             XPFR,                 # STORE PF R PARAMETER IN FDB       # DL3A042
         XPFSN, 
         XPRNTNM, 
                , 
         XRCNM1 , 
                , 
                , 
                , 
                , 
                , 
                , 
                , 
         XRNAME , 
                , 
                , 
         XRSIZ  ,                                                       000210
         XRTC   , 
         XRTCW  , 
         XRTFL  , 
         XRTRM  , 
         XRTTC  , 
         XRTU   , 
         XRTYP  ,                                                       000230
         XRTZB  , 
                , 
         XSDAPRC, 
         XSETEMK,                  # PROCESS NON-IMBEDDED KEYS         #
         XSNAME , 
        XTRAN  ,
         XTSTTYP  ,                                                     000250
        YCLEPT  ; 
  
  
      XREF ITEM DIAGDL;            # FWA OF DIAGNOSTIC ROUTINE         #
          XREF PROC QUDRTN1;       # LOAD AND EXECUTE OVERLAY (3,2)    #016110
          XREF PROC STD$START;     # ENTRY POINT IN CTLSTD WHICH       #016120
                                   # STARTS SYNTAX ANALYSIS            #016130
          XREF ITEM SWITCHVCTR;    # SEMANTIC VECTOR JUMP              #016140
                                                                        016150
          XREF BEGIN
               ITEM RELFLAG B;
               ITEM DDLDIAG;
               ITEM SYNTBL; 
               ITEM SYNTBLE;
               ITEM LBLPTR; 
               ITEM LBLPTRS;
               ITEM LEXWD;
               ITEM LEXWORDS; 
               ITEM LEXICO; 
               ITEM LEXICON;
               PROC DDLINIT;
               END
     CONTROL EJECT;                                                     016170
#**********************************************************************#016180
#                                                                      #016190
#         E X E C U T A B L E   C O D E   F O R   Q D L S Y N          #016200
#                                                                      #016210
#**********************************************************************#016220
*IF DEF,DEBUG 
         XREF ITEM TRACE; XREF ITEM TRACEM; 
         TRACE=LOC(TRACEM); 
*ENDIF
  
  
          DDLDIAG = LOC(DIAGDL);
          SYNTBL=LOC(SYNTBLE);
          LBLPTR=LOC(LBLPTRS);
          LEXWD=LOC(LEXWORDS);
          LEXICO=LOC(LEXICON);
          DDLINIT;
          SWITCHVCTR = LOC(SUBJUMP);  # SEMANTIC VECTOR JUMP           #016240
          STD$START;                  # START SYNTAX ANALYSIS          #016250
                                                                         D2A149 
                                                                         D2A149 
      PROC DCKPRE;           # CHECK FOR GROUP OR ELEMENTARY ITEM      # D2A149 
                                                                         D2A149 
      BEGIN                                                              D2A149 
      LINENUM == NBRLINE;     # LINENUM = NEXT LINE NO. (NEW LINE)     #
                              # NBRLINE = CURRENT LINE NO.             #
                              # ISSUE DIAG. WITH CORRECT LINE NO.      #
      IF SLEVELNUM[SQ] NQ 1                  # IF NOT RECORD           # D2A149 
      THEN BEGIN                                                         D2A149 
           SDATATYPE[SQ] = DDITEM;           # ITEM                    # D2A149 
           IF CURNTLEVEL LQ SLEVELNUM[SQ]                                D2A149 
           THEN BEGIN 
                SITEMTYPE[SQ] = ELEMENTARY;  # ELEMENTARY ITEM         #
                IF  SPICTURE[SQ] NQ SPECIFIED 
                THEN BEGIN
                     DIAGNOS = D149;         # NO PICTURE SPECIFIED    #
                     DIAGS; 
                     END
                END 
           ELSE BEGIN                                                    D2A149 
                SITEMTYPE[SQ] = GROUP;       # GROUP ITEM              # D2A149 
                SITEMSIZE[SQ] = 0;                                       D2A149 
                IF SPICTURE[SQ] EQ SPECIFIED                             D2A149 
                THEN BEGIN                                               D2A149 
                     IF DEFAULTPIC                                       D2A149 
                     THEN SEDITMRLLEN[SQ] = 0;                           D2A149 
                     ELSE BEGIN                                          D2A149 
                          DIAGNOS = D173;    # NO PIC SPECIFICATION    # D2A149 
                          DIAGS;             # ALLOWED FOR GROUP ITEM  # D2A149 
                          END                                            D2A149 
                     END                                                 D2A149 
                END                                                      D2A149 
           END                                                           D2A149 
      LINENUM == NBRLINE;     # STORE NEXT LINE NO. BACK TO NBRLINE    #
      DEFAULTPIC = FALSE;                                                D2A149 
      RETURN;                                                            D2A149 
      END                    # END OF PROC DCKPRE                      # D2A149 
                                                                         D2A149 
                                                                         D2A149 
  
       PROC  GETDOM;
  
        BEGIN 
        PRIOR = LASTDNT;
        IF SDATATYPE[SQ] EQ RECORDESCR OR 
           SDATATYPE[SQ] EQ RECORDONCALL THEN 
         BEGIN
           DOMPTR = DNT - AREADNT;
        RETURN; 
        END 
  
       NEXTDOM: 
  
        IF RDLEVEL[PRIOR+1] EQ SLEVELNUM[SQ] THEN 
         BEGIN
         DOMPTR = RDDOMPTR[PRIOR] + (DNT - PRIOR) ; 
         RETURN;
         END
        IF RDLEVEL[PRIOR+1] LS SLEVELNUM[SQ] THEN 
         BEGIN
         DOMPTR = DNT - PRIOR;
         RETURN;
         END
          PRIOR = PRIOR - RDDOMPTR[PRIOR];
            IF LOC(RDDOMPTR[PRIOR]) LS DNTBASE THEN RETURN; 
           GOTO NEXTDOM;
        END 
  
        PROC GETSYN;
  
        BEGIN 
        ITEM SAMENAMELINK;   #TEMPORARY CELL FOR SAME-NAME LINK.       #
  
        SYNLINK  =  HASH512[HRSLT]; 
  
       STARTCHAIN:  
         SAMENAMELINK = SYNLINK;   #SAVE HEAD OF SAME-NAME CHAIN.      #
  
      #   SEARCH FOR THE END OF THE SYNONYM CHAIN AND/OR   #
      #                             SAME NAME CHAIN        #
       SAMECHAIN: 
  
         EQUALNAME = 0; 
        NAMELOC = SYNLINK + RDNAMEPTR[SYNLINK+1]; 
          FOR I = 0 STEP 1 UNTIL NUMWDS WRDSAVE[0] - 1 DO 
         IF RDNAME[NAMELOC + I] EQ WRDSAVE[I] THEN
          EQUALNAME = EQUALNAME + 1;
         IF EQUALNAME NQ NUMWDS RDNAME[NAMELOC] THEN BEGIN
          EQUALNAME = 0;
          GOTO SYNCHAIN;
        END 
      # IF SAME-NAME ITEM IS IN ANOTHER AREA, RIPPLE THRU SAME-NAME    #
      # CHAIN MARKING ALL ENTRIES.                                     #
         IF SYNLINK LS AREADNT THEN    #SAME-NAME ITEM IS IN OTHER AREA#
          BEGIN    # SAME NAME CHAIN IS IN ANOTHER AREA.               #
          FOR I = 0 WHILE SAMENAMELINK NQ 0 DO
            BEGIN 
            RDUNIQNME[SAMENAMELINK+3] = FALSE;   #MARK EACH ENTRY.     #
            SAMENAMELINK = RDSAMENAME[SAMENAMELINK];  #LINK TO NEXT.   #
            END 
           RDUNIQNME[DNT+3] = FALSE; # SET THEUNIQUE NAME FLAG IN THE  #
                   # CURRENT ENTRY TO INDICATE THAT THERE IS AN ENTRY  #
                   # WITH THE SAME NAME IN ANOTHER AREA.               #
          END 
      IF SAMENMLINK EQ 0 THEN  #SAVE SAME NAME LINKAGE# 
         SAMENMLINK=SYNLINK;
         IF RDSAMENAME[SYNLINK] EQ NONE THEN
          BEGIN 
          SAMENAMEPTR         = DNT;
            RETURN;                                                     000120
          END 
         SYNLINK = RDSAMENAME[SYNLINK]; 
         GOTO SAMECHAIN;
  
       SYNCHAIN:  
  
        IF RDSYNLINK[SYNLINK] EQ NONE THEN
         BEGIN
         SYNONYMPTR         = DNT;
         RETURN;
         END
        SYNLINK = RDSYNLINK[SYNLINK]; 
        GOTO STARTCHAIN;
        END 
  
                                                                         D20134 
      PROC PRINTNAME(NAME,LENGTH);                                       D20134 
                                                                         D20134 
      BEGIN                                                              D20134 
      ARRAY NAME;                                                        D20134 
            ITEM NEXWRD;                                                 D20134 
      ITEM LENGTH;           # LENTGH OF NAME IN CHARACTERS            # D20134 
                                                                         D20134 
      ARRAY ERRBUF [3];                                                  D20134 
            BEGIN                                                        D20134 
            ITEM ERRWORD U(0,0,WL);                                      D20134 
            ITEM ERRCHAR C(0,0,WC) = ["  ********"];                     D20134 
            END                                                          D20134 
      FOR I = 1 STEP 1 UNTIL 3 DO                                        D20134 
          ERRCHAR[I] = "          ";   # BLANK ERRBUF                  # D20134 
      FOR I = 0 STEP 1 UNTIL (LENGTH / 10 - 1) DO                        D20134 
          ERRWORD[I+1] = NEXWRD[I];                                      D20134 
      DDLPRNT(ERRBUF,LENGTH);      # PRINT NAME                        # D20134 
      END                              # END OF PROC PRINTNAME         # D20134 
                                                                         D20134 
       ALLOVER:     #DNT OVERFLOW#
  
        DIAGNOSTIC = 140; 
        DIAGS;
  
  
  
       ONEBEND: 
      IF ENDCOMP EQ 1 THEN   #SYNTAX ERROR                             #
            BEGIN 
      DDLSU = (DNTBASE + DNT - EOMNDX + 63) / 64 * 64;  # ROUND UP     #
              ABRT4;
            END 
  
           QUDRTN1; 
  
  ONEBENE:  
           RELFLAG=TRUE;
      IF  NEXLENG EQ 8 AND B<0,48>NEXWRD[0] EQ O"0411261123111716"
         THEN STDNO;
      DIAGNOS=066;
      DIAGS;
          STDNO;
       PROC STOREVALUE; 
  
        BEGIN 
        IF SGNFLG NQ 0 THEN GOTO STRVSGN; 
           FOR J = 0 STEP 1 UNTIL NUMWDS CURNWD[0] - 1 DO               000420
         BEGIN
          B<0,54> VALUBUF[J] = B<6,54> CURNWD[J]; 
          B<54,6> VALUBUF[J] = B<0,6>  CURNWD[J+1]; 
           VARBUFFER[J] = VALUBUF[J]; 
         END
        RETURN; 
       STRVSGN: 
        VALUBUF[0] = CURNWD[0]; 
        IF SGN LS 0 THEN B<0,6> VALUBUF[0] = O"46"; #NEGATIVE SIGN# 
                    ELSE B<0,6> VALUBUF[0] = O"45"; #POSITIVE SIGN# 
         VARBUFFER[J] = VALUBUF[J]; 
        VALUEBU = WORDLEN + VALUEBU + 1;
        CVARDDL = VALUEBU;
          FOR I = 0 STEP 1 UNTIL WORDLEN - 1 DO 
        BEGIN VALUBUF[I] = CURNWD[I]; 
           VARBUFFER[I] = CURNWD[I];
        END 
        RETURN; 
        END 
  
       PROC SQUASHPUT;
  
        BEGIN 
         DNTNDX = DNT;
        RDUNIQNME[DNT+3] = TRUE; # INITIALIZE THE UNIQUE NAME FLAG.    #
         HASH(LOC(WRDSAVE[0])); 
        IF HASH512[HRSLT] EQ 0 THEN 
          BEGIN 
          HASH512[HRSLT] = DNT; 
          GOTO SQUASHPUT1;
          END 
        SYNONYMPTR = 0; 
        SAMENAMEPTR = 0;
      SAMENMLINK=0; 
        GETSYN; 
          IF RDSAMENAME[SYNLINK] EQ 0 THEN                              002140
          RDSAMENAME[SYNLINK] = SAMENAMEPTR;                            000780
     #   PROTECT AGAINST INADVERTANT ZERO OUT OF SAME CHAIN   #         002150
     #   IF THE SEARCH DID NOT RESULT IN A SAME NAME          #         002160
          IF RDSYNLINK[SYNLINK] EQ 0 THEN                               002170
          RDSYNLINK[SYNLINK] = SYNONYMPTR;                              000800
      #    PRESERVE EXISTENT SYN CHAIN            #                     002180
  
       SQUASHPUT1:  
  
        DOMPTR = 0; 
        GETDOM; 
      IF SUSAGE[SQ] EQ UNSPECIFIED                                       D2A149 
      THEN BEGIN                                                         D2A149 
#         USAGE AND CLASS MUST BE THE SAME AS THE DOMINANT ITEM          D2A149 
          IF THAT IS SPECIFIED.                                          D2A149 
#                                                                        D2A149 
           J = DNT - DOMPTR;                                             D2A149 
           IF RDLEVEL[J+1] GR 1 AND    # NOT A RECORD ENTRY            # D2A149 
              RDUSAGE[J+2] NQ 0                                          D2A149 
           THEN BEGIN                                                    D2A149 
                SUSAGE[SQ] = RDUSAGE[J+2];                               D2A149 
                RDSIZE[J+2] = 0;                                         D2A149 
                END                                                      D2A149 
           END                                                           D2A149 
        RDDOMPTR[DNT] = DOMPTR; 
        RDITEMTYPE[DNT] = SITEMTYPE[SQ];
        RDDATATYPE[DNT] = SDATATYPE[SQ];
        DNT = DNT+1;
         RDNAMELENC[DNT] = NUMCHARS;                                    000550
           ADJPTR = DNT + 2;                                            000690
        IF SDATATYPE[SQ] EQ  RECORDONLY THEN GOTO SQUASHPUTR; 
        IF  SDATATYPE[SQ] EQ RECORDONCALL THEN  GOTO  SQUASHPUTR; 
        RDLEVEL[DNT]   = SLEVELNUM[SQ]; 
              EDDNT = DNT;                                              000990
    RDNEXT[DNT] = 3 + SOCCURS[SQ] + SEDITMRLLEN[SQ] + NUMWDS WRDSAVE[0] 000250
                        + YCLEPTNMLENW; 
           IF DDLCOMP NQ 7 THEN                                         000600
             RDNEXT[DNT] = RDNEXT[DNT] + 1 ;
        RDPRIOR[DNT]   = DNT - LASTDNT - 1; 
          RDNAMEPTR[DNT] = 3 + SOCCURS[SQ] + SEDITMRLLEN[SQ];           000290
          IF DDLCOMP NQ 7 THEN
             RDNAMEPTR[DNT] = RDNAMEPTR[DNT] + 1; 
        DNT = DNT + 1;
         I = (DNT-2) - DOMPTR;
              IF RDDATATYPE[I] LS 7 THEN                                000460
              BEGIN 
                RDSIGN[DNT+1] = SSIGNED[SQ];
           RDOCCURS[DNT] = RDOCCURSR[I+2];                              000610
              END 
         RDOCCURSR[DNT]   = SOCCURS[SQ];
        RDPOINTAORV[DNT]   = SPOINTAORV[SQ];
        RDPOINTLORR[DNT]   = SPOINTLORR[SQ];
        RDPOINTCOUNT[DNT]   = SPOINTCOUNT[SQ];
          IF SUSAGE[SQ] LQ 1 AND                                        000590
                SCLASS[SQ] EQ 2 THEN                                    000310
                RDUSAGE[DNT] = 2;                                       000320
              ELSE                                                      000330
        RDUSAGE[DNT]   = SUSAGE[SQ];
        RDCLASS[DNT]   = SCLASS[SQ];
            IF SUSAGE[SQ] LQ 1 AND                                      000120
             SCLASS[SQ] EQ 6 THEN                                       000130
               BEGIN                                                    000140
                 RDUSAGE[DNT] = 2;                                      000150
               END                                                      000160
      IF (RDUSAGE[DNT] GR DFDISPLAY       # IF USAGE GR DISPLAY        #
         AND RDUSAGE[DNT] NQ DFLOGICAL)   # AND USAGE NOT LOGICAL      #
         AND (RDCLASS[DNT] NQ DFNUMERIC   # AND CLASS NOT NUMERIC      #
         AND RDCLASS[DNT] NQ DFNMERICED)  # AND CLASS NOT NUMERIC EDIT #
      THEN BEGIN
           LINENUM == NBRLINE;         # GET PREVIOUS LINE NUMBER      #
           DIAGNOS = D144;             # NON NUMERIC NOT ALLOWED       #
           DIAGS;                      # DIAGNOSTIC ROUTINE            #
           NBRLINE == LINENUM;         # RESTORE THE CURRENT LINE NO.  #
           END
      RDKEYITEM[DNT] = SKEYITEM[SQ];   # KEY FLAG                      #
      RDNUMINSRTS[DNT] = SNUMINSERTS[SQ];                                D2A164 
      IF  RDCLASS[DNT] LQ 5 AND                  # ALPHA-NUMERIC EDITED# D2A164 
      RDCLASS[DNT] NQ 4 AND                                              D2A164A
          RDCLASS[DNT] NQ 2                                              D2A164 
      THEN RDSIZE[DNT] = SITEMSIZE[SQ];                                  D2A164 
              ELSE                                                      000160
               BEGIN                                                    000170
                 RDSIZEINSRT[DNT] = SITEMSIZE[SQ];                      000180
                 RDSIZEXINSRT[DNT] = SITEMSIZE[SQ] - SNUMINSERTS[SQ];   000190
               END                                                      000200
           IF RDUSAGE[DNT] LQ 2 AND DDLCOMP EQ 7 THEN                   000330
           RDSIZE[DNT] = SITEMSIZE[SQ];                                 000340
          DNT = DNT + 1;
          IF DDLCOMP NQ 7 THEN                                          000120
            BEGIN                                                       000130
              DNT = DNT + 1;                                            000140
                RDNULLVAL[DNT] = SQNULL[SQ];                            000150
             END                                                        000160
          IF SOCCURS[SQ] GR 0 THEN                                      000170
            BEGIN                                                       000180
        RDDEPEND[DNT]   = SDEPEND[SQ];
        RDINTEGER3[DNT]   = SINTFLG[SQ];
        RDVALUE3[DNT]   = SINTEGER3[SQ];
        RDVALUE4[DNT]   = SINTEGER4[SQ];
        RDDEPOBJECT[DNT]   = SDEPOBJECT[SQ];
           DNT = DNT+1; 
            END                                                         000200
          IF SEDITMRLLEN[0] NQ 0 THEN 
            BEGIN 
      FOR I = 0 STEP 1 UNTIL SEDITMRLLEN[SQ] - 1 DO                      D2A164 
          RDEDITMRL[DNT+I] = PICTURWORD[I];                              D2A164 
           RDEDPTR[EDDNT] = DNT - EDDNT + 1;                            000570
            DNT = DNT + SEDITMRLLEN[SQ];
            END 
  
       SQUASHPUT2:  
  
          FOR I = 0 STEP 1 UNTIL NUMWDS WRDSAVE[0] - 1 DO 
         RDNAME [DNT+I] = WRDSAVE[I]; 
      IF EQUALNAME NQ 0 AND RDNAME[DNT] NQ "AFILLER   " THEN
         BEGIN               #SAME NAME EXITS#
         FOR I=0 STEP 1 WHILE SAMENMLINK LQ DNT AND 
         RDSAMENAME[SAMENMLINK] NQ 0 DO 
            BEGIN 
            IF SAMENMLINK GQ AREADNT THEN #WITHIN SAME AREA#
               BEGIN
               IF DNT-4-RDDOMPTR[DNT-4] EQ  #POINTING TO SAME DOMINANT# 
                  SAMENMLINK - RDDOMPTR[SAMENMLINK] OR                   D20134 
                  SAMENMLINK EQ DNT - 4 - RDDOMPTR[DNT-4]                D20134 
                THEN BEGIN                                               D20134 
                  P<DUMMY> = LOC(RDNAME[DNT]);                           D20134 
                  K = (B<0,6>DUMMYITM[0] + 1) * 10;  # LENGTH OF NAME  # D20134 
                  B<0,6>DUMMYITM[0] = O"55";   # BLANK IT OUT          # D20134 
                  PRINTNAME(DUMMY,K);  # PRINT DUPLICATE NAME          # D20134 
                  B<0,6>DUMMYITM[0] = K / 10 - 1;    # RESTORE LENGTH  # D20134 
                  DIAGNOS = D102;  # DATA NAME NOT UNIQUE              # D20134 
                  DIAGS;       #DOMINANT ITEM                   # 
                  SAMENMLINK=DNT+1; #FORCE LOOP END#
                  END 
               SAMENMLINK = RDSAMENAME[SAMENMLINK];  # LINK TO NEXT    # D20134 
               END
               ELSE 
               SAMENMLINK=RDSAMENAME[SAMENMLINK]; #LINK TO NEXT SAME #
                                                  #NAME              #
            END 
         END
      EQUALNAME=0;
           IF DDLCOMP NQ 7 THEN                                         000710
             BEGIN                                                      000720
               IF NUMCHARS EQ 10 OR NUMCHARS EQ 20 OR NUMCHARS EQ 30    000730
              THEN                                                      000740
               BEGIN                                                    000750
           RDADJLEN[ADJPTR] = 1;                                        000840
               END                                                      000780
            END                                                         000790
        LASTDNT = DNTNDX; 
             IF YCLEPTNMLENW NQ 0  THEN 
               BEGIN
                DNT = DNT + NUMWDS WRDSAVE[0];
                FOR I = 0  STEP 1 UNTIL YCLEPTNMLENW-1 DO 
                  RDYCLPTNM[DNT+I]  = YCLEPTNM[I];
                DNTNDX  = DNT + YCLEPTNMLENW; 
                DNT     = DNT + YCLEPTNMLENW; 
              END 
               ELSE 
                  BEGIN 
        DNTNDX = DNT + NUMWDS WRDSAVE[0]; 
         DNT = DNT + NUMWDS WRDSAVE[0]; 
         END
          ENDDNT = DNT; 
         IF DNTBASE + DNT GQ DOWNBOT + EOMNDX THEN GOTO ALLOVER;
                                # EOMNDX IS NEGATIVE# 
        RETURN; 
  
       SQUASHPUTR:  
  
        RDLEVEL[DNT] = 1; 
           ADJLEN = 0;                                                  000810
          IF DDLCOMP NQ 7 THEN
            BEGIN 
             RDNAMEPTR[DNT] = 4;
              RDNEXT[DNT] = 4 + NUMWDS WRDSAVE[0];
          RDNULLVAL[DNT+3] = RECNULL;                                   000750
             RDNULLVAL[DNT+3] = SQNULL[SQ]; 
             RDYCLPTLENW[DNT+3] = YCLEPTNMLENW; 
             RDYCLPTLENC[DNT+3] = YCLEPTNMLENC; 
          DNT = DNT + 1;
            END 
           ELSE 
             BEGIN
         RDNAMEPTR[DNT] = 3;
          RDNEXT[DNT] = 3 + NUMWDS WRDSAVE[0];
             END
  
        RDPRIOR[DNT] = DNT - LASTDNT - 1; 
        DNT = DNT + 1;
           DNTWORD[DNT] = 0;  #  TO CONTAIN THE SIZE OF THE RECORD# 
           DNT = DNT +1;
        GOTO SQUASHPUT2;
        END 
  
  
       PROC SETEOM; 
  
        BEGIN 
      EOMALT = EOMNDX;
         EOMTYPE[EOMNDX] = EOMITEMTYPE; 
         NUMWORDS = NUMWDS CURNWD[0]; 
         EOMTNEXT[EOMNDX] = NUMWORDS + 1; 
           IF   EOMITEMTYPE EQ 3 THEN 
          EOMTDNTPTR[EOMNDX] = DNT; 
           ELSE 
           BEGIN
       EOMTDNTPTR[EOMNDX] = DNT + 4 + SOCCURS[SQ] + NUMWDS WRDSAVE[0] 
                     + SEDITMRLLEN [SQ] + YCLEPTNMLENW; 
          IF DDLCOMP NQ 7 THEN
             EOMTDNTPTR[EOMNDX] = EOMTDNTPTR[EOMNDX] + 1 ;
          END 
           IF DNT EQ 1 THEN 
           EOMTDNTPTR[EOMNDX] = 1;
         EOMNDX = EOMNDX - 1; 
          FOR I = 0 STEP 1 UNTIL NUMWORDS - 1 DO
          BEGIN 
         EOMTWORD[EOMNDX-I] = CURNWD[I];
          END 
           EOMNDX = EOMNDX - NUMWORDS;
         RETURN;
        END 
                                                                         D20134 
      PROC XDTB;             # CONVERT DISPLAY CODE TO BINARY          # D20134 
                                                                         D20134 
      BEGIN                                                              D20134 
      XDTBRSLT = 0;                                                      D20134 
      FOR I = 60 - (INTCNT * 6) STEP 6 UNTIL 54 DO                       D20134 
          XDTBRSLT = XDTBRSLT * 10 + (B<I,6>DISPINT - O"33");            D20134 
      RETURN;                                                            D20134 
      END                    # END OF PROC XDTB                        # D20134 
                                                                         D20134 
  
                                                                         TESTFL 
                                                                         TESTFL 
                                                                         TESTFL 
      PROC TESTFL(ENDADDR); 
  
      ITEM ENDADDR; 
                                                                         TESTFL 
#         ENSURE THAT ADNT STAYS WITHIN THE FIELD LENGTH               # TESTFL 
#                                                                      # TESTFL 
#         IF THE ADNT IS WITHIN FL RETURN NORMALLY                     # TESTFL 
#         OTHERWISE ABRT1 IS CALLED TO ABORT THE RUN                   # TESTFL 
#                                                                      # TESTFL 
                                                                         TESTFL 
      BEGIN                                                              TESTFL 
      IF (DNTBASE + ENDADDR) GQ DDLMEM
      THEN ABRT1;            # OUTSIDE FL                              # TESTFL 
      RETURN;                # NORMAL EXIT                             # TESTFL 
      END                    # END OF TESTFL                           # TESTFL 
                                                                         TESTFL 
                                                                         TESTFL 
          CONTROL EJECT;
  
      PROC ZEROBUF(BUFFER,NWORDS);     # ZERO OUT A BUFFER AREA        #
  
      BEGIN 
      BASED ARRAY BUFFER[0];           # BUFFER TO BE ZEROED OUT       #
           ITEM WORD    U(00,00,WL);   # WORD TO BE ZEROED OUT         #
  
      ITEM NWORDS;                     # NUMBER OF WORDS TO ZERO OUT   #
  
      FOR I = 0 STEP 1 UNTIL NWORDS - 1 DO
          WORD[I] = 0;
      END                              # END OF ZEROBUF                #
  
      CONTROL EJECT;
       XADBLK1: 
  
        IF CHARCNT GR 6 THEN GOTO XADBLK1ERR; 
        INTCNT = CHARCNT; 
        DISPINT = B<6,INTCNT * 6> CURNWD[0];
        IF DISPINT GR MAXOF262142 THEN GOTO XADBLK1ERR; 
        XDTB; 
        FITMBL[0] = XDTBRSLT; 
         SADNO; 
  
       XADBLK1ERR:  
  
        DIAGNOS = 167;
        DIAGS;
           FITMBL[0]=5120;
         SADNO; 
  
XADBLK2:                           # BLOCK CONTAINS RECORDS            # D2A158 
                                                                         D2A158 
      BLOCKFLAG = TRUE;                                                  D2A158 
      BSIZTYP = FIXEDNUMBER;       # K TYPE BLOCKS                     # D2A158 
      FITRB[0] = FITMBL[0];                                              D2A158 
      STDNO;                                                             D2A158 
                                                                         D2A158 
  
       XADBLK3: 
  
          BSIZTYP = CHARCOUNT;        #C#                               001170
         SADNO; 
       XADBLK4:                                                         001190
          BSIZTYP = EXACTNUMBER;      #E#                               001200
          SADNO;                                                        001220
       XADRECN: 
  
         EOMITEMTYPE  = O"15";
         FITLP[0] = EOMNDX; 
         SETEOM;
         ARBUFRECLDEP[0] = SPECIFIED; 
         SADNO; 
  
       XADREC1: 
  
        IF CHARCNT GR 6 THEN GOTO XADREC1ERR; 
        INTCNT = CHARCNT; 
        DISPINT = B<6,INTCNT * 6> CURNWD[0];
          RSIZTYP = FIXLENRT;                                           001240
        IF DISPINT GR MAXOF262142 THEN
         BEGIN
           DIAGNOS = 152; 
           DIAGS; 
           FITMNR[0]=5120;
           FITMRL[0]=5120;
         SADNO; 
         END
        XDTB; 
        FITMNR[0] = XDTBRSLT;                                           MINREC11
        FITMRL[0] = XDTBRSLT; 
         SADNO; 
                                                                        MINREC-4
       XADREC2:                                                         MINREC-5
                                                                        MINREC-6
        IF CHARCNT GR 6 THEN GOTO XADREC1ERR; 
        INTCNT = CHARCNT; 
        DISPINT = B<6,INTCNT * 6> CURNWD[0];
          RSIZTYP = FIXLENRT;                                           001260
        IF DISPINT GR MAXOF262142 THEN
         BEGIN
           DIAGNOS = 152; 
           DIAGS; 
           FITMRL[0]=5120;
         SADNO; 
         END
        XDTB; 
        FITMRL[0] = XDTBRSLT; 
         SADNO; 
  
       XADREC1ERR:  
  
        DIAGNOS = 151;
        DIAGS;
           FITMNR[0]=5120;
           FITMRL[0]=5120;
  
       XADREC3: 
  
       RECDEPEND      =  SPECIFIED; 
          RSIZTYP =DCHARCOUNT;                                          001300
         SADNO; 
  
       XADREC4: 
  
        FITRMK[0] = RECORDMARK; 
         SADNO; 
  
       XAFT:  
  
        ARBUFAFT[0] = SPECIFIED;
         SADNO; 
  
       XANAME:  
      AREATAB=AREATAB+1;
      IF AREATAB GR 64 THEN 
         BEGIN
         DIAGNOS=208; 
         DIAGS; 
         END
        PFNVALID;            #CHECK NAME IS LEGAL PFN. #
                             #CHARS                                    #
      FOR I=0 STEP 1 UNTIL 14 DO
         BEGIN
         AREANM[I]=0; 
         INDEXNM[I]=0;
         END
      PFFGWORD[0]=0;
  
          FOR I = 0 STEP 1 UNTIL WORDLEN - 1 DO 
         ARBUFNAME[I] = CURNWD[I];
          NUMANMS = NUMANMS + 1;
          LOFANMS = LOFANMS + WORDLEN;
           NBRRC=0; 
      GETCURNAM(CWRD);
      CHKLFN; 
      ARISPF=FALSE; 
         SADNO; 
       XASAAM:  
         SAAMFLG = SPECIFIED; 
         SADNO; 
       XASAAMT: 
         IF SAAMFLG EQ SPECIFIED THEN 
             BEGIN
              SAAMFLG = UNSPECIFIED;
           SADYES;
             END
         SADNO; 
  
       XASC:  
  
        ARBUFASCDSC[0] = ASCEND;
         SADNO; 
  
       XASEC: 
  
        IF ASECFLAG EQ SPECIFIED THEN      SADYES;
         SADNO; 
  
       XASET: 
  
            AREAPRECEDES = 1; 
           IF NUMANMS GR 1 THEN 
             BEGIN
             CURNTLEVEL = 1 ; 
             DCKPRE;
             SQUASHPUT; 
           AREANEXT[DNT] = DNT+1; 
           DNTITEMTYPE[DNT] = 7;
           DNT = DNT + 1; 
           AREANEXT[AREADNT] = DNT; 
           END
        J = 1;
          AREADNT  = DNT; 
        ASECFLAG = SPECIFIED; 
         HASH(LOC(ARBUFNAME[0])); 
        IF HASH512[HRSLT]  NQ  0 THEN 
         BEGIN
          SYNLINK  = HASH512[HRSLT];
          FOR I = SYNLINK  WHILE DNTSYNLINK[SYNLINK] NQ 0 DO
          SYNLINK   =   DNTSYNLINK[SYNLINK];
        DNTSYNLINK[SYNLINK] =     DNT;
         END
           ELSE HASH512[HRSLT] = DNT; 
          ADNT = DNT; 
          TESTFL(ADNT + 5); 
          DNTITEMTYPE[ADNT]  = AREATYPE;
          ARNAME[ADNT+2] = ARBUFNAME[0];
          ARNAME[ADNT+3] = ARBUFNAME[1];
          ARNAME[ADNT+4] = ARBUFNAME[2];
          ARNAME[ADNT+5] = ARBUFNAME[3];
         IF FITFO[0] EQ SIS THEN
          FITPM[0] = FALSE; 
      IF BLOCKFLAG THEN FITMBL[0] = FITMBL[0] * FITMRL[0];               D2A130 
          P<DNT18> = LOC(FIT);
          TESTFL(ADNT + 8 + FITLENGTH); 
          FOR I = 0  STEP 1 UNTIL FITLENGTH - 1 DO
            DNTWORD[ADNT+8+I] = DNT18WD[I]; 
      P<FIT> = LOC(DNTWORD[ADNT+8]);  # KLUDGE NEEDED TO PROCESS EMK   #
      ADNT = ADNT + 8 +FITLENGTH; 
           IF ARBUFCLITFLG[0] NQ SPECIFIED THEN GOTO XASET2;            000120
      ARBUFCOLLPTR[0]  = FITLENGTH + 8; 
           TESTFL(ADNT + CLIT + 1); 
           FOR I = 0 STEP 1 UNTIL CLIT DO                               000360
             DNTWORD[ADNT+I] = ARBUFCLIT[I];                            000370
           ADNT = ADNT + CLIT + 1;                                      000380
             CLIT = 0;                                                  000390
        XASET2: 
         IF ARBUFLOGPTR[0] EQ SPECIFIED THEN
           BEGIN
            ARBUFLOGPTR[0] = ADNT - DNT;
            TESTFL(ADNT + ALOGCNT + 1); 
            FOR I = 0 STEP 1 UNTIL ALOGCNT DO 
               DNTWORD[ADNT + I] = ALOGNM[I]; 
            ADNT = ADNT + ALOGCNT + 1;
           END
         IF ARBUFSDAFL[0] EQ SPECIFIED THEN 
           BEGIN
            DNTWORD[ADNT] = ARSDAPROCN; 
            ARBUFSDAFL[0] = ADNT - DNT; 
            ADNT = ADNT + 1;
            TESTFL(ADNT); 
           END
      IF NUMCALLS GR 0
      THEN BEGIN
           ARBUFONCAL = ADNT - DNT;              # POINTER TO DBP LIST #
           FOR I = 0 STEP 1 UNTIL DFNUMDBPS DO
                BEGIN                            # MOVE DBPS TO DNT    #
                IF ARBUFONCNAME[I] NQ 0 
                THEN BEGIN
                     DNTWORD[ADNT] = ARBUFONCWORD[I]; 
                     ADNT = ADNT + 1; 
                     TESTFL(ADNT);
                     END
                END 
           END
           FOR I=0 STEP 1 UNTIL 14 DO 
               BEGIN
               IF I EQ 0 AND AREANM[I] EQ 0 THEN GOTO AREAFDBEND; 
               DNTWORD[ADNT+I]=AREANM[I]; 
               IF ARPV[I] EQ "         " THEN GOTO AREAFDBEND;
               END
       AREAFDBEND:  
           IF I NQ 0 THEN 
               BEGIN
               DNTAR[DNT]=ADNT-DNT; 
               ADNT=ADNT+I+1; 
               END
           FOR I=0 STEP 1 UNTIL 14 DO 
               BEGIN
               IF I EQ 0 AND INDEXNM[I] EQ 0 THEN GOTO INDEXFDBEND; 
               DNTWORD[ADNT+I]=INDEXNM[I];
               IF INPV[I] EQ "         " THEN GOTO INDEXFDBEND; 
               END
       INDEXFDBEND: 
           IF I NQ 0 THEN 
               BEGIN
               DNTIN[DNT]=ADNT-DNT; 
               ADNT=ADNT+I+1; 
               END
         DNTWORD[DNT+6] = ARBUFDDLINFO[0];
      DNTM=DNT+6; 
         DNTNEXT[DNT+1]= ADNT - DNT;
         DNTPRIOR[DNT+1] = LASTENTRY; 
         LASTENTRY = DNT; 
         DNT = ADNT;
         IF DNTBASE + DNT GQ DOWNBOT + EOMNDX THEN GOTO ALLOVER;
                                # EOMNDX IS NEGATIVE# 
  
         SADNO; 
  
       XATEMP:  
  
        ARBUFTEMP[0] = SPECIFIED; 
           NBRRC=0; 
         SADNO; 
  
       XBEF:  
  
        ARBUFBEF[0] = SPECIFIED;
         SADNO; 
  
        XBSIZ:                                                          001410
           BSIZSPEC = SPECIFIED;                                        001420
           SADNO;                                                       001430
       XBTEN: 
  
          BTYP = EXACTNUMBER;                                           001630
          SADNO;
  
       XBTFL: 
  
          BTYP = CHARCOUNT;                                             001590
         SADNO; 
  
       XBTFN: 
  
          BTYP = FIXEDNUMBER;                                           001610
         SADNO; 
  
       XBTIN: 
  
          BTYP = INTERNAL;                                              001570
         SADNO; 
  
        XBTYP:                                                          001490
           BTYPSPEC = SPECIFIED;                                        001500
           SADNO;                                                       001510
       XCLIT: 
  
        ARBUFCLITFLG[0] = SPECIFIED;
          FOR I = 0 STEP 1 UNTIL WORDLEN - 1 DO 
         BEGIN
         ARBUFCLIT[I] = VALUBUF[I]; 
         CLIT  = I; 
         END
        ARBUFCLITLEN[0] = CHARCNT;
           ARBUFCLITLW[0] = WORDLEN;                                    000300
         SADNO; 
  
       XCLNUP:  
  
            IF ASECFLAG NQ SPECIFIED THEN 
             BEGIN
               DIAGNOS = 105; 
               DIAGS; 
               SADNO; 
             END
        CURNTLEVEL = 1; 
        DCKPRE; 
        SQUASHPUT;
          AREANEXT[AREADNT] = DNT;
         DNTITEMTYPE[DNT] = 7;
         ENDDNT = DNT;
         SADNO; 
  
       XCOB:  
  
        ARBUFCOLLATE[0] = COBOL;
         SADNO; 
  
                                                                         D2A130 
XDATPD:                            # DATA-PADDING IS                   # D2A130 
                                                                         D2A130 
      IF FITFO[0] EQ SIS OR FITFO[0] EQ SAK                              D2A130 
      THEN BEGIN                                                         D2A130 
           IF CHARCNT GR 2                                               D2A130 
           THEN BEGIN                                                    D2A130 
                DIAGNOS = D157;    # ILLEGAL VALUE                     # D2A130 
                DIAGS;                                                   D2A130 
                FITDP[0] = 5;      # 5 ASSUMED                         # D2A130 
                END                                                      D2A130 
           ELSE BEGIN                                                    D2A130 
                DISPINT = B<6,CHARCNT*6>CURNWD[0];                       D2A130 
                INTCNT  = CHARCNT;                                       D2A130 
                XDTB;              # CONVERT TO BINARY                 # D2A130 
                FITDP[0] = XDTBRSLT;                                     D2A130 
                END                                                      D2A130 
           END                                                           D2A130 
      ELSE BEGIN                                                         D2A130 
           DIAGNOS = D115;                                               D2A130 
           DIAGS;                                                        D2A130 
           END                                                           D2A130 
      STDNO;                                                             D2A130 
  
        XDDCK:  
  
      IF PICWORD[0] EQ "-" OR PICWORD[PICLENGTH] EQ "-" 
      OR PICWORD[0] EQ "+" OR PICWORD[PICLENGTH] EQ "+" 
      THEN SSIGNED[SQ]=1; 
         IF SPICTURE[SQ] EQ SPECIFIED THEN
             PICTUR(LOC(SQBUF[SQ]));
      IF  SUSAGE[SQ] EQ DFLOGICAL      # IF USAGE IS LOGICAL           #
      THEN SCLASS[SQ] = 4;         # CLASS MUST BE LOGICAL ALSO        # D2A164 
           IF  SUSAGE[SQ] EQ DFDISPLAY # IF USAGE IS DISPLAY           #
           THEN GOTO CHECKFILLER; 
  
        IF SUSAGE[SQ] EQ UNSPECIFIED THEN GOTO CHECKFILLER; 
        XDDCKCOMP:  
          IF SCLASS[SQ] EQ UNSPECIFIED THEN 
            BEGIN 
             SCLASS[SQ] = DFNUMERIC;   # CLASS IS NUMERIC              #
             GOTO CHECKFILLER;
            END 
        CHECKFILLER:  
  
         IF SDATATYPE[SQ] NQ  FILLR  THEN      SADNO; 
         IF SOCCURS[SQ] EQ SPECIFIED THEN 
           BEGIN
            DIAGNOS = 174;
            DIAGS;
            SOCCURS[SQ] = UNSPECIFIED;
           END
         SADNO; 
  
                                                                         D2A149 
XRSIZ:                             # RECORD CONTAINS CLAUSE            # D2A149 
      RSIZSPEC = SPECIFIED;                                              D2A149 
      STDNO;                                                             D2A149 
                                                                         D2A149 
       XDDOC1:  
  
        IF SGN NQ 0 THEN GOTO OC1ERR1;
        IF CHARCNT GR 6 THEN GOTO OC1ERR1;
        INTCNT = CHARCNT; 
        DISPINT = B<6,CHARCNT*6> CURNWD[0]; 
        IF DISPINT GR O"354135343735"      # MAX DECIMAL 262142 # 
          THEN GOTO OC1ERR2;
  
       XDDOC11: 
  
        XDTB; 
        SOCCURS[SQ] = 1;
        SINTEGER4[SQ] = XDTBRSLT; 
         SADNO; 
  
       OC1ERR1: 
  
        DIAGNOSTIC = 143; 
        DIAGS;
         SADNO; 
  
       OC1ERR2: 
  
        DIAGNOSTIC = 145; 
        DIAGS;
        INTCNT = 2; 
        GOTO XDDOC11; 
  
       XDDOC2:  
  
        IF SGN NQ 0      THEN GOTO OC2ERR1; 
        IF CHARCNT GR 6 THEN GOTO OC2ERR1;
        INTCNT = CHARCNT; 
        DISPINT = B<6,INTCNT * 6> CURNWD[0];
        IF DISPINT GR O"354135343735" THEN GOTO OC2ERR2;
  
       XDDOC22: 
  
        XDTB; 
        SOCCURS[SQ] = 1;
        SINTEGER3[SQ] = SINTEGER4[SQ];
        SINTEGER4[SQ] = XDTBRSLT; 
        SINTFLG[SQ] = 1;
         SADNO; 
  
       OC2ERR1: 
  
        DIAGNOSTIC = 143; 
        DIAGS;
         SADNO; 
  
       OC2ERR2: 
  
        DIAGNOSTIC = 145; 
        DIAGS;
        INTCNT = 2; 
        GOTO XDDOC22; 
                                                                         D2A160 
XDDOC3:                            # OCCURS DEPENDING ON               # D2A160 
                                                                         D2A160 
      IF RSIZTYP EQ DCHARCOUNT OR                                        D2A160 
         RTYP EQ DCHARCOUNT                                              D2A160 
      THEN BEGIN                                                         D2A160 
           DIAGNOS = D189;                                               D2A160 
           DIAGS;                                                        D2A160 
           END                                                           D2A160 
      IF RTYPSPEC EQ SPECIFIED AND                                       D2A160 
         RTYP NQ TRAILERCOUNT                                            D2A160 
      THEN BEGIN                                                         D2A160 
           DIAGNOS = D190;                                               D2A160 
           DIAGS;                                                        D2A160 
           END                                                           D2A160 
      FITRT[0] = TRAILERCOUNT;                                           D2A160 
      SDEPEND[SQ] = SPECIFIED;                                           D2A160 
      EOMITEMTYPE = 3;             # CREATE EOMT ENTRY                 # D2A160 
      SEOMPTR[SQ] = EOMNDX;                                              D2A160 
      SDEPOBJECT[SQ] = EOMNDX;                                           D2A160 
      SETEOM;                                                            D2A160 
      STDNO;                                                             D2A160 
                                                                         D2A160 
  
XDDPC1:                            # MOVE PIC FROM NEXWRD TO PICWORD   # D2A164 
                                                                         D2A164 
      DEFAULTPIC = FALSE;                                                D2A149 
      SEDITCOUNT[SQ] = NEXLENG;                                          D2A164 
      PICFLAG = SPECIFIED;         #PICTURE HAS BEEN SPECIFIED         # D2A164 
      PICLENGTH = NEXLENG - 1;     # PICTOURE LENGTH                   # D2A164 
      IF  PICLENGTH GR 30                                                D2A164 
      THEN BEGIN                                                         D2A164 
           DIAGNOS = D008;         # PICTURE GREATER THAN 30 CHARS     # D2A164 
           DIAGS;                                                        D2A164 
           END                                                           D2A164 
      ELSE BEGIN                                                         D2A164 
           J = 0;                                                        D2A164 
           K = 0;                                                        D2A164 
           FOR  I = 0 STEP 1 UNTIL PICLENGTH DO                          D2A164 
                BEGIN                                                    D2A164 
                PICWORD[I] = B<J*6,6>NEXWRD[K];                          D2A164 
                IF J EQ 9                                                D2A164 
                THEN BEGIN         # END OF WORD REACHED               # D2A164 
                     J = 0;        # RESET BYTE OFFSET                 # D2A164 
                     K = K + 1;    # INCREMENT WORD OFFSET             # D2A164 
                     END                                                 D2A164 
                ELSE J = J + 1;    # INCREMENT BYTE OFFSET             # D2A164 
                END                                                      D2A164 
           PICWORD[I] = O"55";     # END OF PICTURE                    # D2A164 
           SPICTURE[SQ] = 1;                                             D2A164 
           END                                                           D2A164 
      STDNO;                                                             D2A164 
  
  
XDDUS1: 
      SUSAGE[SQ] = DFDISPLAY;      # USAGE IS DISPLAY                  #
      IF  PICFLAG EQ UNSPECIFIED
      THEN BEGIN                   # SET DEFAULT VALUE TO X(10)        #
           SPICTURE[SQ] = 1;
           SEDITCOUNT[SQ] = 6;
           PICLENGTH = 5; 
           PICWORD[0] = O"30";     # X                                 #
           PICWORD[1] = O"51";     # LEFT PAREN                        #
           PICWORD[2] = O"34";     # 1                                 #
           PICWORD[3] = O"33";     # 0                                 #
           PICWORD[4] = O"52";     # RIGHT PAREN                       #
           PICWORD[5] = O"55";     # BLANK                             #
           DEFAULTPIC = TRUE;      # NO PICTURE SPECIFIED              #
           END
      PICFLAG = UNSPECIFIED;       # CLEAR PICFLAG                     #
      STDNO;
  
  
XDDUS2: 
      SUSAGE[SQ] = DFCOMP;         # COMP/COMPUTATIONAL                #
      IF  PICFLAG EQ UNSPECIFIED
      THEN BEGIN                   # SET DEFAULT VALUE TO 9(10)        #
           SPICTURE[SQ] = 1;
           SEDITCOUNT[SQ] = 6;
           PICLENGTH = 5; 
           PICWORD[0] = O"44";     # 9                                 #
           PICWORD[1] = O"51";     # LEFT PAREN                        #
           PICWORD[2] = O"34";     # 1                                 #
           PICWORD[3] = O"33";     # 0                                 #
           PICWORD[4] = O"52";     # RIGHT PAREN                       #
           PICWORD[5] = O"55";     # BLANK                             #
           DEFAULTPIC = TRUE;      # NO PICTURE SPECIFIED              #
           END
      PICFLAG = UNSPECIFIED;       # CLEAR PICFLAG                     #
      STDNO;
  
  
XDDUS3: 
      SUSAGE[SQ] = DFCOMP1;        # USAGE IS COMP-1                   #
  
  
XDDUS3A:  
      IF PICFLAG EQ UNSPECIFIED 
      THEN
        BEGIN                      # SET DEFAULT VALUE TO -9(18)       #
        SPICTURE[SQ] = 1; 
        SEDITCOUNT[SQ] = 7; 
        PICLENGTH = 6;
        PICWORD[0] = O"46";        # MINUS                             #
        PICWORD[1] = O"44";        # 9                                 #
        PICWORD[2] = O"51";        # LEFT PAREN                        #
        PICWORD[3] = O"34";        # 1                                 #
        PICWORD[4] = O"43";        # 8                                 #
        PICWORD[5] = O"52";        # RIGHT PAREN                       #
        PICWORD[6] = O"55";        # BLANK                             #
        DEFAULTPIC = TRUE;         # NO PICTURE SPECIFIED              #
        END 
      PICFLAG = UNSPECIFIED;       # RESET PICFLAG                     #
      STDNO;
  
  
XDDUS4: 
      SUSAGE[SQ] = DFCOMP2;        # COMP-2, SINGLE PRECISION          #
  
  
XDDUS4A:                           # SET DEFAULT VALUE TO -9(12).99    #
      IF PICFLAG EQ UNSPECIFIED 
      THEN
        BEGIN 
        SPICTURE[SQ] = 1; 
        SEDITCOUNT[SQ] = 10;
        PICLENGTH = 9;
        PICWORD[0] = O"46";        # MINUS                             #
        PICWORD[1] = O"44";        # 9                                 #
        PICWORD[2] = O"51";        # LEFT PAREN                        #
        PICWORD[3] = O"34";        # 1                                 #
        PICWORD[4] = O"35";        # 2                                 #
        PICWORD[5] = O"52";        # RIGHT PAREN                       #
        PICWORD[6] = O"57";        # PERIOD                            #
        PICWORD[7] = O"44";        # 9                                 #
        PICWORD[8] = O"44";        # 9                                 #
        PICWORD[9] = O"55";        # BLANK                             #
        DEFAULTPIC = TRUE;         # NO PICTURE SPECIFIED              #
        END 
      PICFLAG = UNSPECIFIED;       # CLEAR PICFLAG                     #
      STDNO;
  
  
XDDUS5: 
      SUSAGE[SQ] = DFINTEGER;      # USAGE IS INTEGER                  #
      GOTO XDDUS3A;                # SET DEFAULT VALUES                #
  
  
XDDUS6: 
      SUSAGE[SQ] = DFLOGICAL;      # USAGE IS LOGICAL                  #
      IF  PICFLAG EQ UNSPECIFIED
      THEN BEGIN                   # SET DEFAULT VALUE TO X            #
           SPICTURE[SQ] = 1;
           SEDITCOUNT[SQ] = 2;
           PICLENGTH = 1; 
           PICWORD[0] = O"30";     # X                                 #
           PICWORD[1] = O"55";     # BLANK                             #
           DEFAULTPIC = TRUE;      # NO PICTURE SPECIFIED              #
           END
      PICFLAG = UNSPECIFIED;       # CLEAR PICFLAG                     #
      STDNO;
  
  
XDDUS7: 
      SUSAGE[SQ] = DFCOMPLEX;      # USAGE IS COMPLEX                  #
      GOTO XDDUS4A;                # SET DEFAULT VALUE TO -9(12).99    #
  
  
XDDUS8: 
      SUSAGE[SQ] = DFDOUBLE;       # COMP-1 SIZE > 14, DOUBLE PRECISION#
      IF  PICFLAG EQ UNSPECIFIED
      THEN BEGIN                   # SET DEFAULT VALUE TO -9(12).9(6)  #
           SPICTURE[SQ] = 1;
           SEDITCOUNT[SQ] = 12; 
           PICLENGTH = 11;
           PICWORD[0] = O"46";     # MINUS                             #
           PICWORD[1] = O"44";     # 9                                 #
           PICWORD[2] = O"51";     # LEFT PAREN                        #
           PICWORD[3] = O"34";     # 1                                 #
           PICWORD[4] = O"35";     # 2                                 #
           PICWORD[5] = O"52";     # RIGHT PAREN                       #
           PICWORD[6] = O"57";     # PERIOD                            #
           PICWORD[7] = O"44";     # 9                                 #
           PICWORD[8] = O"51";     # LEFT PAREN                        #
           PICWORD[9] = O"41";     # 6                                 #
           PICWORD[10] = O"52";    # RIGHT PAREN                       #
           PICWORD[11] = O"55";    # BLANK                             #
           DEFAULTPIC = TRUE;      # NO PICTURE SPECIFIED              #
           END
      PICFLAG = UNSPECIFIED;       # RESET PICFLAG                     #
      STDNO;
  
  
XDD1:                              # STORE ITEM NAME                   #
  
      DISPINT = INTBUF;                                                  D20128A
      XDTB;                        # CONVERT LEVEL TO BINARY           # D20128A
      IF XDTBRSLT LS 2 OR                                                D20128A
         XDTBRSLT GR 49                                                  D20128A
      THEN STDNO;                  # INVALID LEVEL NUMBER              # D20128A
      IF NOT FITEMK[0]                                                   D20128A
      THEN BEGIN                   # IF WORKING ON KEY-FIELD           # D20128A
           IF KEYLEVEL EQ 0                                              D20128A
           THEN KEYLEVEL = XDTBRSLT;   # FIRST TIME THROUGH            # D20128A
           ELSE BEGIN                                                    D20128A
                IF KEYLEVEL GQ XDTBRSLT                                  D20128A
                THEN BEGIN                                               D20128A
                     DIAGNOS = D218;                                     D20128A
                     DIAGS;                                              D20128A
                     END                                                 D20128A
                END                                                      D20128A
           END                                                           D20128A
      CURNTLEVEL = XDTBRSLT;                                             D20128A
      DCKPRE;                      # CHECK FOR GROUP/ELEMENTARY ITEM   # D20128A
      SQUASHPUT;                   # SQUASH PREVIOUS ENTRY INTO DNT    # D20128A
      ZEROBUF(LOC(SQBUF[SQ]),24);  # ZERO OUT SQUASH BUFFER            # D20128A
      SLEVELNUM[SQ] = CURNTLEVEL;                                        D20128A
      STDYES;                                                            D20128A
                                                                         D20128A
  
XDD2:                        # INITIAL CHECK ON CURRENT LEVEL NUMBER   # D2A149 
                                                                         D2A149 
      PICFLAG = UNSPECIFIED;       # CLEAR PIC FLAG                    # D2A149 
  
        IF SGN NQ 0 THEN GOTO XDD2ERR;
        IF CHARCNT EQ 1 THEN GOTO ONEINT; 
        IF CHARCNT EQ 2 THEN GOTO TWOINT; 
        GOTO XDD2ERR; 
  
       ONEINT:  
  
        IF WORDLEN EQ 0 THEN GOTO XDD2ERR;
        INTBUF = B<6,6> CURNWD[0];
        INTCNT = 1; 
         SADYES;
  
       TWOINT:  
  
        IF B<6,12> CURNWD[0] EQ 0 THEN GOTO XDD2ERR;
        INTBUF = B<6,12> CURNWD[0]; 
        INTCNT = 2; 
         SADYES;
  
       XDD2ERR: 
  
        DIAGNOSTIC = 141; 
       DIAGS; 
         SADNO; 
  
       XDD4:  
  
      LINENUM = NBRLINE;           # CURRENT LINE NUMBER               #
        WRDSAVE[0]  = B<3,57> CURNWD[0];
        WRDSAVE[1]  = CURNWD[1];
        WRDSAVE[2]  = CURNWD[2];
        WRDSAVE[3]  = CURNWD[3];
          NUMDNMS = NUMDNMS + 1;
           NUMCHARS = CURLENG;                                          000120
         SADNO; 
  
       XDD6:          # SET FILLER BIT ON#
       SGDDEDD[SQ] = SGDDEDD[SQ] LOR O"000010"; 
        WRDSAVE[0] =FILL; 
        GOTO XDD4;
  
       XDESC: 
  
        ARBUFASCDSC[0] = DESCEND; 
         SADNO; 
  
        XDUPFST:  
          ARBUFDUPS[0] = DUPFIRST;
        FITDKI[0] = TRUE; 
          SADNO;
        XDUPLST:  
          ARBUFDUPS[0] = DUPLAST; 
        FITDKI[0] = TRUE; 
          SADNO;
        XDUPNOT:  
          ARBUFDUPS[0] = DUPNOT;
        FITDKI[0] = FALSE;
          SADNO;
                                                                         D2A130 
                                                                         D2A130 
XFLIM:                             # FILE-LIMIT IS                     # D2A130 
                                                                         D2A130 
      IF FITFO[0] NQ SEQ                                                 D2A130 
      THEN BEGIN                                                         D2A130 
           DISPINT = B<6,CHARCNT*6>CURNWD[0];                            D2A130 
           INTCNT  = CHARCNT;                                            D2A130 
           XDTB;                   # CONVERT DISPLAY CODE TO BINARY    # D2A130 
           FITFLM[0] = XDTBRSLT;                                         D2A130 
           END                                                           D2A130 
      ELSE BEGIN                                                         D2A130 
           DIAGNOS = D106;                                               D2A130 
           DIAGS;                                                        D2A130 
           END                                                           D2A130 
      STDNO;                                                             D2A130 
                                                                         D2A130 
  
       XFORT: 
  
        ARBUFCOLLATE[0] = FORTRAN;
         SADNO; 
  
       XIMPNM:  
  
        B<0,42> FITLFN[0] =  B<6,42> CURNWD[0]; 
         SADNO; 
  
                                                                         D2A130 
XINDBL:                            # INDEX-BLOCK CONTAINS              # D2A130 
                                                                         D2A130 
      IF FITFO[0] EQ SIS                                                 D2A130 
      THEN BEGIN                                                         D2A130 
           DISPINT = B<6,CHARCNT*6>CURNWD[0];                            D2A130 
           INTCNT  = CHARCNT;                                            D2A130 
           XDTB;                                                         D2A130 
           IF XDTBRSLT GR 0 AND XDTBRSLT LS 32767                        D2A130 
           THEN  FITIBL[0] = XDTBRSLT;                                   D2A130 
           ELSE BEGIN                                                    D2A130 
                DIAGNOS = D156;    # INDEX-BLOCK INVALID               # D2A130 
                DIAGS;                                                   D2A130 
                FITIBL[0] = 511;   # 511 USED                          # D2A130 
                END                                                      D2A130 
           END                                                           D2A130 
      ELSE BEGIN                                                         D2A130 
           DIAGNOS = D124;         # INDEX BLOCK FOR NON-IS FILE       # D2A130 
           DIAGS;                                                        D2A130 
           END                                                           D2A130 
      STDNO;                       # RETURN                            # D2A130 
                                                                         D2A130 
  
XINDLV:                            # INDEX LEVEL IS                    # D2A130 
                                                                         D2A130 
      IF FITFO[0] EQ SIS                                                 D2A130 
      THEN BEGIN                                                         D2A130 
           IF CHARCNT GR 2                                               D2A130 
           THEN BEGIN                                                    D2A130 
                DIAGNOS = D153;    # INDEX LEVEL GT 100                # D2A130 
                DIAGS;                                                   D2A130 
                END                                                      D2A130 
           ELSE BEGIN                                                    D2A130 
                DISPINT = B<6,CHARCNT*6>CURNWD[0];                       D2A130 
                INTCNT  = CHARCNT;                                       D2A130 
                XDTB;              # CONVERT TO BINARY                 # D2A130 
                IF XDTBRSLT LQ 0 OR XDTBRSLT GR 64                       D2A130 
                THEN BEGIN                                               D2A130 
                     DIAGNOS = D154; # INDEX-LEVEL INVALID             # D2A130 
                     DIAGS;                                              D2A130 
                     FITNL[0] = 1;   # 1 ASSUMED                       # D2A130 
                     END                                                 D2A130 
                ELSE FITNL[0] = XDTBRSLT;                                D2A130 
               END                                                       D2A130 
           END                                                           D2A130 
      ELSE BEGIN                                                         D2A130 
           DIAGNOS = D121;         # INDEX LEVEL FOR NON-IS FILE       # D2A130 
           DIAGS;                                                        D2A130 
           END                                                           D2A130 
      STDNO;                       # RETURN                            # D2A130 
  
                                                                         D2A130 
XINDPD:                            # INDEX-PADDING IS                  # D2A130 
                                                                         D2A130 
      IF FITFO[0] EQ SIS                                                 D2A130 
      THEN BEGIN                                                         D2A130 
           DISPINT = B<6,CHARCNT*6>CURNWD[0];                            D2A130 
           INTCNT  = CHARCNT;                                            D2A130 
           XDTB;                   # CONVERT TO BINARY                 # D2A130 
           IF XDTBRSLT GR 99                                             D2A130 
           THEN BEGIN                                                    D2A130 
                DIAGNOS = D150;    # INVALID VALUE                     #
                DIAGS;                                                   D2A130 
                FITIP[0] = 5;      # 5 ASSUMED                         # D2A130 
                END                                                      D2A130 
           ELSE FITIP[0] = XDTBRSLT;                                     D2A130 
           END                                                           D2A130 
      ELSE BEGIN                                                         D2A130 
           DIAGNOS = D120;                                               D2A130 
           DIAGS;                                                        D2A130 
           END                                                           D2A130 
      STDNO;                       # RETURN                            # D2A130 
                                                                         D2A130 
  
XINIT:                             # INITIALIZE INDEXES, ZERO OUT DNT  #
  
      AREATAB = 0;                 # NUMBER OF AREAS                   #
      DNTNDX  = 1;
      EOMNDX  = 0;
      LASTDNT = 1;                 # LAST DNT ENTRY                    #
      LFNTAB  = 1;                 # NUMBER OF LFNS                    #
      DNT     = 1;                 # DNT ENTRY                         #
      DOMPTR  = 0;                 # DOMINANT ITEM POINTER             #
      ENDDNT  = 0;                 # END OF DNT                        #
      LASTENTRY = 1;               # LAST DNT ENTRY                    #
      LOFANMS   = 0;
      AREADNT   = 0;               # DNT ENTRY FOR AREA                #
      AREAPRECEDES = 0; 
      DDLMEM = B<0,30>DDLMEM - 5; 
      NUMANMS = 0;
      NUMDNMS = 0;
      P<DATANAMETABL> = DNTBASE;
      P<DLSYNHASH> = LOC(HASHTBL);
      P<ENDOFMEMTABL> = DDLMEM; 
      ZEROBUF(DNTBASE,DDLMEM-DNTBASE+1);
      ZEROBUF(LOC(HASHTBL),512);
      STDNO;                       # RETURN                            #
  
       XINITA:  
  
         ZEROBUF(LOC(AREABUFN),4);
        ARBUFDDLINFO[0] = 0;
      ZEROBUF(LOC(ARBUFONCALL),7);     # ZERO OUT ON CALL AREA BUFFER  #
         ZEROBUF(LOC(AREABUFC),26); 
        P<FIT>  = LOC(FITWORK); 
         ZEROBUF(LOC(FITWORK),FITLENGTH); 
     FITEMK[0] = TRUE;             # NEW AREA, FITEMK MUST BE SET      #
      FITEFC[0] = 3;               # SET DEFAULT ERROR FILE CONTROL    #
      FITORG[0] = TRUE;            # SET THE DEFAULT ORGANIZATION.     #
      CALLPTR = 0;                     # NUMBER OF DBPS                #
      NUMCALLS = 0;                    # NUMBER OF DBP CALLS           #
      ARBUFCWORD = 0;                  # ON CALL OPTIONS               #
          BSIZSPEC = 0;                                                 001060
          RSIZSPEC = 0;                                                 001070
          RTYPSPEC = 0;                                                 001080
          BTYPSPEC = 0;                                                 001090
          RTYP     = 0;                                                 001100
          BTYP     = 0;                                                 001110
          RSIZTYP  = 0;                                                 001120
          BSIZTYP  = 0;                                                 001130
         FITLT[0] = 2;                                                  000270
         SADNO; 
  
       XINITR:  
  
        CURNTLEVEL = 1; 
         RECNULL = 0;                                                   000710
        IF AREAPRECEDES EQ  1 THEN
           BEGIN
               AREAPRECEDES = 0;
               GOTO XINITR2;
           END
        AREAPRECEDES = 0; 
        DCKPRE; 
        SQUASHPUT;
        XINITR2:  
          SDATATYPE[SQ] = RECORDONLY; 
          SITEMTYPE[SQ] = GROUP;
         ZEROBUF(LOC(SQBUF[SQ]),24);
        SLEVELNUM[SQ] = CURNTLEVEL; 
      NBRRC=NBRRC+1;
      IF NBRRC GR 1 THEN ARBUFMULTREC[DNTM]=1;
         SADNO; 
  
       XINITS:  
  
       P<SCHEMABLOCK>  = LOC(SBLOCK); 
      ZEROBUF(LOC(SBLOCK),9); 
      ZEROBUF(LOC(LIBFDB),15);
      SCHEMADDL21[4]=TRUE;   #UNCONDITIONALLY SET TRUE FOR DDL2.1#
        SC = 0; 
         SADNO; 
  
  XLACT:   #   #
      FITFO[0] =  SAK;
      SADNO;
  XLALTDUP:   #   # 
      EOMTDUP[EOMALT] = 1;
      SADNO;
  XLALTFRST:   #   #
      EOMTDUPARE[EOMALT] = 1; 
      EOMTDUP [EOMALT] = 1; 
      SADNO;
  XLALTINDX:   #   #
      EOMTDUP [EOMALT] = 1; 
      SADNO;
  XLALTNAM:   #   # 
      EOMITEMTYPE = O"14";
      FITKA[0] = EOMNDX;
      SETEOM; 
      EOMTDUP [EOMALT] = 0; 
      EOMTDUPARE [EOMALT] = 0;
      ARBUFMIPFLG [0] = 1;
      SADNO;
  
  XLCKDUP:   #   #
     IF EOMITEMTYPE EQ O"13"  THEN             # PRIMARY KEY CHECK     #
     IF (ARBUFDUPS [0] EQ DUPLAST)  OR  (ARBUFDUPS [0] EQ DUPFIRST) 
     THEN 
       IF(FITFO[0] EQ SIS AND FITORG[0]) OR 
          FITFO[0] EQ SAK OR FITFO[0] EQ SDA THEN 
        SADNO;
      SADYES; 
  
XLCKFO:     #  * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
      IF FITFO [0] EQ SEQ 
        THEN SADNO; 
      SADYES; 
XLCKPKY:  
      IF FITFO [0] NQ SEQ     OR
         ARBUFSORT [0] EQ SPECIFIED 
          THEN
          BEGIN 
            IF ARBUFPKEYFLG [0] NQ SPECIFIED
               THEN 
               BEGIN
               DIAGNOS  =  212; 
               DIAGS; 
               END
          END 
          SADNO;
       XLCALC:  
  
      FITHMB[0] = 5;
        FITFO[0] =  SDA;
         SADNO; 
  
       XLDIR: 
  
        FITFO[0] = SIS; 
         SADNO; 
  
       XLOLD: 
        FITORG[0] = FALSE;
         SADNO; 
  
       XLIT8: 
        IF CHARCNT GR 256 THEN BEGIN
          DIAGNOS    = 147; 
          DIAGS;
          VALUEBU = 0;
          CVARDDL = 0;
         SADNO; 
         END
        VALUEBU = B<41,6> VALUEBU LOR O"17";
        VALUEBU =  B<47,13> VALUEBU LOR B<47,13> CHARCNT; 
        CVARDDL = VALUEBU;
        SGNFLG = 0; 
        STOREVALUE; 
         SADNO; 
  
       XLNAM: 
  
          IF FITFO [0] NQ SEQ      OR 
             ARBUFSORT [0] EQ SPECIFIED 
            THEN
             BEGIN
             IF ARBUFPKEYFLG [0] EQ SPECIFIED 
               THEN 
                BEGIN 
                DIAGNOS  =  211;
                DIAGS;
                SADNO;
                END 
               ELSE 
                BEGIN 
        EOMITEMTYPE =  O"13"; 
        FITKA[0] = EOMNDX;
        SETEOM; 
       ARBUFPKEYFLG [0] = SPECIFIED;
        SADNO;
                END 
             END
            ELSE
             BEGIN
             DIAGNOS  =  213; 
             DIAGS; 
             SADNO; 
             END
  
        XLOGNM: 
      PFNVALID; 
  
         FOR I = 0 STEP 1 UNTIL 14 DO 
              ALOGNM[I] = BINZEROES;
          FOR  I = 0 STEP 1 UNTIL WORDLEN -1 DO 
           ALOGNM[I] = CURNWD[I]; 
           ALOGCNT = WORDLEN; 
          ARBUFLOGPTR[0] = SPECIFIED; 
      PFFGWORD[0] = 0;
      LGFG[0] = TRUE; 
      PWCNT = O"20";
          SADNO;
  
      PROC GETCURNAM(A);
         BEGIN
         ARRAY A[3];
            BEGIN 
            ITEM CWF  U(0,0,60);
            ITEM CWF9 U(0,0,54);
            ITEM CWF1 U(0,54,6);
            END 
         FOR I=0 STEP 1 UNTIL CURLENW-1 DO
            BEGIN 
            CWF9[I]=CWC9[I];
            CWF1[I]=CWC1[I+1];
            END 
         FOR K=0 STEP 6 UNTIL 54 DO 
            IF I GQ 1 THEN
               IF B<K,6>CWF[I-1] EQ " " THEN B<K,6>CWF[I-1]=0;
         END
      PROC INDXPFERR; 
         BEGIN
         DIAGNOS=209; 
         DIAGS; 
         STDNO; 
         END
XINDEX: 
      PFNVALID; 
      GETCURNAM(CWRD);
      CHKLFN; 
      FOR I=0 STEP 1 UNTIL WORDLEN-1 DO 
         INDEXNM[I]=CURNWD[I];
      INLFN[4]=B<0,42>INDEXNM[0]; 
      PFFGWORD[0]=0;
      PFCNT=5;
      PWCNT=16;              # PW KEYWORD PARAMETER IS O"20" #
      INFG[0]=TRUE; 
      STDNO;
XPFCY:  
      IF CYFG[0] THEN 
         BEGIN
         DIAGNOS=205; 
         DIAGS; 
         STDNO; 
         END
      DISPINT=B<6,(CHARCNT*6)>CURNWD[0];
      INTCNT=CHARCNT; 
      XDTB; 
      IF INFG[0] THEN 
         BEGIN
         IF NOT ARISPF THEN INDXPFERR;
         INPV[PFCNT]=XDTBRSLT;
         INKW[PFCNT]=O"03"; 
         END
      IF ARFG[0] THEN 
         BEGIN
         ARPV[PFCNT]=XDTBRSLT;
         ARKW[PFCNT]=O"03"; 
         END
      IF LBFG[0] THEN 
         BEGIN
         B<(54-I),I>LBPV[PFCNT]=XDTBRSLT; 
         LBKW[PFCNT]=O"03"; 
         END
      IF LGFG[0] THEN 
        BEGIN 
        ALOGWD[ALOGCNT] = XDTBRSLT; 
        ALOGCD[ALOGCNT] = O"03";
        ALOGCNT = ALOGCNT + 1;
        END 
      CYFG[0]=TRUE; 
      PFCNT=PFCNT+1;
      STDNO;
XPFEND: 
      IF INFG[0] THEN 
         BEGIN
         INPV[PFCNT]=O"555555555555555555"; 
         INKW[PFCNT]=O"00"; 
         END
      IF ARFG[0] THEN 
         BEGIN
         ARPV[PFCNT]=O"555555555555555555"; 
         ARKW[PFCNT]=O"00"; 
         END
      IF LBFG[0] THEN 
         BEGIN
         LBPV[PFCNT]=O"555555555555555555"; 
         LBKW[PFCNT]=O"00"; 
         END
      STDNO;
                                                                         DL3A045
XPFID:                                      # PROCESS PF ID/UN         # DL3A045
                                                                         DL3A045
      IF  IDFG[0]                                                        DL3A045
      THEN BEGIN                                                         DL3A045
           DIAGNOS = D205;                  # PF PARAMETER INVALID     # DL3A045
           DIAGS;                                                        DL3A045
           STDNO;                                                        DL3A045
           END                                                           DL3A045
      J = CHARCNT * 6;                                                   DL3A045
      B<54-J,J>I = B<6,J>CURNWD[0];         # ID                       # DL3A045
      B<54,6>I = O"14";                     # UN/ID CODE               # DL3A045
      FOR K = 54-J STEP 6 UNTIL 54 DO       # CHECK FOR LEGAL CHARS    # DL3A045
          IF  B<K,6>I GQ O"45"              # NON ALPHA-NUMERIC PRESENT# DL3A045
          THEN BEGIN                                                     DL3A045
               DIAGNOS = D181;              # PF UN/ID INVALID         # DL3A045
               DIAGS;                                                    DL3A045
               END                                                       DL3A045
      IF INFG[0]                            # INDEX FILE               # DL3A045
      THEN BEGIN                                                         DL3A045
           IF  NOT ARISPF                   # AREA MUST BE PERM FILE   # DL3A045
           THEN INDXPFERR;                  # PF PARAMETER ERROR       # DL3A045
           INDEXNM[PFCNT] = I;                                           DL3A045
           END                                                           DL3A045
      IF  ARFG[0]                           # AREA                     # DL3A045
      THEN AREANM[PFCNT] = I;                                            DL3A045
      IF  LBFG[0]                           # LIBRARY FILE             # DL3A045
      THEN LIBNM[PFCNT] = I;                                             DL3A045
      IF  LGFG[0]                           # LOG FILE                 # DL3A045
      THEN BEGIN                                                         DL3A045
           ALOGNM[ALOGCNT] = I;                                          DL3A045
           ALOGCNT = ALOGCNT + 1;           # INCREMENT LOG COUNT      # DL3A045
           END                                                           DL3A045
      PFCNT = PFCNT + 1;                    # INCREMENT PF COUNT       # DL3A045
      IDFG[0] = TRUE;                       # SET ID/UN FLAG           # DL3A045
      STDNO;                                                             DL3A045
                                                                         DL3A045
XPFLIBNM: 
      PFNVALID; 
      GETCURNAM(CWRD);
      CHKLFN; 
      SCHEMALIBFG[4]=TRUE;   #SET FLAG FOR SCHEMA LIBRARY FILE #
      P<LIBFILE>=LOC(LIBFDB); 
      FOR I=0 STEP 1 UNTIL WORDLEN-1 DO LIBNM[I]=CURNWD[I]; 
      LIBLFN[4]=B<0,42>LIBNM[0];
      PFFGWORD[0]=0;
      LBFG[0]=TRUE; 
      PFCNT=5;
      PWCNT=16;              # PW KEYWORD PARAMETER IS O"20" #
      STDNO;
  
  
XPFM:                              # PROCESS PF M = MODE               #
  
      MODE = CURP1; 
      IF MFG[0] THEN
         BEGIN
         DIAGNOS=205; 
         DIAGS; 
         STDNO; 
         END
      IF INFG[0] THEN 
         BEGIN
         IF NOT ARISPF THEN INDXPFERR;
         INPV[PFCNT] = MODE;
         INKW[PFCNT]=O"30"; 
         END
      IF ARFG[0] THEN 
         BEGIN
         ARPV[PFCNT] = MODE;
         ARKW[PFCNT]=O"30"; 
         END
      IF LBFG[0] THEN 
         BEGIN
         LBPV[PFCNT] = MODE;
         LBKW[PFCNT]=O"30"; 
         END
      IF LGFG[0] THEN 
        BEGIN 
         ALOGWD[ALOGCNT] = MODE;
        ALOGCD[ALOGCNT] = O"30";
        ALOGCNT = ALOGCNT + 1;
        END 
      MFG[0]=TRUE;
      PFCNT=PFCNT+1;
      STDNO;
  
XPFNAM: 
      FOR I=0 STEP 1 UNTIL B<0,6>ARBUFNAME[0]-1 DO
         BEGIN
         B<0,54>AREANM[I]=B<6,54>ARBUFNAME[I];
         B<54,6>AREANM[I]=B<0,6>ARBUFNAME[I+1]; 
         END
      FOR K=0 STEP 6 UNTIL 54 DO
      IF I GQ 1 THEN
         IF 
         B<K,6>AREANM[I-1] EQ " " THEN B<K,6>AREANM[I-1]=0; 
      ARLFN[4]=B<0,42>AREANM[0];
      PFFGWORD[0]=0;
      PFCNT=5;
      PWCNT=16;              # PW KEYWORD PARAMETER IS O"20" #
      ARFG[0]=TRUE; 
      ARISPF=TRUE;
      STDNO;
XPFPW:  
      IF PWCNT GR O"24" THEN
         BEGIN
         DIAGNOS=182; 
         DIAGS; 
         STDNO; 
         END
      I=CHARCNT*6;
      IF INFG[0] THEN 
         BEGIN
         IF NOT ARISPF THEN INDXPFERR;
         B<(54-I),I>INPV[PFCNT]=B<6,I>CURNWD[0];
         INKW[PFCNT]=PWCNT; 
         END
      IF ARFG[0] THEN 
         BEGIN
         B<(54-I),I>ARPV[PFCNT]=B<6,I>CURNWD[0];
         ARKW[PFCNT]=PWCNT; 
         END
      IF LBFG[0] THEN 
         BEGIN
         B<(54-I),I>LBPV[PFCNT]=B<6,I>CURNWD[0];
         LBKW[PFCNT]=PWCNT; 
         END
      IF LGFG[0] THEN 
        BEGIN 
        B<(54-I),I>ALOGWD[ALOGCNT] = B<6,I>CURNWD[0]; 
        ALOGCD[ALOGCNT] = PWCNT;
        ALOGCNT = ALOGCNT + 1;
        END 
      PWCNT=PWCNT+1;
      PFCNT=PFCNT+1;
      STDNO;
XPFPWS: 
      IF OSNAME NQ 0 THEN 
         BEGIN
         DIAGNOS=205; 
         DIAGS; 
         STDNO; 
         END
      STDYES; 
XPFPWN: 
      IF OSNAME EQ 0 THEN 
         BEGIN
         DIAGNOS=205; 
         DIAGS; 
         STDNO; 
         END
      STDYES; 
                                                                         DL3A042
XPFR:                              # STORE PF R PARAMETER IN FDB       # DL3A042
                                                                         DL3A042
      IF  RFG[0]                                                         DL3A042
      THEN BEGIN                   # DUPLICATE R PARAMETER             # DL3A042
           DIAGNOS = D205;         # INVALID PF PARAMETER              # DL3A042
           DIAGS;                                                        DL3A042
           STDNO;                                                        DL3A042
           END                                                           DL3A042
      IF  CHARCNT GR 3                                                   DL3A042
          OR CHARCNT LS 2                                                DL3A042
      THEN BEGIN                                                         DL3A042
           DIAGNOS = D148;         # INVALID R PARAMETER               # DL3A042
           DIAGS;                                                        DL3A042
           STDNO;                                                        DL3A042
           END                                                           DL3A042
      UNIT = 0;                                                          DL3A042
      I = 0;                                                             DL3A042
      IF  CHARCNT EQ 3                                                   DL3A042
      THEN UNIT = B<18,6>CURNWD[0] - O"33";      # EXTRACT UNIT NUMBER # DL3A042
           B<0,12>I = B<6,12>CURNWD[0];          # DX                  # DL3A042
           B<12,6>I = UNIT;                      # UNIT NUMBER         # DL3A042
           B<54,6>I = O"41";                     # R PARAMETER CODE    # DL3A042
      IF  INFG[0]                                # INDEX FILE          # DL3A042
      THEN BEGIN                                                         DL3A042
           IF  NOT ARISPF                                                DL3A042
           THEN INDXPFERR;                       # PF PARAMETER ERROR  # DL3A042
           INDEXNM[PFCNT] = I;                                           DL3A042
           END                                                           DL3A042
      IF  ARFG[0]                                # AREA                # DL3A042
      THEN AREANM[PFCNT] = I;                                            DL3A042
      IF LBFG[0]                                 # LIBRARY FILE        # DL3A042
      THEN LIBNM[PFCNT] = I;                                             DL3A042
      PFCNT = PFCNT + 1;                                                 DL3A042
      RFG[0] = TRUE;                             # SET R FLAG          # DL3A042
      STDNO;                                                             DL3A042
                                                                         DL3A042
XPFSN:  
      IF SNFG[0] THEN 
         BEGIN
         DIAGNOS=205; 
         DIAGS; 
         STDNO; 
         END
      I=CHARCNT*6;
      IF INFG[0] THEN 
         BEGIN
         IF NOT ARISPF THEN INDXPFERR;
         B<0,I>INPV[PFCNT]=B<6,I>CURNWD[0]; 
         INKW[PFCNT]=O"40"; 
         END
      IF ARFG[0] THEN 
         BEGIN
         B<0,I>ARPV[PFCNT]=B<6,I>CURNWD[0]; 
         ARKW[PFCNT]=O"40"; 
         END
      IF LBFG[0] THEN 
         BEGIN
         B<0,I>LBPV[PFCNT]=B<6,I>CURNWD[0]; 
         LBKW[PFCNT]=O"40"; 
         END
      IF LGFG[0] THEN 
        BEGIN 
        B<0,I>ALOGWD[ALOGCNT] = B<6,I>CURNWD[0];
        ALOGCD[ALOGCNT] = O"40";
        ALOGCNT = ALOGCNT + 1;
        END 
      PFCNT=PFCNT+1;
      SNFG[0]=TRUE; 
      STDNO;
      # AREA INDEX AND LIBRARY FILES MUST ALL BE UNIQUE # 
      PROC CHKLFN;
      BEGIN 
      FOR I=1 STEP 1 UNTIL LFNTAB DO
         BEGIN
         IF LFNAME[I] EQ CURNWD7[0] THEN
            BEGIN 
            DIAGNOS=207;
            DIAGS;
            RETURN; 
            END 
         END
      LFNAME[LFNTAB]=CURNWD7[0];
      LFNTAB=LFNTAB+1;
      RETURN; 
      END 
# THIS PROC IS TO VERIFY THAT PERMANENT FILE NAMES BEGIN WITH          #
# ALPHABETIC, AND CONTAIN ONLY ALPHANUMERIC CHARACTERS.                #
      PROC PFNVALID;
        BEGIN 
        ITEM LEGALNAME B;    #TRUE IF PFN IS A LEGAL NAME. #
        LEGALNAME = FALSE;   #INITIALIZE.  REMAINS FALSE IF BAD NAME.  #
        IF B<6,6>CURNWD[0] LQ O"32" THEN
          BEGIN 
          LEGALNAME = TRUE;  #FIRST CHAR IS ALPHABETIC. # 
          J = 0;             #INITIALIZE WORD INDEX. #
          K = 12;            #INITIALIZE BIT COUNT. # 
          FOR I = 2 STEP 1 UNTIL CURLENG DO 
            BEGIN            #LOOP THRU REMAINING CHARACTERS OF NAME.  #
            IF B<K,6>CURNWD[J] GR O"44" THEN
              BEGIN 
              LEGALNAME = FALSE;   #ILLEGAL CHARACTER DETECTED. # 
              I = CURLENG;   #CAUSE LOOP TO TERMINATE. #
              END 
            K = K + 6;       #INCREMENT TO NEXT CHARACTER. #
            IF K GR 54 THEN  #OFF END OF WORD. #
              BEGIN 
              K = 0;
              J = J + 1;     #ON TO NEXT WORD. #
              END 
            END #OF LOOP. # 
          IF NOT LEGALNAME THEN 
            BEGIN 
            DIAGNOS = 125;
            DIAGS;
            END 
          END   #OF IF CONDITION. # 
        RETURN; 
        END  #OF PROC LFNVALID. # 
        XLOGRC: 
           SADNO; 
        XLOGSET:  
           IF ARBUFLOGOPT[0] EQ UNSPECIFIED THEN
            ARBUFTRANS[0] =SPECIFIED; 
            SADNO;
            XLOGTST:                                                    000450
           IF ARBUFLOGOPT[0] EQ UNSPECIFIED THEN                        000460
             ARBUFBEF[0] = SPECIFIED;                                   000470
           SADNO;                                                       000480
       XLSEQ: 
  
        FITFO[0] = SEQ; 
         SADNO; 
        XLSORT: 
          ARBUFSORT[0] = SPECIFIED; 
          SADNO;
  
       XLSYM: 
  
        FITKT[0] = SYMBOLIC;
         SADNO; 
  
XONCALL:                               # PROCESS ON CALL OPTIONS       #
  
      IF  NUMCALLS GQ DFNUMDBPS + 1 
      THEN BEGIN
           DIAGNOS = D126;             # MORE THAN 8 ON CALL OPTIONS   #
           DIAGS; 
           STDNO;                      # RETURN                        #
           END
      FOR I = 0 STEP 1 UNTIL CALLPTR DO 
          IF (ARBUFONCOPTN[I] LAN CURP1) NQ 0 
          THEN STDNO;                  # DUPLICATE OPTION CALLS        #
      ARBUFONCOPTN[CALLPTR] = ARBUFONCOPTN[CALLPTR] LOR CURP1;
      ARBUFONOPT = ARBUFONOPT LOR CURP1;
      NUMCALLS = NUMCALLS + 1;         # NUMBER OF ON CALL OPTIONS     #
      STDYES;                          # RETURN                        #
  
  
XONCHK:                                # CHECK THAT AT LEAST ONE CALL  #
                                       #OPTION HAS BEEN SPECIFIED      #
      IF ARBUFONOPT EQ 0
      THEN STDNO;                      # NO OPTIONS                    #
      STDYES;                          # OK                            #
  
  
XONTYPS:                               # CHECK ON CALL TYPES           #
  
      IF ARBUFONSRCH
         AND NOT (ARBUFONOPEN 
                  AND ARBUFONCLSE)
      THEN BEGIN
           DIAGNOS = D214;             # OPEN AND CLOSE PROCEDURES MUST#
           DIAGS;                      # SPECIFIED WITH SEARCH         #
           END
      STDNO;                           # RETURN                        #
  
  
XNXTPRC:                               # INITIALIZE VARIABLES FOR      #
                                       # NEXT ON CALL CLAUSE           #
      ARBUFONCNEXT[CALLPTR] = TRUE;    # DBP FOLLOWS                   #
      CALLPTR = CALLPTR + 1;           # INCREMENT NUMBER OF DBPS      #
      STDNO;                           # RETURN                        #
  
                                                                         D2A130 
                                                                         D2A130 
XNUMBL:                            # NUMBER OF BLOCKS                  # D2A130 
                                                                         D2A130 
      IF FITFO[0] EQ SDA                                                 D2A130 
      THEN BEGIN                                                         D2A130 
           DISPINT = B<6,CHARCNT*6>CURNWD[0];                            D2A130 
           INTCNT  = CHARCNT;                                            D2A130 
           XDTB;                   # DISPLAY TO BINARY                 # D2A130 
           IF XDTBRSLT GR 0 AND XDTBRSLT LQ 16777215                     D2A130 
           THEN FITHMB[0] = XDTBRSLT;                                    D2A130 
           ELSE BEGIN                                                    D2A130 
                DIAGNOS = D138;    # NUMBER OF BLOCKS VALUE ILLEGAL    # D2A130 
                DIAGS;                                                   D2A130 
                END                                                      D2A130 
           END                                                           D2A130 
      ELSE BEGIN                                                         D2A130 
           DIAGNOS = D131;         # NUMBER OF BLOCKS FOR NON-DA FILE  # D2A130 
           DIAGS;                                                        D2A130 
           END                                                           D2A130 
      STDNO;                       # RETURN                            # D2A130 
                                                                         D2A130 
                                                                         D2A130 
                                                                         D20134 
                                                                         D20134 
XPRNTNM:                           # PRINT NAME                        # D20134 
                                                                         D20134 
      NEXLENG = NEXLENG + 11;                                            D20134 
      PRINTNAME(NEXWORD,NEXLENG);                                        D20134 
      STDNO;                                                             D20134 
                                                                         D20134 
  
XRCNM1:                                # STORE DBP NAME                #
  
      IF CHARCNT GR 7 
      THEN BEGIN
           DIAGNOS = D128;             # DBP NAME GREATER THAN 7 CHARS #
           DIAGS; 
           END
      ELSE BEGIN
           I = CHARCNT * 6; 
           B<0,I>ARBUFONCNAME[CALLPTR] = B<6,I>CURNWD[0]; 
           END
      STDNO;                           # RETURN                        #
  
  
XRNAME:                            # STORE RECORD-NAME NAME            #
  
      KEYLEVEL = 0;                                                      D20128A
      IF NOT FITEMK[0] THEN 
         BEGIN
         DIAGNOS = 216;            # RECORD DECLARATION AFTER A KEY    #
         DIAGS;                    # FIELD CLAUSE                      #
         END
  
XRNAME1:  
  
        WRDSAVE[0]  = CURNWD[0];
        WRDSAVE[1]  = CURNWD[1];
        WRDSAVE[2]  = CURNWD[2];
        WRDSAVE[3]  = CURNWD[3];
          NUMDNMS = NUMDNMS + 1;
             NUMCHARS = CURLENG;                                        000510
         SADNO; 
  
       XRSET: 
  
        RECSECT = SPECIFIED;
         SADNO; 
  
       XRTC:  
  
          RTYP = TRAILERCOUNT;                                          001710
         SADNO; 
  
       XRTCW: 
  
          RTYP = CONTROLWORD;                                           001650
         SADNO; 
  
       XRTFL: 
  
          RTYP = FIXLENRT;                                              001730
         SADNO; 
  
       XRTRM: 
  
          RTYP = RECMARK;                                               001750
           FITRMK[0]=RECORDMARK;
         SADNO; 
  
       XRTTC: 
  
          RTYP = DCHARCOUNT;                                            001770
         SADNO; 
  
       XRTYP:                                                           001530
           RTYPSPEC = SPECIFIED;                                        001540
           SADNO;                                                       001550
       XRTU:  
  
          RTYP = UNDEFINED;                                             001790
         SADNO; 
  
       XRTZB: 
  
          RTYP = ZEROBYTE;                                              001810
         SADNO; 
       XSDAPRC: 
          IF CHARCNT GR 7 THEN
            BEGIN 
            DIAGNOS = 123;
            DIAGS;
            SADNO;
            END 
          J = 0;
          K = 6;
          FOR  I = 1 STEP 1 UNTIL CHARCNT  DO 
            BEGIN 
             B<J,6> ARSDAPROCN = B<K,6> CURNWD[0];
             J= J + 6;
             K= K + 6;
            END 
          ARBUFSDAFL[0]= SPECIFIED; 
          SADNO;
  
  
XSETEMK:                           # PROCESS NON-IMBEDDED KEYS         #
      BEGIN 
      IF NOT FITEMK[0] THEN 
         BEGIN
         DIAGNOS = 215;            # MORE THAN ONE KEY-FIELD FOR SAME  #
         DIAGS;                    # AREA                              #
         KEYLEVEL = 0;       # CLEAR KEY LEVEL                         # D20128A
         END
      ELSE
         BEGIN
         IF FITFO[0] EQ SEQ THEN   # KEY-FIELD INVALID WITH SEQUENTIAL #
            BEGIN                  # FILES                             #
            DIAGNOS = 217;
            DIAGS;
            END 
         ELSE FITEMK[0] = FALSE;   # CLEAR EMK FLAG                    #
         END
      GOTO XRNAME1;                # PROCESS AS IF NORMAL RECORD-NAME  #
  
#     ************************************************************     #
      END 
       XSNAME:  
  
          FOR I=0 STEP 1 UNTIL 2 DO                                     000120
         BEGIN
          B<0,54> SCHEMANAME[SC+I] = B<6,54> CURNWD[I]; 
          B<54,6> SCHEMANAME[SC+I] = B<0,6>  CURNWD[I+1]; 
         END
          B<54,6>SCHEMANAME[SC+2] = O"55";                              000140
        SC = SC + NUMWDS CURNWD[0]; 
           FOR I = 0 STEP 1 UNTIL WORDLEN-1 DO
              NAMEIDENT[I] = CURNWD[I]; 
           B<0,6>NAMEIDENT[0] = O"55";
         SADNO; 
  
         XTSTTYP:                                                       000500
          IF RSIZSPEC EQ SPECIFIED AND                                  000510
             RTYPSPEC EQ SPECIFIED THEN                                 000520
           BEGIN                                                        000530
          IF RTYP EQ RSIZTYP THEN                                       000540
             BEGIN                                                      000550
             FITRT[0] = RTYP;                                           000560
             GOTO TSTBTYP;                                              000570
           END                                                          000580
          IF RTYP EQ DCHARCOUNT OR                                      000590
             RSIZTYP EQ DCHARCOUNT THEN                                 000600
           BEGIN                                                        000610
             DIAGNOS = 185;                                             000620
             DIAGS;                                                     000630
           END                                                          000640
             FITRT[0] = RTYP;                                           000650
           GOTO TSTBTYP;                                                000660
           END                                                          000670
          IF RSIZSPEC EQ SPECIFIED THEN                                 000680
             FITRT[0] = RSIZTYP;                                        000690
          IF RTYPSPEC EQ SPECIFIED THEN                                 000700
             FITRT[0] = RTYP;                                           000710
          IF RTYPSPEC EQ UNSPECIFIED AND                                000720
             RSIZSPEC EQ UNSPECIFIED THEN                               000730
             FITRT[0] = FIXLENRT;                                       000740
       TSTBTYP:                                                         000750
          IF BSIZSPEC EQ SPECIFIED AND                                  000760
             BTYPSPEC EQ SPECIFIED THEN                                 000770
           BEGIN                                                        000780
                DIAGNOS = 199;
                DIAGS;
             FITBT[0] = BTYP;                                           000790
                       GOTO TESTEND;                                    000800
           END                                                          000810
          IF BSIZSPEC EQ SPECIFIED THEN                                 000820
             FITBT[0] = BSIZTYP;                                        000830
          IF BTYPSPEC EQ SPECIFIED THEN                                 000840
             FITBT[0] = BTYP;                                           000850
          IF BSIZSPEC EQ UNSPECIFIED AND                                000860
             BTYPSPEC EQ UNSPECIFIED THEN                               000870
           FITBT[0] = CHARCOUNT;                                        000880
          IF FITRT[0] EQ CONTROLWORD AND                                000890
             FITBT[0] NQ INTERNAL THEN                                  000900
              BEGIN                                                     000910
               DIAGNOS = 187;                                           000920
               DIAGS;                                                   000930
                       GOTO TESTEND;                                    000940
              END                                                       000950
          IF FITBT[0] EQ INTERNAL AND                                   000960
             FITRT[0] NQ CONTROLWORD THEN                               000970
              BEGIN                                                     000980
               DIAGNOS = 187;                                           000990
               DIAGS;                                                   001000
                       GOTO TESTEND;                                    001010
              END                                                       001020
       TESTEND:                                                         001030
          SADNO;                                                        001040
       XTRAN: 
  
        ARBUFTRANS[0] = SPECIFIED;
         SADNO; 
  
          YCLEPT: 
            SADNO;
  
    END 
      TERM; 
