*DECK DMLMAIN                                                           000110
      PROC DMLMAIN;                                                     000120
      BEGIN                                                             000130
      CONTROL FASTLOOP;                                                 000140
      CONTROL DISJOINT;                                                 000150
      CONTROL INERT;                                                    000160
                                                                        000170
                                 #        DEFS                         #000180
                                                                        000190
      DEF F4       #8#;          # DDLCOMP VALUE FOR FORTRAN 4         #
      DEF F5       #9#;          # DDLCOMP VALUE FOR FORTRAN 5         #
      DEF BLANK     #" "#;       # BLANK CHARACTER                     #000220
      DEF DISP0    #"0"#;        # CHARACTER ZERO                      #000230
      DEF DISP1    #"1"#;        # CHARACTER ONE                       #000240
      DEF DISP3    #"3"#;        # CHARACTER THREE                     #000250
      DEF DISP6    #"6"#;        # CHARACTER SIX                       #000260
      DEF FITLEN   #35#;         # LENGTH OF FIT IN WORDS              #
      DEF AK     #6#;            #FIT CODE FOR AK                      #
                                                                        000310
                                                                        000320
                                                                        000330
      DEF LOUTERR  #20#;         # LENGTH OF OUTERR                    #000340
                                                                        000350
                                                                        000370
                                   # XDEFS                             #000380
      XDEF                                                              000390
        BEGIN                                                           000400
           ARRAY SSNAME [2] S(1);                                       000410
           BEGIN                                                        000750
             ITEM SUBSCHNAME U(0,0,60);     # SUBSCHEMA NAME           #000760
             ITEM SSNAME30   C(0,0,30);                                 000770
           END                                                          000780
                                                                        000430
          ITEM SSLENG = 0;       # LENGTH IN CHARACTERS OF SS NAME     #000440
          ITEM SSLENW = 0;       # LENGTH IN WORDS OF SS NAME          #000450
                                                                        000460
        END                                                             000470
                                                                        000480
                                 #  XREFS                              #000490
                                                                        000500
      XREF                                                              000510
        BEGIN                                                           000520
          PROC ABRT4;            # ISSUES FATAL MESSAGE TO THE ERROR   #000530
                                 # FILE AND DAY FILE AND THEN ABORTS   #000540
          PROC ABRT1;            # ISSUES INSUFFICIENT FIELD LENGTH    #
                                 # MESSAGE AND ABORTS                  #
          PROC ADDFTN;           # COPIES SUB-SCHEMA SOURCE ONTO DMLOUT#000130
          ITEM FWAS1S2;          # ADDR FOR ADDFTN TO START COPY FROM  #001410
          PROC DDLINIT;          # INITIAL ENTRY POINT IN CTLSCAN      #000570
          PROC DIAGDL;           # ENTRY POINT IN DMLDIAG THAT PROCESS #000580
                                 # DIAGS ISSUED IN SEMANTIC ROUTINES   #000590
          PROC DIAGSTD;          # ENTRY POINT IN DMLDIAG THAT PROCESS #000600
                                 # DIAGS ISSUED IN SYNGEN SPECIFICATION#000610
          PROC STDNO;            # ENTRY POINT IN STD TO RETURN NO     #000620
          PROC STDYES;           # ENTRY POINT IN STD TO RETURN YES    #000630
          PROC STD$START;        # INITIAL ENTRY POINT IN CTLSTD       #000640
          PROC WDMLOUT;          # DMLOUT WRITE ROUTINE                #000650
                                                                        002670
                                 # DEBUGGING ROUTINES                  #002680
          PROC SNATCH;                                                  002690
          PROC SNATCHC;                                                 002700
          PROC SNATCHO;                                                 002710
          PROC SNATCHD;                                                 002720
          PROC SNATCHF;                                                 002730
          PROC MEMORY;           # ISSUE FIELD LENGTH REQUEST          #000400
          ITEM DDLMEM;           # CONTAINS CURRENT JOB FIELD LENGTH   #000410
                                 # IN LEFTMOST 30 BITS                 #000420
          ITEM MAXFL;            # MAXIMUN FIELD LENGTH ALLOWED        #000430
                                 # PREPASS SETS THIS TO EQUAL DDLMEM   #000440
          ITEM DDLSU;            # STORAGE USED- MIN FL NEEDED         #000450
                                                                        000660
                                 # DIRECTORY ACCESS ROUTINES           #000670
                                                                        000680
          PROC DE$ARSB;              # READS AREA/RELATION ENTRY       #000690
          PROC DE$OPSB;              # OPENS SS FILE                   #000700
          PROC DE$RCSB;              # READS RECORD ENTRY              #000710
          PROC DE$GTSB;              # READS SS BY WORD ADDRESS        #000720
                                                                        000730
          ITEM ABORTFLAG;        # 1=FATAL DIAGNOSTIC HAS BEEN ISSUED  #000740
                                 # ABORTFLAG IS SET BY DMLDIAG         #000750
                                                                        000760
                                 # XREFS DEFINED IN CTLSCAN            #000770
                                                                        000780
          ARRAY CWORD [25] S(1);  # CURRENT SYNTAX SOURCE WORD         #000790
            BEGIN                                                       000800
              ITEM CURWORD U(0,0,60);                                   000810
              ITEM CURWRD30 C(0,0,30);                                  000820
            END                                                         000830
                                                                        000840
          ITEM CURLENG;          # LENGTH IN CHARACTERS                #000850
                                 # OF CURRENT SOURCE WORD              #000860
          ITEM CURLENW;          # LENGTH IN WORDS                     #000870
                                 # OF CURRENT SOURCE WORD              #000880
                                                                        000340
          ITEM CURLABEL C(5);    # LABEL (COL.1-5) OF STMT JUST COM-   #000350
                                 # PLETED (+EOS RETURNED OR +SNS DONE).#000360
                                                                        000890
          ITEM STARSTMT B;       # TRUE MEANS CONVERT THE              #000900
                                 # CURRENT STATEMENT INTO A COMMENT    #000910
                                                                        000920
                                 # XREFS DEFINED IN  DML               #000930
                                                                        000940
          ITEM DDLCOMP;          # CONTAINS CODE FOR FTN4 OR FTN5      #
          ITEM SBLFN U;          # LFN OF SUBSCHEMA FILE               #000960
        ITEM DSOPT B;            # TRUE MEANS SUPPRESS LISTING CONTROL #000420
                                 # DIRECTIVES                          #000430
          ITEM DDLDIAG;          # ADDRESS OF THE DIAG ROUTINE         #000970
          ITEM SYNTBL;           # ADDRESS OF THE SYNTAX TABLE         #000980
          ITEM LBLPTR;           # ADDRESS OF THE SUBROUTINE LIST      #000990
          ITEM TRACE;            # ADDRESS OF THE TRACE TABLE          #001000
          ITEM LEXWD;            # ADDRESS OF THE KEYWORD LIST         #001010
          ITEM LEXICO;           # ADDRESS OF THE KEYWORD INDEX        #001020
          ITEM SWITCHVCTR;       # ADDRESS OF THE SWITCH VECTOR        #001030
                                                                        001040
                                 # XREFS DEFINED IN DMLSYN             #001050
                                                                        001060
          ITEM SYNTBLE;          # ADDRESS OF THE SYNTAX TABLE         #001070
          ITEM TRACEM;           # ADDRESS OF THE TRACE TABLE          #001080
          ITEM LBLPTRS;          # ADDRESS OF THE SUBROUTINE LIST      #001090
          ITEM LEXICON;          # ADDRESS OF THE KEYWORD INDEX        #001100
          ITEM LEXWORD;          # ADDRESS OF THE KEYWORD LIST         #001110
        END                                                             001120
                                                                        001130
                                 # LOCAL VARIABLES                     #001140
                                                                        001150
      ITEM I;                    # SCRATCH ITEM                        #001160
      ITEM J;                                                           001170
      ITEM K;                                                           001180
      ITEM L;                                                           002630
      ITEM NEXTDBI I;            # DBI POINTER                         #
      ITEM NAMEPTR I;            # POINTER TO ITEM NAME                #
      ITEM SAVENAM C(7);         # HOLDS 1ST ITEM NAME OF MAJOR KEY    #
      ITEM SAVELEN I;            # HOLDS LENGTH OF 1ST ITEM NAME OF    #
                                 # MAJOR KEY                           #
      ITEM TEMP;                                                        002640
      ITEM SUB;                                                         000400
      ITEM CHARTEMP C(30) = BLANK;                                      000800
      ITEM MAJORFLAG B=FALSE;    # MAJOR KEY FLAG                      #
      ITEM CONCTFG B=FALSE;      # CONCATENATED KEY FLAG               #
                                                                        002340
                                                                        000290
      BASED ARRAY RA [0];        # POINTS TO RA 0, USED TO PICK UP     #000300
                                 # RA 65-LAST WORD ADDR + 1 IN CM      #000310
        ITEM RAWORD U(0,0,60);                                          000320
      ITEM FIRSTWORD;            # CONTAINS THE FIRST WORD ADDRESS     #000330
                                 # OF AVAILABLE STORAGE                #000340
      ITEM LASTWORD;             # LAST WORD OF USERS FIELD LENGTH     #000350
      BASED ARRAY WORKAREA [0] S;                                       000360
        ITEM WORKWORD U(0,0,60);                                        000370
      ITEM WORKPTR = 10;         # POINTER TO WORK AREA                #000380
                                                                        001190
      ITEM DISPLAYORD C(5);      # HOLDS ORDINAL IN DISPLAY FORMAT     #001200
      ITEM DIGITCOUNT;           # NUMBER OF DIGITS CONVERTED          #001205
                                                                        001210
      ITEM KEYCODE C(1);         # KEY RELATIONAL OPERATOR             #001220
                                                                        001230
      ITEM RELFLAG B = FALSE;    # THIS FLAG IS TRUE IF A READ RELATION#001240
                                 # IS BEING PROCESSED.                 #001250
                                                                        001260
      ITEM INVOKEFLAG B = FALSE; # TRUE MEANS AN INVOKE STMT IS FOUND  #000530
                                                                        001290
      ITEM PGMNAME C(10);        # PROGRAM UNIT NAME                   #002130
                                                                        002140
      ITEM KEYITEM C(30);        # HOLDS KEY ITEM NAME                 #
                                                                        001310
      ITEM KEYITEMSIZE;          # HOLDS LENGTH IN CHARACTERS          #001320
                                 # OF KEY ITEM NAME                    #001330
                                                                        001340
      ITEM KEYFLAG B = FALSE;    # TRUE IF A READ RELATION WITH KEY    #001350
                                 # IS BEING PROCESSED.                 #001360
  
      ITEM STKEYFLAG B = TRUE;   # TRUE IF START WITH KEY PROCESSED    #
  
      ITEM PARMLOC;              # SPECIFIES LAST PARAMETER LOCATION   #
  
      ITEM ENDSAVE C(6);         # STORAGE FOR ON END ALT RETURN LABEL #
  
      ITEM ERRSAVE C(6);         # STORAGE FOR ON ERR ALT RETURN LABEL #
  
      ITEM ENDPARCNT;            # END PARAMETER COUNTER               #
  
      ITEM ERRPARCNT;            # ERR PARAMETER COUNTER               #
                                                                        001370
      ITEM MODEPARCNT;           # COUNT OF MODE PARAMS.               #002450
                                 # ERROR IF GT 1.                      #002460
                                                                        002470
      ITEM MODE C(2);            # HOLDS MODE OPTION.                  #002480
                                                                        002490
      ITEM PRIVPARCNT;           # COUNT OF PRIVACY PARAMS.            #002500
                                 # ERROR IF GT 1.                      #002510
                                                                        002520
      ITEM PRIVACY C(32);        # HOLDS PRIVACY OPTION - NAME OR LIT. #002530
                                                                        000150
      ITEM LITFLAG B = FALSE;    # TRUE IF PRIVACY PARM IS LITERAL     #000160
                                                                        002540
                                                                        001380
                                 # SKELETONS FOR INTERFACE ROUTINE     #001390
                                 # CALL STATEMENTS                     #001400
                                                                        001410
      ITEM VERSID  C(7) = " ";     # TEMP TO HOLD VERSION NAME         #
      ITEM BEGINID C(10)= " ";     # TEMP TO HOLD BEGINTRAN IDENTIFIER #
      ITEM RSTID   C(10)= " ";     # TEMP TO HOLD RESTART IDENTIFIER   #
      ITEM TYPID   C(10)= " ";     # TEMP TO HOLD TYPE PARAMETER ON    #
                                   # LOCK STATEMENT                    #
      ITEM OPENREL C(70) =                                             "
      CALL DMLOPNR(DBNXXXX,DBAXXXX,2HIO,ERRRTN)"; 
  
      ITEM CLOSREL C(70) =                                             "
      CALL DMLCLSR(DBNXXXX,DBAXXXX,ERRRTN)";
  
      ITEM CALLOPN C(70) =                                             "
      CALL DMLOPN(DBFXXXX,RORD,2HIO,ERRRTN)"; 
  
      ITEM CALLCLS C(45) ="      CALL DMLCLS(DBFXXXX,RORD,ERRRTN)"; 
  
#--------------------START CALL STATEMENT SKELETONS--------------------#
  
      ITEM CALLSTR  C(70) =                                            "
      CALL DMLSTR(DBFXXXX,RORD,KYORD,RCOR,0,DLXX,T,RKWX,RP,MKLX,";
  
      ITEM CALLSTR1 C(45) ="     +KEYNAME,ERRRTN)"; 
  
      ITEM CALLRST  C(70) =                                            "
      CALL DMLRST(DBNXXXX,RLOR,KYORD,RCOR,0,KLXX,T,RKWX,RP,MKLX,";
  
      ITEM CALLRST1 C(45) ="     +KEYNAME, RORD,ERRRTN)"; 
  
#----------------------------------------------------------------------#
      ITEM CALLRD  C(70) =                                             "
      CALL DMLRD(DBFXXXX,RORD,0,0,ERRRTN,ENDRTN)";
  
      ITEM CALLWRT C(70) =                                             "
      CALL DMLWRT(DBFXXXX,0,RORD,PKORD,ERRRTN)";
  
      ITEM CALLREW C(70) =                                             "
      CALL DMLREW(DBFXXXX,0,RORD,PKORD,ERRRTN)";
  
      ITEM CALLDEL  C(70) =                                            "
      CALL DMLDEL(DBFXXXX,0,RORD,PKORD,ERRRTN)";
  
      ITEM CALLRL C(70) =                                              "
      CALL DMLRL(DBNXXXX,RORD,0,0,ERRRTN,ENDRTN)";
  
      ITEM CALLRDK C(70) =                                             "
      CALL DMLRDK(DBFXXXX,RORD,KYORD,RCOR,0,KLXX,T,RKWX,RP,"; 
  
      ITEM CALLRDK1 C(45) ="     +KEYNAME,ERRRTN)"; 
                                                                        000150
      ITEM CALLRLK C(67) =                                              000160
"      CALL DMLRLK(DBNXXXX,RLOR,KYORD,RCOR,0,KLXX,T,RKWX,RP,KEYNAME,";  000170
                                                                        000180
      ITEM CALLRLK1 C(45)="     + RORD,ERRRTN)";
  
      ITEM CALLLCK C(45) ="      CALL DMLLCK(DBFXXXX,RORD,ERRRTN)"; 
  
  
#---------ALTERNATE LOCK CALL STATEMENT SKELETON-----------------------#
  
      ITEM CALLCKP1 C(60) =        # ALTERNATE LOCK CALL STATEMENT    #"
      CALL DMLLCKP(DBFXXXX,10H          ,10H          ,     ";
      ITEM CALLCKP2 C(45) =        # ALTERNATE LOCK CALL CONTD        #"
     +10H          ,Q1234567890Q,ERRRTN)     "; 
  
#---------COMMIT CALL STATEMENT SKELETON-------------------------------#
  
      ITEM CALLCOMMIT C(30) =      # COMMIT CALL STATEMENT            #"
      CALL DMLCMT(ERRRTN)     ";
  
#---------DROP CALL STATEMENT SKELETON---------------------------------#
  
      ITEM CALLDRP C(30) =         # DROP CALL STATEMENT              #"
      CALL DMLDRP(ERRRTN)     ";
      ITEM CALLUNL C(45) ="      CALL DMLUNL(DBFXXXX,RORD,ERRRTN)"; 
  
#---------------PRIVACY CALL STATEMENT SKELETON------------------------#
  
      ITEM CALLPRV C(35) ="      CALL DMLPRV(0,1,0,XXXX,      ";
  
      ITEM CALLPR1 C(55) =         #      PRIVACY STMT CONTINUATION   #"
     +O""NN"",Q1234567890Q,Q1234567890Q,Q1234567890Q)    "; 
  
#----------------------------------------------------------------------#
  
      ITEM SETWSA  C(35) ="      DBFXXXX(16)=LOCF(DBIXXXX)    ";        000130
      ITEM SETWSAF5 C(60) = 
"      DBFXXXX(16)=LOCF(DBIXXXX).AND. O""00000000000017777777"""; 
      ITEM SETINVOKEKA C(29) =
            "      DBFXXXX(25)=0000000000B";
      ITEM FT5INVOKEKA C(43) =
            "      DBFXXXX(25)=  O""00000000000000000000""";
  
      ITEM SETKA   C(41) ="      DBFXXXX(25)=DBFXXXX(25)+DBFXXXX(16)";  000140
      ITEM SETRL   C(35) ="      DBNXXXX(XXXX)=LOCF(DBFXXXX)  ";        000150
  
      ITEM SETRELIST C(55) =       # FTN4 STMT TO STORE DATA NAME ADDR #
"      DBRELST(XXXX)=DBRELST(XXXX) .OR. LOCF(7CHNAME)   ";              000170
                                   # FTN5 STMTS TO STORE DATA NAME     #
                                   # ADDR AND BCP                      #
      ITEM SETRELST5A C(55) =      # MASK OUT ALL BUT ITEM ADDRESS     #
"      DBTEMP=LOCF(7CHNAME).AND. O""00000000000017777777""";
  
      ITEM SETRELST5B C(43) =      # STORE ADDR AND BCP                #
"      DBRELST(XXXX)=DBRELST(XXXX).OR.DBTEMP";
  
      ITEM SETRELST5C C(55) =      # MASK OUT ALL BUT ITEM BCP         #
"      DBTEMP=LOCF(7CHNAME).AND. O""00000000001700000000""";
  
      ITEM SETRELST5D C(28) =      # SHIFT BCP TO MATCH CDCS FORMAT    #
"      DBTEMP=SHIFT(DBTEMP,6)"; 
  
#---------------INVOKE CALL STATEMENT SKELETON-------------------------#
  
      ITEM CALLINV C(70) =         # INVOKE CALL STATEMENT            #"
      CALL DMLINV(XXXX,DBF0001,10H1234567890,10H1234567890,           ";
  
      ITEM CALLIN4 C(50) =         # FTN4 INVOKE STMT CONTINUATION    #"
     +10H1234567890,12345678901234567890B)       "; 
  
      ITEM CALLIN5 C(50) =         # FTN5 INVOKE STMT CONTINUATION    #"
     +10H1234567890,O""12345678901234567890"")      ";
  
      ITEM CALLINVV C(70) =        # INVOKE(VERSION) CALL STATEMENT   #"
      CALL DMLINVV(XXXX,DBF0001,10H1234567890,10H1234567890,          ";
      ITEM CALLINVV4 C(60) =       # FTN4 INVOKE(VERSION) CONTD       #"
     +10H1234567890,12345678901234567890B,Q1234567Q)        ";
      ITEM CALLINVV5 C(60) =       # FTN5 INVOKE(VERSION) CONTD       #"
     +10H1234567890,O""12345678901234567890"",Q1234567Q)      ";
  
#----------VERSION CALL STATEMENT SKELETON-----------------------------#
  
      ITEM CALLVERS C(40)=         # VERSION CALL STATEMENT           #"
      CALL DMLVERS(Q1234567Q,ERRRTN)    ";
  
#---------BEGINTRAN CALL STATEMENT SKELETON----------------------------#
  
      ITEM CALLBEGTRAN C(40)=      # BEGINTRAN CALL STATEMENT         #"
      CALL DMLBEG(Q1234567890Q,ERRRTN)  ";
  
#---------GET RESTART IDENTIFIER CALL SKELETON-------------------------#
  
      ITEM CALLRSTID C(40) =       #                                  #"
      CALL DMLGTID(1234567,ERRRTN)      ";
  
#---------FIND TRANSACTION ID CALL STATEMENT SKELETON------------------#
  
      ITEM CALLFIND C(44) =        # FINDCALL STATEMENT               #"
      CALL DMLFIND(1234567,1234567,ERRRTN)  ";
#----------------------------------------------------------------------#
  
      ITEM CALLEND C(20) ="      CALL DMLEND   ";                       000130
                                                                        002280
                                                                        002300
      ITEM DATANAME C(40) = "      DATA DBRUID /10HXXXXXXXXXX/       "; 002310
                                                                        002320
#-------------------------LIST,ALL/NONE STATEMENTS---------------------#
  
                                   # FORTRAN 4 STATEMENTS              #
      ITEM LISTALL4  C(20) = "C/    LIST,ALL      ";
      ITEM LISTNONE4 C(20) = "C/    LIST,NONE     ";
                                   # FORTRAN 5 STATEMENTS              #
      ITEM LISTALL5  C(20) = "C$    LIST(ALL)     ";                    000610
      ITEM LISTNONE5 C(20) = "C$    LIST(ALL=0)   ";
  
#----------------------------------------------------------------------#
                                                                        001540
                                 # THE FOLLOWING MESSAGE IS WRITTEN    #001550
                                 # ON DMLOUT WHEN THERE IS AN ERROR    #001560
                                 # IN THE DML INPUT.  THIS MESSAGE     #001570
                                 # WILL CAUSE THE FORTRAN COMPILER     #001580
                                 # TO ISSUE A DIAGNOSTIC.              #001590
                                                                        001600
      ITEM OUTERR C (LOUTERR) = " **** DML ERROR     ";                 001610
                                                                        001620
                                                                        001630
                                 # THESE 3 WORDS ARE USED TO           #001640
                                 # HOLD THE REALM NAME                 #001650
                                                                        001660
      ARRAY RLMNAME [2] S(1);                                           001670
        BEGIN                                                           001680
          ITEM REALMNAME U(0,0,60); # REALM NAME                       #001690
          ITEM RLMNAME30 C(0,0,30); # REALM NAME IN CHAR               #001700
        END                                                             001710
                                                                        001720
      ITEM REALMORDINAL;         # HOLDS REALM ORDINAL                 #001730
      ITEM RELATIONORD;          # HOLDS RELATION ORDINAL              #001740
      ITEM KEYORDINAL;           # HOLDS KEY ORDINAL                   #001760
      ITEM RECORDINAL;           # HOLDS RECORD ORDINAL                #001762
      ITEM RKW;                  # RKW FIELD IN FIT                    #001764
      ITEM RKP;                  # RKP FIELD IN FIT                    #001766
      ITEM KEYTYPE;              # FIT KEY TYPE                        #001768
      ITEM KEYLENGTH;            # KEY LENGTH                          #001769
      ITEM MKL;                  # MAJOR KEY LENGTH                    #
                                                                        001770
      ITEM PRIMKEY  B;             # BOOLEAN PRIMARY KEY FLAG          #
                                 # SIZE OF REALM/RELATION LIST         #001780
      ITEM RLMLISTSIZE;                                                 001790
                                                                        001800
                                                                        001830
                                                                        001840
      BASED ARRAY REALMLIST  S(4);                                      000470
        BEGIN                                                           001860
*CALL SBRLMLST                                                          001870
        END                                                             001880
                                                                        001890
      BASED ARRAY RECORDLIST [0] S;                                     001900
        BEGIN                                                           001910
*CALL SBRECLST                                                          001920
      END                                                               001930
                                                                        001940
                                                                        001950
      ARRAY REALMENTRY S(2);      # 2 WORDS OF REALM ENTRY             #001960
        BEGIN                                                           001970
          ITEM SBARORDINAL U(0,3,12); # REALM ORDINAL                  #001980
          ITEM SBARDCONTRLA U(1,42,18); # WORD ADDRESS OF DATA CONTROL #001990
                                        # ENTRY                        #002000
        END                                                             002010
                                                                        002020
                                 # MAP OF RELATION ENTRY               #002030
      BASED ARRAY MAPRELATION S(2);                                     002040
        ITEM RELORD U(0,15,12);  # RELATION ORDINAL                    #002050
                                                                        002060
                                                                        002070
       ARRAY RELENTRY [0:6] S(1);                                       000460
      BEGIN                                                             002090
*CALL SBRLHDDCL                                                         002100
*CALL SBRLDBDCL                                                         002110
      END                                                               002120
       BASED ARRAY DBIARRAY [1:2] S(2);                                 000130
        BEGIN                                                           002320
          ITEM AREAORD  U(0,0,21);                                      002330
        END                                                             002340
                                                                        002350
      ARRAY RQTHEADER [0];       # 1 WORD OF RQT TABLE - HEADER        #002360
        BEGIN                                                           002370
*CALL SBRQHDDCL                                                         002380
        END                                                             002390
                                                                        002400
      BASED ARRAY RQTSTACK;      # RQT STACK ENTRIES                   #002410
        BEGIN                                                           002420
*CALL SBRQSTDCL                                                         002430
        END                                                             002440
                                                                        002450
      BASED ARRAY RQTATTR;       # RQT ATTRIBUTE ENTRIES               #002460
        BEGIN                                                           002470
*CALL SBRQATDCL                                                         002480
        END                                                             002490
                                                                        002500
                                                                        002130
      ARRAY RECORDENTRY [0:3] S(1);                                     000150
        ITEM SBRECORDINAL U(0,3,12); # RECORD ORDINAL                  #002150
                                                                        002160
      ARRAY DATACONTROL[0] S(2);
        BEGIN 
*CALL SBDCHDDCL 
        END 
  
      ARRAY FIT[0] S(FITLEN); 
*CALL FITDCLS 
      ITEM FITPTR U;             # HOLDS ADDRESS OF DATA CONTROL FIT   #
                                                                        002190
                                   # KEY ENTRY OF DATA CONTROL ENTRY   #002200
      ARRAY KEYENTRY S(70);;
                                                                        002220
      BASED ARRAY MAPKEYENTRY;                                          002230
        BEGIN                                                           002240
*CALL SBDCKYDCL                                                         002250
        END                                                             002260
                                                                        002270
                                                                        002280
      ARRAY ITEMENTRY [11] S(1); # 12 WORDS OF ITEM ENTRY              #002290
        BEGIN                                                           002300
*CALL SBIHDDCLS                                                         002310
        END                                                             002320
                                                                        002330
      ITEM DCADDR;               # WORD ADDRESS OF DATA CONTROL ENTRY  #002340
                                                                        002350
      ITEM ITEMADDR;             # WORD ADDRESS OF ITEM ENTRY          #002360
                                                                        002370
      ITEM RELADDR;              # WORD ADDRESS OF RELATION ENTRY      #002520
                                                                        002530
      ITEM DBIADDR;              # WORD ADDRESS OF DBI SECTION         #002540
                                 # OF RELATION ENTRY                   #002550
                                                                        002560
      ITEM RELISTSUB = 2;        # SUBSCRIPT FOR RELATION USAGE LIST   #002600
                                                                        002610
      ARRAY CRMBUF [99]; ;       # CRM BUFFER FOR DE$OPSB CALL         #002380
                                                                        002390
      ITEM CRMBUFLEN = 100;      # CRM BUFFER LENGTH                   #002400
                                                                        002410
      ITEM SSADDR = 0;           # WORD ADDR OF SS IN FILE             #002380
                                                                        002390
                                                                        002420
      ARRAY DIT [24] S(1);       # DIT                                 #002430
        BEGIN                                                           002440
*CALL SBCWDECLS                                                         002450
*CALL DITDECLS                                                          002460
                                                                        000710
          ITEM SBCWSBCKSUM1 U(7,00,30);   # SUB-SCHEMA CHECKSUM        #
          ITEM SBCWSBCKSUM2 U(7,30,30);   #                            #
      END                                                               002470
                                                                        002480
                                                                        002490
      SWITCH PPJUMP              # JUMP TABLE OF SEMANTIC ROUTINES     #002500
                                 # MUST MATCH JUMP TABLE IN DMLSYN     #002510
                                                                        002520
        DMLEND,                  # ROUTINE WHICH RECEIVES CONTROL      #002530
                                 # WHEN THE PRE-PASS HAS FINISHED      #002540
                                 # PROCESSING INPUT                    #002550
         SAVENAME,               # RTN TO SAVE SS NAME                 #002560
         COMMENT,                # RTN TO CONVERT DML STMT             #002570
                                 # INTO A FORTRAN COMMENT              #002580
         COPYSS,                 # RTN TO COPY IN SUBSCHEMA            #002590
        FTNCHK,                  # CHECK FOR COMPATIBLE FTN IN SS      #
        DMLERROR,                # WRITES "DML ERROR" ON DMLOUT        #002630
        DMLINIT,                 # INITIALIZES VARIABLES               #
        REALMORD,                # CONVERTS REALM NAME INTO ORDINAL    #002640
        MODESTORE,               # STORES MODE INTO DMLOPN CALL        #002650
        OPENCALL,                # WRITES CALL TO DMLOPN ON DMLOUT     #002660
        CLOSECALL,               # WRITES CALL TO DMLCLS ON DMLOUT     #002670
        STARTCALL,               # WRITES CALL TO DMLSTR ON DMLOUT     #
        READCALL,                # WRITES CALL TO DMLRD ON DMLOUT     # 002680
        WRITECALL,               # WRITES CALL TO DMLWRT ON DMLOUT     #002690
        RECORDORD,               # FINDS RECORD ORDINAL                #002700
        PKEYORD,                 # FINDS PRIMARY KEY ORDINAL           #002710
        DELETECALL,              # WRITES CALL TO DMLDEL ON DMLOUT     #002720
        REWRITECALL,             # WRITES CALL TO DMLREW ON DMLOUT     #002730
        VERSCALL,                # WRITES CALL TO DMLVERS ON DMLOUT    #
        SAVERS,                  # SAVES VERSION NAME/LITERAL          #
        BEGINCALL,               # WRITES CALL TO DMLBEGTRAN ON DMLOUT #
        SAVBEGID,                # SAVES BEGINTRAN NAME/LITERAL        #
        COMMITCALL,              # WRITES CALL TO DMLCMT ON DMLOUT     #
        DROPCALL,                # WRITES CALL TO DMLDRP ON DMLOUT     #
        ASSIGNCALL,              # WRITES CALL TO DMLGTID ON DMLOUT    #
        SAVRID,                  # SAVES RESTART IDENTIFIER            #
        FINDCALL,                # WRITES CALL TO DMLFIND ON DMLOUT    #
        SAVTYP,                  # SAVES LOCK TYPE/LITERAL             #
        SAVEREALM,               # SAVES REALM NAME                    #002740
        ACCESSREALM,             # READS REALM ENTRY FROM SS           #002750
        REALMRELORD,             # FINDS REALM OR RELATION ORDINAL     #002760
        STKEYCK,                 # CHECK IF START KEY SPECIFIED        #
        KEYOPR,                  # SAVES KEY OPERATOR                  #002770
        KEYNAME                  # VERIFIES KEY NAME                   #000930
       ,READKEY                  # VERIFIES KEY NAME IN READ STATEMENT #
       ,ERRRTRN                  # CHECKS AND STORES ON ERROR LABEL    #
       ,ENDRTRN                  # CHECKS AND STORES ON END LABEL      #
       ,SAVEPGMNAME              # SAVES PROGRAM UNIT NAME             #000940
       ,DEFAULTNAME              # STORES DEFAULT PROGRAM UNIT NAME    #000950
       ,DATAPGMNAME              # GENERATES DATA STMT FOR PGM NAME    #000960
       ,FITCALL                  # WRITES CALL TO DMLCFIT ON DMLOUT    #000970
       ,FITLISTCALL              # WRITES CALL TO DMLCFL ON DMLOUT     #000980
       ,INVOKECALL               # WRITES CALL TO DMLINV ON DMLOUT     #001000
       ,TERMCALL                 # WRITES CALL TO DB$END ON DMLOUT     #001010
       ,LOCKCALL                 # WRITES CALL TO DMLLCK ON DMLOUT     #001080
       ,UNLOCKCALL               # WRITES CALL TO DMLUNL ON DMLOUT     #001090
       ,PRIVACYCALL              # WRITES CALL TO DMLPRV ON DMLOUT     #001100
       ,SAVEMODE                 # SAVES MODE PARAMETER                #001110
       ,SAVEPRIV                 # SAVES PRIVACY PARAMETER             #001120
       ,NOCOMMENT                # DELETES COMMENT FROM FTN STMT       #000250
       ,SETLIT                  # SETS LITERAL FLAG                    #000370
      ,ENDOFPROG                 # VERIFIES INVOKE IN EVERY PROG UNIT  #000210
       ;                                                                001020
      CONTROL EJECT;                                                    000380
FUNC XCOD(NUMBER) C(10);                                                000390
   BEGIN                                                                000400
#**********************************************************************#000410
#                                                                      #000420
#                         X C O D                                      #000430
#                                                                      #000440
#     THIS FUNCTION CONVERTS A BINARY INTEGER INTO OCTAL DISPLAY CODE  #000450
#                                                                      #000460
#**********************************************************************#000470
      ITEM NUMBER;               # NUMBER TO BE CONVERTED              #000480
      ITEM WORK C(10);                                                  000490
      ITEM I,J;                                                         000500
      WORK = "0000000000";       # ZERO FILL                           #000510
      I = NUMBER;                                                       000520
      FOR J = 3  STEP 3 UNTIL 30 DO                                     000530
        B<60-J*2,6>WORK = B<60-J,3>NUMBER + O"33";                      000700
      XCOD = WORK;                                                      000550
      RETURN;                                                           000560
   END                                                                  000570
 CONTROL EJECT;                                                         002790
START:                                                                  002800
#**********************************************************************#002810
#                           S T A R T                                  #002820
#                                                                      #002830
#   INITIALIZES EXTERNAL FIELDS TO THE LOCATIONS OF VARIOUS SYNGEN     #002840
#   TABLES. CALLS INITIAL ENTRY POINT IN CTLSCAN AND THEN PASSES       #002850
#   CONTROL TO CTLSTD.                                                 #002860
#                                                                      #002870
#**********************************************************************#002880
      DDLDIAG = LOC(DIAGSTD);    # SET ADDRESS OF DIAG ROUTINE         #002890
*IF DEF,DEBUG                                                           000210
      TRACE = LOC(TRACEM);       # SET ADDRESS OF TRACE TABLE          #002900
*ENDIF                                                                  000230
      LEXWD = LOC(LEXWORD);      # SET ADDRESS OF KEYWORD LIST         #002910
      LEXICO = LOC(LEXICON);     # SET ADDRESS OF KEYWORD INDEX        #002920
      SYNTBL = LOC(SYNTBLE);     # SET ADDRESS OF SYNTAX TABLE         #002930
      LBLPTR = LOC(LBLPTRS);     # SET ADDRESS OF SUBROUTINE LIST      #002940
      SWITCHVCTR = LOC(PPJUMP);  # SET ADDRESS OF JUMP TABLE           #002950
                                                                        002960
      ABORTFLAG = 0;             # INITIALIZE ABORTFLAG                #002970
                                                                        002980
      P<RA> = 0;                                                        000130
      FIRSTWORD = B<42,18>RAWORD[53]; # 1ST AVAILABLE WORD OF MEMORY   #000130
      P<WORKAREA> = FIRSTWORD;                                          000150
      LASTWORD = B<0,30>DDLMEM;  # LAST WORD OF THE USERS FIELD LENGTH #000160
      MAXFL = B<0,30>DDLMEM;     # THIS CODE INSURES THAT MEMORY USED  #000170
                                 # DOES NOT EXCEED REQUESTED FIELD     #000180
                                 # LENGTH.                             #000190
                                                                        000200
      FOR I = 0 STEP 1 UNTIL LASTWORD - (FIRSTWORD+1) DO                000210
        WORKWORD[I] = 0;         # ZERO OUT WORKING STORAGE            #000220
                                                                        000230
      LASTWORD = LASTWORD -25;   # LEAVE SPACE TO ELIMINATE CONTINUAL  #000240
                                 # CHECKING FOR OVERFLOW               #000250
      P<REALMLIST> = FIRSTWORD + WORKPTR; # FIRST THING IN WORKAREA    #000260
                                 # WILL BE REALMLIST                   #000270
                                                                        002990
                                 # SET MAP OF RELATION ENTRY TO        #003000
                                 # OVERLAY REALMENTRY                  #003010
      P<MAPRELATION> = LOC(REALMENTRY);                                 003020
                                                                        003030
      P<MAPKEYENTRY> = LOC(KEYENTRY);                                   003040
                                                                        002290
                                                                        003050
                                                                        003060
      DDLINIT;                   # INITIALIZE CTLSCAN                  #003070
                                                                        003080
      STD$START;                 # CALL CTLSTD TO BEGIN INTERPRETING   #003090
                                 # SYNGEN SPECIFICATIONS               #003100
                                                                        003110
      # CONTROL DOES NOT RETURN TO THIS POINT                          #003120
      CONTROL EJECT;                                                    003130
DMLEND:                                                                 003140
#**********************************************************************#003150
#                                                                      #003160
#                       D M L E N D                                    #003170
#                                                                      #003180
#   THIS ROUTINE IS CALLED WHEN THERE ARE NO MORE INPUT STATEMENTS TO  #003190
#   BE PROCESSED.  IF ERRORS HAVE OCCURRED WITH A SEVERITY EQUAL TO OR #003200
#   GREATER THAN THE USER SPECIFIED ET OPTION, CALL ABRT4 IN DMLIO TO  #003210
#   ABORT. IF NOT, RETURN TO FDML                                      #003220
#                                                                      #003230
#**********************************************************************#003240
      IF ABORTFLAG GR 0          # IF FATAL ERRORS HAVE OCCURRED,      #003250
        THEN                     # THEN                                #003260
          ABRT4;                 # ABORT                               #003270
      RETURN;                    # RETURN TO FDML                      #003280
                                                                        003290
SAVENAME:                                                               003300
#**********************************************************************#003310
#                                                                      #003320
#                      S A V E N A M E                                 #003330
#                                                                      #003340
#     SAVES SUBSCHEMA NAME AND LENGTH OF NAME                          #003350
#     RETURNS YES                                                      #003360
#                                                                      #003370
#**********************************************************************#003380
                                                                        003390
      SUBSCHNAME[0] = 0;         # CLEAR SUBSCHEMA NAME                #000250
      SUBSCHNAME[1] = 0;                                                000260
      SUBSCHNAME[2] = 0;                                                000270
                                 # SAVE SUBSCHEMA NAME                 #003400
       FOR I=0 STEP 1 UNTIL CURLENW-1 DO                                003410
         SUBSCHNAME[I] = CURWORD[I];                                    003420
                                                                        003430
      SSLENG = CURLENG;          # LENGTH IN CHARS OF SS NAME          #003440
      SSLENW = CURLENW;          # LENGTH IN WORDS OF SS NAME          #003450
                                                                        003460
      STDYES;                    # RETURN YES                          #003470
                                                                        003480
                                                                        003490
COMMENT:                                                                003500
#**********************************************************************#003510
#                                                                      #003520
#                       C O M M E N T                                  #003530
#                                                                      #003540
#     THIS ROUTINE IS CALLED WHEN THE CURRENT DML STATEMENT            #003550
#     IS NOT A VALID FORTRAN STATEMENT. THIS ROUTINE SETS              #003560
#     A FLAG TO TELL THE SCANNER TO CONVERT THIS STATEMENT             #003570
#     INTO A COMMENT BEFORE IT IS WRITTEN TO DMLOUT.                   #003580
#                                                                      #003590
#**********************************************************************#003600
                                                                        003610
      STARSTMT = TRUE;           # THIS FLAG TELLS THE SCANNER         #003620
                                 # TO CONVERT THE CURRENT STATEMENT    #003630
                                 # INTO A COMMENT                      #003640
      STDYES;                    # RETURN YES                          #003650
                                                                        000270
NOCOMMENT:                                                              000280
#**********************************************************************#000290
#                                                                      #000300
#                    N O C O M M E N T                                 #000310
#                                                                      #000320
#     THIS ROUTINE IS CALLED WHEN THE DML STATEMENT BEING              #000330
#     PROCESSED CONSISTS OF ONLY ONE KEYWORD WHICH COULD ALSO BE       #000340
#     A VALID FORTRAN NAME,IE. INVOKE. THE SCANNER AUTOMATICALLY       #000350
#     CONVERTS THIS INTO A COMMENT. IF IT IS FOUND TO NOT BE A         #000360
#     DML STATEMENT, THIS ROUTINE TURNS THE COMMENT FLAG OFF.          #000370
#                                                                      #000380
#**********************************************************************#000390
                                                                        000400
      STARSTMT = FALSE;                                                 000410
      STDNO;                                                            000420
                                                                        003660
                                                                        003670
COPYSS:                                                                 003680
#**********************************************************************#003690
#                                                                      #003700
#                       C O P Y S S                                    #003710
#                                                                      #003720
#     OPENS SUBSCHEMA, VALIDATING THE SS LFN AND SS NAME.              #003730
#     IF SUBSCHEMA IS NOT FOUND, RETURNS NO                            #000290
#     COPIES SSOUT PORTION OF SUBSCHEMA (SOURCE STATEMENTS OF ITEM     #003750
#     DECLARATIONS FROM SS COMPILE) ONTO DMLOUT FILE.  READS REALM     #003760
#     LIST INTO MEMORY.                                                #000550
#                                                                      #003780
#**********************************************************************#003790
                                                                        003800
      DE$OPSB(SBLFN,SSNAME,DIT,CRMBUF,CRMBUFLEN);  # OPEN, FIND SS     #003810
                                                                        003820
      IF DASTATE[0] EQ 1         # IF SS NOT FOUND,                    #003830
      THEN                                                              003840
          STDNO;                 # RETURN NO                           #003890
                                                                        003910
      SSADDR = SBCWSBADDR[0];    # SAVE STARTING ADDR OF SS            #000160
                                                                        002420
                                 # FIND START OF SSOUT PORTION OF SS   #000130
       FWAS1S2 = SBCWFTNSSFWA[0] + SSADDR -1;                           000140
                                                                        001350
                                                                        000480
      IF NOT DSOPT               # IF DS OPTION NOT SELECTED           #000490
      THEN                       # GENERATE LIST,NONE DIRECTIVE        #000500
        BEGIN 
        IF DDLCOMP EQ F4         #              IF FTN4                #
        THEN
          WDMLOUT(LISTNONE4,20); # WRITE OUT FTN4 LIST,NONE DIRECTIVE  #
        ELSE                     #         ELSE, ASSUME FTN5           #
          WDMLOUT(LISTNONE5,20); # WRITE OUT FTN5 LIST,NONE DIRECTIVE  #
        END 
  
      ADDFTN;                    # COPY SUB-SCHEMA SOURCE ONTO DMLOUT  #000150
                                                                        000530
      IF NOT DSOPT               # IF DS OPTION NOT SELECTED           #000540
      THEN                                                              000550
        BEGIN 
        IF DDLCOMP EQ F4         #             IF FTN4                 #
        THEN
          WDMLOUT(LISTALL4,20);  # WRITE OUT FTN4 LIST,ALL DIRECTIVE   #
        ELSE                     #         ELSE, ASSUME FTN5           #
          WDMLOUT(LISTALL5,20);  # WRITE OUT FTN5 LIST,ALL DIRECTIVE   #
        END 
                                                                        000160
      DE$OPSB(SBLFN,SSNAME,DIT,CRMBUF,CRMBUFLEN); # REOPEN SS TO       #001370
                                                  # RESTORE FIT PARAMS #001380
                                                                        001390
                                 # CALCULATE SIZE OF REALM LIST        #003920
      RLMLISTSIZE = (SBCWNUMAREAS[0] + SBCWNUMRELS[0]) * 4;             003930
                                 # IF REALM LIST IS TOO BIG FOR ARRAY  #003940
                                 # DO NOT READ IT IN                   #003950
      WORKPTR = WORKPTR + RLMLISTSIZE; # UPDATE STORAGE USED           #000500
      CHECKFL;                   # CHECK IF ENOUGH WORKING STORAGE     #000510
                                 # ABORT IF EXCEEDED FIELD LENGTH      #000520
                                                                        000530
                                 # READ IN REALM LIST                  #004020
      DE$GTSB (REALMLIST,        # AREA TO READ INTO                   #004030
               RLMLISTSIZE,      # NO. OF WORDS TO READ                #004040
               SBCWRLMLSTAD[0]); # ADDR TO READ FROM                   #000180
                                                                        004060
                                 # ADDRESS OUTSIDE LIMITS              #004070
                                 # SHOULD NOT OCCUR                    #004080
      IF DASTATE[0] EQ 1                                                004090
      THEN                                                              004100
        STDNO;                                                          004110
                                                                        004120
      ELSE
      STDYES;                    # RETURN YES                          #004130
                                                                        004140
                                                                        004320
FTNCHK: 
#**********************************************************************#
#                                                                      #
#                            FTNCHK                                    #
#                                                                      #
#     CHECKS FOR COMPATIBLITY BETWEEN THE SUBSCHEMA AND DML            #
#     COMPILATION MODE. RETURN IS TO STDYES IF BOTH ARE                #
#     COMPATIBLE, STDNO IF NOT.                                        #
#                                                                      #
#**********************************************************************#
  
      IF ((SBCWSSTYPE[0] EQ "FT4"  # IF SS COMPILED UNDER DIFFERENT    #
        OR SBCWSSTYPE[0] EQ 0)     # FORTRAN VERSION THAN PREPROCESSOR #
          AND DDLCOMP EQ F5)       # COMPILATION LANGUAGE MODE         #
        OR (SBCWSSTYPE[0] EQ "FT5"
          AND DDLCOMP EQ F4)
      THEN
        STDNO;                     # RETURN TO PRINT DIAGNOSTIC        #
      ELSE
        STDYES;                    # ELSE, RETURN YES                  #
  
DMLERROR:                                                               004330
#**********************************************************************#004340
#                                                                      #004350
#                      D M L E R R O R                                 #004360
#                                                                      #004370
#     THIS ROUTINE IS CALLED WHEN THERE IS AN ERROR IN A               #004380
#     DML STATEMENT. A MESAGE IS WRITTEN TO DMLOUT WHICH WILL          #004390
#     CAUSE THE FORTRAN COMPILER TO ISSUE A DIAGNOSTIC.                #004400
#     RESETS ALTERNATE RETURN STORAGE AREAS.                           #
#     RETURNS TO STDNO.                                                #004410
#                                                                      #004420
#**********************************************************************#004430
                                                                        004440
      WDMLOUT (OUTERR, LOUTERR); # ISSUE DML ERROR MESSAGE             #004450
        TYPID = " ";               # RESET TYPE PARAMETER              #
        VERSID = " ";              # RESET TEMP FOR VERSION NAME       #
                                                                        004460
      ERRSAVE = "NUTHIN"; 
      ENDSAVE = "NUTHIN"; 
  
      STDNO;                     # RETURN NO                           #004470
                                                                        004480
DMLINIT:  
#**********************************************************************#
#                                                                      #
#                      D M L I N I T                                   #
#                                                                      #
#     THIS ROUTINE INITIALIZES VARIABLES BEFORE PROCESSING ANY DML     #
#     VERB.                                                            #
#                                                                      #
#     RETURNS TO STDNO.                                                #
#                                                                      #
#**********************************************************************#
  
      RELFLAG = FALSE;
      KEYFLAG = FALSE;
      MODEPARCNT = 0; 
      PRIVPARCNT = 0; 
      ENDPARCNT = 0;
      ERRPARCNT = 0;
      CONCTFG = FALSE;
      MAJORFLAG = FALSE;
  
      STDNO;                     # RETURN NO                           #
  
REALMORD:                                                               004490
#**********************************************************************#004500
#                                                                      #004510
#                   R E A L M O R D                                    #004520
#                                                                      #004530
#     THIS ROUTINE IS CALLED TO FIND A REALM ORDINAL                   #000570
#     IT SEARCHES THE REALM LIST FOR A NAME WHICH MATCHES THE SPECIFIED#004560
#     REALM NAME. RETURNS TO STDYES IS REALM IS FOUND. THE REALM       #004570
#     ORDINAL IS SAVED IN REALMORDINAL.  RETURNS TO STDNO IF REALM     #004580
#     NOT FOUND.                                                       #004590
#                                                                      #004600
#**********************************************************************#004610
                                                                        004620
      REALMORDINAL = 0;          # SET UP FOR LOOP                     #004630
                                                                        004640
                                                                        004700
                                 # SEARCH ONLY REALM PORTION OF REALM  #004710
                                 # LIST. SET LIMIT TO NUMBER OF        #004720
                                 # REALMS IN SUBSCHEMA                 #004730
      FOR I = 0 STEP 1 WHILE REALMORDINAL LS SBCWNUMAREAS[0] DO         004740
        BEGIN                                                           004750
          REALMORDINAL = REALMORDINAL + 1;                              004760
          IF RLMNAME30[0] EQ REALMLSTNM30[I]                            004770
          THEN                                                          004780
            BEGIN                  # SAVE REALM NAME                   #
            CHARTEMP = C<0,CURLENG>CURWRD30[0]; 
            STDYES;                                                     004790
            END 
        END                                                             004800
      STDNO;                                                            004810
                                                                        004820
REALMRELORD:                                                            004830
#**********************************************************************#004840
#                                                                      #004850
#                  R E A L M R E L O R D                               #004860
#                                                                      #004870
#     CALLED TO FIND A REALM OR RELATION ORDINAL.                      #000600
#     SEARCHES REALM LIST FOR NAME WHICH MATCHES                       #004900
#     THE SPECIFIED REALM OR RELATION NAME. RETURNS                    #004910
#     TO STDYES IF REALM OR RELATION IS FOUND.                         #004920
#     OTHERWISE RETURNS TO STDNO. RELATION ORDINAL                     #004930
#     IS RETURNED IN RELATIONORD, REALM ORDINAL IN REALMORDINAL        #000340
#                                                                      #004960
#**********************************************************************#004970
                                                                        004980
      REALMORDINAL = 0;                                                 004990
                                                                        005000
                                                                        005070
                                 # LOOP LIMIT IS NUMBER OF             #005080
                                 # REALMS + NUMBER OF RELATIONS        #005090
      J = SBCWNUMAREAS[0] + SBCWNUMRELS[0];                             005100
                                 # SEARCH FOR MATCH                    #005110
      FOR I = 0 STEP 1 WHILE REALMORDINAL LS J DO                       005120
        BEGIN                                                           005130
          REALMORDINAL = REALMORDINAL + 1;                              005140
          IF RLMNAME30[0] EQ REALMLSTNM30[I]                            005150
          THEN                                                          005160
            BEGIN                                                       005170
                                 # THIS FIELD IS 0 ONLY FOR RELATIONS  #005180
              IF REALMRECLIST[I] EQ 0                                   005190
              THEN                                                      005200
                BEGIN                                                   005210
                  RELFLAG = TRUE;                                       005220
                  RELATIONORD = REALMORDINAL - SBCWNUMAREAS[0];         005230
                END                                                     005240
              STDYES;                                                   005250
          END                                                           005260
        END                                                             005270
      STDNO;                                                            005280
                                                                        005290
SAVEREALM:                                                              005300
#**********************************************************************#005310
#                                                                      #005320
#                   S A V E R E A L M                                  #005330
#                                                                      #005340
#     SAVES REALM OR RELATION NAME IN REALMNAME                        #005350
#     RETURNS TO STDYES.                                               #000360
#                                                                      #005380
#**********************************************************************#005390
                                                                        005400
      REALMNAME[0] = 0;          # ZERO OUT REALM NAME                 #005540
      REALMNAME[1] = 0;                                                 005550
      REALMNAME[2] = 0;                                                 005560
                                                                        005570
                                 # SAVE REALM NAME                     #005580
      FOR I=0 STEP 1 UNTIL CURLENW-1 DO                                 005590
        REALMNAME[I] = CURWORD[I];                                      005600
                                                                        005610
      STDYES;                    # RETURN YES                          #005620
                                                                        005630
ACCESSREALM:                                                            005640
#**********************************************************************#005650
#                                                                      #005660
#                  A C C E S S R E A L M                               #005670
#                                                                      #005680
#     CALLED TO READ A REALM OR RELATION ENTRY FROM SS. A DIRECTORY    #005690
#     ACCESS ROUTINE IS CALLED TO READ THE FIRST 2 WORDS OF            #005700
#     THE REALM ENTRY INTO ARRAY REALMENTRY. IF DASTATE IS 3 AFTER     #005710
#     THE DAR CALL, A RELATION ENTRY HAS BEEN READ. THE RELATION       #005720
#     FLAG IS TURNED ON AND THE RELATION ORDINAL IS SAVED IN           #005730
#     RELATIONORD. IN THE CASE OF A REALM, THE ORDINAL IS SAVED        #005740
#     IN REALMORDINAL. RETURN TO STDYES ON A SUCCESSFUL READ.          #005750
#**********************************************************************#005760
                                                                        005770
                                 # ZERO OUT DAPART SO 1ST 2 WORDS      #005780
                                 # OF REALM ENTRY WILL BE READ         #005790
      DAPART[0] = 0;                                                    005800
                                                                        005810
                                                                        005820
                                 # CALL DER RTN TO READ 1ST 2 WORDS    #005830
                                 # OF REALM ENTRY                      #005840
                                                                        005850
      DE$ARSB (RLMNAME,          # REALM NAME                          #005860
               REALMENTRY,       # AREA TO READ INTO                   #005870
               2);               # NUMBER OF WORDS TO READ             #005880
                                                                        005890
                                 # CHECK FOR UNSUCCESSFUL READ         #005900
      IF DASTATE [0] EQ 1        # REALM NOT FOUND                     #005910
      THEN                                                              005920
        STDNO;                   # RETURN NO                           #005930
                                                                        005940
                                 # HAS RELATION ENTRY BEEN READ?       #005950
      IF DASTATE[0] EQ 3                                                005960
      THEN                                                              005970
        BEGIN                                                           005980
          RELFLAG = TRUE;                                               005990
          RELATIONORD = RELORD[0];                                      006000
        END                                                             006010
      ELSE                                                              006020
        REALMORDINAL = SBARORDINAL[0];                                  006030
                                                                        006040
      STDYES;                    # RETURN YES ON SUCCESSFUL READ       #006050
                                                                        006060
MODESTORE:                                                              006070
#**********************************************************************#006080
#                                                                      #006090
#                    M O D E S T O R E                                 #006100
#                                                                      #006110
#     THIS ROUTINE IS CALLED WHEN MODE IS SPECIFIED                    #006120
#     ON AN OPEN STATEMENT. IT STORES THE MODE INTO THE                #006130
#     CALL TO DMLOPEN. RETURN IS TO STDNO IF OPEN RELATION AND MODE =O #
#     ELSE, RETURN IS TO STDYES.                                       #
  
#                                                                      #006150
#**********************************************************************#006160
                                                                        006170
      IF RELFLAG                  # IF OPEN RELATION                   #
      THEN
        BEGIN 
        C<37,2>OPENREL = MODE;
                                  # IF MODE = O , RETURN TO STDNO      #
        IF C<0,1>MODE EQ "O"
        THEN
          STDNO;
        END 
  
      ELSE                        # IT IS OPEN AREA                    #
        C<33,2>CALLOPN = MODE;
  
      STDYES; 
  
  
                                                                        006300
OPENCALL:                                                               006310
#**********************************************************************#006320
#                                                                      #006330
#                    O P E N C A L L                                   #006340
#                                                                      #006350
#     THIS ROUTINE WRITES CALL TO DMLOPN ON DMLOUT.                    #006360
#                                                                      #
#     THE CALL STATEMENT IS:                                           #
#            " CALL DMLOPN (FIT,REALM ORDINAL,MODE,ERRRTN) "           #
#                                                                      #
#     IF AN *ON ERROR* ALTERNATE RETURN IS SPECIFIED ERRRTN WILL       #
#     HOLD THE LABEL SPECIFIED, ELSE IT WILL BE BLANKED OUT.           #
#     THE REALM ORDINAL IS CONVERTED TO DISPLAY AND STORED             #006380
#     IN THE CALL STATEMENT. WDMLOUT IS CALLED TO WRITE THE            #006390
#     STATEMENT. THE MODE IS RESET TO THE DEFAULT OF IO AND            #006400
#     RETURN IS TO STDYES.                                             #006410
#                                                                      #006420
#**********************************************************************#006430
                                                                        006440
      IF RELFLAG                 # IF RELFLAG IS SET THEN IT IS AN     #
      THEN                       # OPEN RELATION CALL                  #
        GOTO RELOPEN; 
  
                                 # PICK UP REALM ORDINAL               #006450
      I = REALMORDINAL;                                                 006460
                                 # CALL PROC TO CONVERT ORDINAL        #006470
                                 # TO DISPLAY CODE                     #006480
      ORDCONVERT;                                                       006490
                                                                        006500
                                 # PUT ORDINAL IN CALL STMT            #006510
      C<21,4>CALLOPN = C<1,4>DISPLAYORD;                                000290
      C<26,4>CALLOPN = C<1,4>DISPLAYORD;                                000300
                                                                        006540
                                 # MOVE LABEL FROM DML STMT TO CALL    #000380
      C<0,5>CALLOPN = CURLABEL;                                         000390
  
      IF C<0,1>ERRSAVE EQ "*"    # IF ERRSAVE CONTAINS A VALID LABEL   #
      THEN
        BEGIN 
        C<35,8>CALLOPN = ",      )";  # INSERT COMMA AND RIGHT PAREN   #
        C<36,6>CALLOPN = ERRSAVE;# STORE THE LABEL IN ERRRTRN          #
        END 
      ELSE                       #                 ELSE                #
        C<35,8>CALLOPN = ") ";   # OVERWRITE ERRRTRN PARAMETER         #
  
      ERRSAVE = "NUTHIN";        # RESET ERRSAVE                       #
                                 # WRITE CALL STMT TO DMLOUT           #006550
      WDMLOUT (CALLOPN,70); 
                                 # RESET MODE DEFAULT                  #006570
      C<33,2>CALLOPN = "IO";                                            000320
  
      STDYES;                    # RETURN YES                          #006590
                                                                        006600
                                                                        006610
RELOPEN:  
#**********************************************************************#
#                                                                      #
#                    R E L O P E N                                     #
#                                                                      #
#     THIS ROUTINE WRITES CALL TO DMLOPNR ON DMLOUT.                   #
#                                                                      #
#     THE CALL STATEMENT IS:                                           #
#             " CALL DMLOPNR (FITLIST,REALMORD,MODE,ERRRTN) "          #
#                                                                      #
#     IF AN *ON ERROR* ALTERNATE RETURN IS SPECIFIED ERRRTN WILL       #
#     HOLD THE LABEL SPECIFIED, ELSE IT WILL BE BLANKED OUT.           #
#     WDMLOUT IS CALLED TO WRITE THE STATEMENT. THE MODE IS RESET TO   #
#     THE DEFAULT OF "IO". RELFLAG IS SET TO FALSE, AND RETURN IS TO   #
#     STDYES.                                                          #
#                                                                      #
#**********************************************************************#
  
      I = RELATIONORD;           # PICK UP RELATION ORDINAL            #
      ORDCONVERT;                # AND CONVERT TO DISPLAY CODE         #
      DISPLAYORD = C<1,4>DISPLAYORD;
      C<22,4>OPENREL = DISPLAYORD;
      C<30,4>OPENREL = DISPLAYORD;
  
      C<0,5>OPENREL = CURLABEL;  # MOVE LABEL FROM DML STMT TO CALL    #
  
      IF C<0,1>ERRSAVE EQ "*"    # IF ERRSAVE CONTAINS A VALID LABEL   #
      THEN
        BEGIN 
        C<39,8>OPENREL = ",      )";  # INSERT COMMA AND RIGHT PAREN   #
        C<40,6>OPENREL = ERRSAVE;# STORE THE LABEL IN ERRRTRN          #
        END 
      ELSE                       #              ELSE                   #
        C<39,8>OPENREL = ") ";   # OVERWRITE ERRRTRN PARAMETER         #
  
      ERRSAVE = "NUTHIN";        # RESET ERRSAVE                       #
                                 # WRITE CALL STMT TO DMLOUT           #
      WDMLOUT (OPENREL,70); 
  
      C<37,2>OPENREL = "IO";     # RESET DEFAULT MODE TO IO            #
      RELFLAG = FALSE;           # RESET RELFLAG                       #
      STDYES;                    # RETURN TO STDYES                    #
  
  
CLOSECALL:                                                              006620
#**********************************************************************#006630
#                                                                      #006640
#                    C L O S E C A L L                                 #006650
#                                                                      #006660
#     THIS ROUTINE WRITES CALL TO DMLCLS ON DMLOUT.                    #006670
#                                                                      #
#     THE CALL STATEMENT IS:                                           #
#            " CALL DMLCLS (FIT,REALM ORDINAL,ERRRTN) "                #
#                                                                      #
#     IF AN *ON ERROR* ALTERNATE RETURN IS SPECIFIED ERRRTN WILL       #
#     HOLD THE LABEL SPECIFIED, ELSE IT WILL BE BLANKED OUT.           #
#     THE REALM ORDINAL IS CONVERTED INTO DISPLAY CODE AND STORED      #006690
#     IN THE CALL STATEMENT. THE STATEMENT IS WRITTEN TO DMLOUT AND    #006700
#     RETURN IS TO STDYES.                                             #006710
#                                                                      #006720
#**********************************************************************#006730
                                                                        006740
      IF RELFLAG                 # IF RELFLAG IS SET THEN IT IS A      #
      THEN                       # CLOSE RELATION CALL                 #
        GOTO CLOSEREL;
  
      I = REALMORDINAL;          # PICK UP REALM ORDINAL               #006750
                                 # CALL PROC TO CONVERT ORDINAL        #006760
                                 # TO DISPLAY CODE                     #006770
      ORDCONVERT;                                                       006780
                                 # PUT ORDINAL IN CALL STMT            #006790
      C<21,4>CALLCLS = C<1,4>DISPLAYORD;                                000380
      C<26,4>CALLCLS = C<1,4>DISPLAYORD;                                000390
                                 # MOVE LABEL FROM DML STMT TO CALL    #000410
      C<0,5>CALLCLS = CURLABEL;                                         000420
  
      IF C<0,1>ERRSAVE EQ "*"    # IF ERRSAVE CONTAINS A VALID LABEL   #
      THEN
        BEGIN 
        C<30,8>CALLCLS = ",      )";  # INSERT COMMA AND RIGHT PAREN   #
        C<31,6>CALLCLS = ERRSAVE;# STORE THE LABEL IN ERRRTRN          #
        END 
      ELSE                       #                 ELSE                #
        C<30,8>CALLCLS = ") ";   # OVERWRITE ERRRTRN PARAMETER         #
  
      ERRSAVE = "NUTHIN";        # RESET ERRSAVE                       #
                                 # WRITE CALL STMT TO DMLOUT           #006820
      WDMLOUT (CALLCLS,45); 
                                                                        006840
      STDYES;                    # RETURN YES                          #006850
                                                                        006860
CLOSEREL: 
#**********************************************************************#
#                                                                      #
#                     C L O S E R E L                                  #
#                                                                      #
#     THIS ROUTINE WRITES CALL TO DMLCLSR TO DMLOUT.                   #
#                                                                      #
#     THE CALL STATEMENT IS:                                           #
#            " CALL DMLCLSR (FIT,REALM ORDINAL LIST,ERRRTN) "          #
#                                                                      #
#     IF AN *ON ERROR* ALTERNATE RETURN IS SPECIFIED ERRRTN WILL       #
#     HOLD THE LABEL SPECIFIED, ELSE IT WILL BE BLANKED OUT.           #
#     WDMLOUT IS CALLED TO WRITE THE STATEMENT. RELFLAG IS SET TO      #
#     FALSE AND RETURN IS TO STDYES.                                   #
#                                                                      #
#**********************************************************************#
  
      I = RELATIONORD;           # PICK UP RELATION ORDINAL AND        #
      ORDCONVERT;                # CONVERT TO DISPLAY CODE             #
      DISPLAYORD = C<1,4>DISPLAYORD;
      C<22,4>CLOSREL = DISPLAYORD;
      C<30,4>CLOSREL = DISPLAYORD;
      C<0,5>CLOSREL = CURLABEL;  # MOVE LABEL FROM DML STMT TO CALL    #
  
      IF C<0,1>ERRSAVE EQ "*"    # IF ERRSAVE CONTAINS A VALID LABEL   #
      THEN
        BEGIN 
        C<34,8>CLOSREL = ",      )";  # INSERT COMMA AND RIGHT PAREN   #
        C<35,6>CLOSREL = ERRSAVE;# STORE THE LABEL IN ERRRTRN          #
        END 
      ELSE                       #                 ELSE                #
        C<34,8>CLOSREL = ") ";   # OVERWRITE ERRRTRN PARAMETER         #
  
      ERRSAVE = "NUTHIN";        # RESET ERRSAVE                       #
                                 # WRITE CALL STMT TO DMLOUT           #
      WDMLOUT (CLOSREL,70); 
  
      RELFLAG = FALSE;           # RESET RELFLAG                       #
      STDYES;                    # RETURN                              #
  
  
STARTCALL:  
#**********************************************************************#
#                                                                      #
#                          S T A R T C A L L                           #
#                                                                      #
#     THIS ROUTINE WRITES A START CALL TO DMLSTR ON DMLOUT             #
#                                                                      #
#     THE CALL STATEMENT IS:                                           #
#     "CALL DMLSTR(FIT,REALM ORDINAL,KEY ORDINAL,RECORD ORDINAL,RELA-  #
#     TIONAL OPERATOR,KEY LENGTH,KEY TYPE,RKW,RKP,MKL,KEY NAME,        #
#     ERRRTRN)"                                                        #
#                                                                      #
#     THE RELATION FLAG IS TESTED TO DETERMINE IF A RELATION IS BEING  #
#     PROCESSED. IF SO, CONTROL IS TRANSFERRED TO RSTCALL. THE AREA,   #
#     KEY, AND RECORD ORDINALS ARE CONVERTED TO DISPLAY AND STORED INTO#
#     THE STATEMENT, AS ARE THE KEY LENGTH, MAJOR KEY LENGTH AND TYPE  #
#     AND THE RKW AND RKP FIELDS. IF AN *ON ERROR* ALTERNATE RETURN IS #
#     SPECIFIED ERRRTRN WILL HOLD THE LABEL SPECIFIED, ELSE IT WILL BE #
#     BLANKED OUT. THE STATEMENT LABEL, IF ANY, IS ADDED, FLAGS ARE    #
#     RESET AND THE RELATIONAL OPERATOR IS STORED. FINALLY, WDMLOUT IS #
#     CALLED TO WRITE THE CALL TO DMLOUT.                              #
#     RETURN IS TO STDYES.                                             #
#                                                                      #
#**********************************************************************#
  
      IF NOT(RELFLAG)            # CHECK FOR START REALM               #
                                 # NO, GO TO START RELATION ROUTINE    #
      THEN
        BEGIN 
                                 # PICK UP VALUES, CONVERT TO DISPLAY  #
                                 # AND STORE THEM IN THE CALL STATEMENT#
        I = REALMORDINAL; 
        ORDCONVERT; 
        C<21,4>CALLSTR = C<1,4>DISPLAYORD;  # FIT                      #
        C<26,4>CALLSTR = C<1,4>DISPLAYORD;  # REALM ORDINAL            #
  
        I = KEYORDINAL; 
        ORDCONVERT; 
        C<31,5>CALLSTR = C<0,5>DISPLAYORD;  # KEY ORDINAL              #
  
        I = RECORDINAL; 
        ORDCONVERT; 
        C<37,4>CALLSTR = C<1,4>DISPLAYORD;  # RECORD ORDINAL           #
  
        I = KEYLENGTH;
        ORDCONVERT; 
        C<44,4>CALLSTR = C<1,4>DISPLAYORD;  # KEY LENGTH               #
  
        I = KEYTYPE;
        ORDCONVERT; 
        C<49,1>CALLSTR = C<4,1>DISPLAYORD;  # KEY TYPE                 #
  
        I = RKW;
        ORDCONVERT; 
        C<51,4>CALLSTR = C<1,4>DISPLAYORD;  # RKW                      #
  
        I = RKP;
        ORDCONVERT; 
        C<56,2>CALLSTR = C<3,2>DISPLAYORD;  # RKP                      #
  
        I = MKL;
        ORDCONVERT; 
        C<59,4>CALLSTR = C<1,4>DISPLAYORD;  # MKL                      #
  
                                 # NO CONVERSION ON REST OF PARAMETERS #
  
        C<42,1>CALLSTR = KEYCODE;# KEY CODE                            #
  
        C<6,7>CALLSTR1 = C<0,KEYITEMSIZE>KEYITEM;   # KEY NAME         #
  
        C<0,5>CALLSTR = CURLABEL;# STATEMENT LABEL (IF ANY)            #
  
        IF C<0,1>ERRSAVE EQ "*"  # IF ERRSAVE CONTAINS A VALID LABEL   #
        THEN
          BEGIN 
          C<13,8>CALLSTR1 = ",      )";  # INSERT COMMA AND RIGHT PAREN#
          C<14,6>CALLSTR1 = ERRSAVE;  # STORE THE LABEL IN ERRRTRN     #
          END 
        ELSE                     #              ELSE                   #
          BEGIN 
          C<13,8>CALLSTR1 = ") ";# OVERWRITE ERRRTRN PARAMETER         #
          END 
  
        ERRSAVE = "NUTHIN";      # RESET ERRSAVE                       #
        STKEYFLAG = TRUE;        # RESET START KEY FLAG                #
  
        WDMLOUT(CALLSTR,70);     # WRITE CALL STATEMENT                #
        WDMLOUT(CALLSTR1,45); 
  
        STDYES;                  # RETURN TO STDYES                    #
  
        END 
      ELSE
        BEGIN 
  
RSTCALL:  
#**********************************************************************#
#                                                                      #
#                             R S T C A L L                            #
#                                                                      #
#     THIS ROUTINE WRITES A RELATION START CALL TO DMLRST ON DMLOUT.   #
#                                                                      #
#     THE CALL STATEMENT IS:                                           #
#     "CALL DMLRST(FIT,RELATION ORDINAL,KEY ORDINAL,RECORD ORDINAL,    #
#     RELATION OPERATOR,KEY LENGTH,KEY TYPE,RKW,RKP,MKL,KEY NAME,ROOT  #
#     ORDINAL,ERRRTRN)"                                                #
#                                                                      #
#     THE RELATION, KEY, RECORD AND ROOT ORDINALS ARE CONVERTED        #
#     TO DISPLAY AND STORED INTO THE STATEMENT AS ARE THE KEY LENGTH   #
#     AND MAJOR KEY LENGTH AND TYPE, AND THE RKW AND RKP FIELDS. IF AN #
#     *ON ERROR* ALTERNATE RETURN IS SPECIFIED, ERRRTRN WILL HOLD THE  #
#     LABEL SPECIFIED, ELSE, IT WILL BE BLANKED OUT. THE STATEMENT     #
#     LABEL, IF ANY, IS ADDED, FLAGS ARE RESET AND THE RELATIONAL      #
#     OPERATOR IS STORED.                                              #
#     FINALLY, WDMLOUT IS CALLED TO WRITE THE CALL STATEMENT TO        #
#     DMLOUT.                                                          #
#     RETURN IS TO STDYES.                                             #
#                                                                      #
#**********************************************************************#
  
                                 # PICK UP VALUES, CONVERT TO DISPLAY  #
                                 # AND STORE THEM IN THE CALL STATEMENT#
        I = RELATIONORD;
        ORDCONVERT; 
        C<21,4>CALLRST = C<1,4>DISPLAYORD;  # FIT                      #
        C<26,4>CALLRST = C<1,4>DISPLAYORD;  # RELATION ORDINAL         #
  
        I = KEYORDINAL; 
        ORDCONVERT; 
        C<31,5>CALLRST = C<0,5>DISPLAYORD;  # KEY ORDINAL              #
  
        I = RECORDINAL; 
        ORDCONVERT; 
        C<37,4>CALLRST = C<1,4>DISPLAYORD;  # RECORD ORDINAL           #
  
        I = KEYLENGTH;
        ORDCONVERT; 
        C<44,4>CALLRST = C<1,4>DISPLAYORD;  # KEY LENGTH               #
  
        I = KEYTYPE;
        ORDCONVERT; 
        C<49,1>CALLRST = C<4,1>DISPLAYORD;  # KEY TYPE                 #
  
        I = RKW;
        ORDCONVERT; 
        C<51,4>CALLRST = C<1,4>DISPLAYORD;  # RKW                      #
  
        I = RKP;
        ORDCONVERT; 
        C<56,2>CALLRST = C<3,2>DISPLAYORD;  # RKP                      #
  
        I = MKL;
        ORDCONVERT; 
        C<59,4>CALLRST = C<1,4>DISPLAYORD;  # MKL                      #
  
        I = REALMORDINAL; 
        ORDCONVERT; 
        C<15,4>CALLRST1 = C<1,4>DISPLAYORD; # REALM ORDINAL -ROOT FILE #
  
                                 # NO CONVERSION ON REST OF PARAMETERS #
  
        C<42,1>CALLRST = KEYCODE;# KEY CODE                            #
  
        C<6,7>CALLRST1 = C<0,KEYITEMSIZE>KEYITEM;   # KEY NAME         #
  
        C<0,5>CALLRST = CURLABEL;# STATEMENT LABEL (IF ANY)            #
  
        IF C<0,1>ERRSAVE EQ "*"  # IF ERRSAVE CONTAINS A VALID LABEL   #
        THEN
          BEGIN 
          C<19,8>CALLRST1 = ",      )"; # INSERT COMMA AND RIGHT PAREN #
          C<20,6>CALLRST1 = ERRSAVE;    # STORE THE LABEL IN ERRRTRN   #
          END 
        ELSE                     #              ELSE                   #
          BEGIN 
          C<19,8>CALLRST1 = ") ";# OVERWRITE ERRRTRN PARAMETER         #
          END 
  
        ERRSAVE = "NUTHIN";      # RESET ERRSAVE                       #
        STKEYFLAG = TRUE;        # RESET START KEY FLAG                #
  
        WDMLOUT(CALLRST,70);     # WRITE CALL STATEMENT                #
        WDMLOUT(CALLRST1,45); 
  
        STDYES;                  # RETURN TO STDYES                    #
  
        END 
READCALL:                                                               006870
#**********************************************************************#006880
#                                                                      #006890
#                    R E A D C A L L                                   #006900
#                                                                      #006910
#     THIS ROUTINE WRITES THE CALL STATEMENT TO DMLRD ON DMLOUT.       #006920
#                                                                      #
#     THE CALL STATEMENT IS:                                           #
#     "CALL DMLRD(FIT,REALM ORDINAL,ERRFLAG,ENDFLAG,ERRRTN,ENDRTN)"    #
#                                                                      #
#     IF AN *ON ERROR* AND/OR *ON END* ALTERNATE RETURN IS SPECIFIED   #
#     ERRRTN OR ENDRTN WILL HOLD THE APPROPRIATE LABEL, ELSE THE       #
#     PARAMETER NOT SPECIFIED WILL BE BLANKED OUT FROM THE CALL STMT.  #
#     FIRST THE RELATION FLAG IS TESTED TO DETERMINE                   #006940
#     IF A READ RELATION IS BEING PROCESSED. IF SO,                    #006950
#     CONTROL IS TRANSFERRED TO RELCALL.                               #006960
#     IF A READ WITH KEY IS BEING PROCESSED, CONTROL                   #006970
#     IS TRANSFERRED TO READKCALL.                                     #006980
#     THE REALM ORDINAL IS CONVERTED TO DISPLAY CODE AND STORED IN     #006990
#     THE CALL STATEMENT. THE CALL STATEMENT IS WRITTEN TO DMLOUT      #007000
#     AND RETURN IS TO STDYES.                                         #007010
#                                                                      #007020
#**********************************************************************#007030
                                                                        007040
                                 # CHECK FOR READ RELATION             #007050
      IF RELFLAG                                                        007060
      THEN                                                              007070
        GOTO  RELCALL;           # ROUTINE TO WRITE CALL TO DMLRL      #007080
                                                                        007090
                                 # CHECK FOR READ WITH KEY             #007100
      IF KEYFLAG                                                        007110
      THEN                                                              007120
        GOTO  READKCALL;                                                007130
                                                                        007140
                                 # PICK UP AREA ORDINAL                #007150
      I = REALMORDINAL;                                                 007160
                                 # CONVERT ORDINAL TO DISPLAY          #007170
      ORDCONVERT;                                                       007180
                                 # PUT ORDINAL IN CALL STMT            #007190
      C<20,4>CALLRD = C<1,4>DISPLAYORD;                                 000430
      C<25,4>CALLRD = C<1,4>DISPLAYORD;                                 000440
                                                                        007220
                                 # MOVE LABEL FROM DML STMT TO CALL    #000440
      C<0,5>CALLRD = CURLABEL;                                          000450
  
                                 #        ERRRTRN PARAMETER            #
      IF C<0,1>ERRSAVE EQ "*"    # IF ERRSAVE CONTAINS A VALID LABEL   #
      THEN
        BEGIN 
        C<30,1>CALLRD = "1";     # SET ERRFLAG TO TRUE                 #
        C<33,1>CALLRD = ",";
        C<34,6>CALLRD = ERRSAVE; # STORE THE LABEL IN ERRRTRN          #
        PARMLOC = 40;            # SET THE LOC OF NEXT PARAM AFTER ERR #
        END 
      ELSE                       #                 ELSE                #
        BEGIN 
        C<30,1>CALLRD = "0";     # SET ERRFLAG TO FALSE                #
        PARMLOC = 33;            # SET THE LOC OF NEXT PARAM BEFORE ERR#
        END 
  
                                 #           END PARAMETER             #
      IF C<0,1>ENDSAVE EQ "*"    # IF ENDSAVE CONTAINS A VALID LABEL   #
      THEN
        BEGIN 
        C<32,1>CALLRD = "1";     # SET ENDFLAG TO TRUE                 #
        C<PARMLOC,1>CALLRD = ",";# PLACE COMMA TO CONTINUE PARAMETERS  #
        C<PARMLOC+1,6>CALLRD = ENDSAVE; # INSERT ENDRTRN PARAMETER     #
        C<PARMLOC+7,8>CALLRD = ") ";  # INSERT END PARENTHESIS         #
                                      # AND BLANK OUT REST OF STMT     #
        END 
      ELSE                       #               ELSE                  #
        BEGIN 
        C<32,1>CALLRD = "0";     # SET ENDFLAG TO FALSE                #
        C<PARMLOC,15>CALLRD = ") ";  # TERMINATE CALL STMT AT LAST PARM#
                                     # AND BLANK OUT REST OF STMT      #
        END 
                                 # RESET LABEL STORAGE AREAS           #
      ENDSAVE = "NUTHIN"; 
      ERRSAVE = "NUTHIN"; 
                                 # WRITE CALL STATEMENT                #007230
      WDMLOUT (CALLRD,70);
                                                                        007250
      STDYES;                    # RETURN YES                          #007260
                                                                        007270
READKCALL:                                                              007280
#**********************************************************************#007290
#                                                                      #007300
#                     R E A D K C A L L                                #007310
#                                                                      #007320
#     WRITES CALL STATEMENT TO DMLRDK ON DMLOUT.                       #007330
#     THE CALL STATEMENT IS "CALL DMLRDK(FIT, REALM                    #007340
#     ORDINAL,KEY ORDINAL, RECORD ORDINAL,RELATIONAL                   #007350
#     OPERATOR, KEY LENGTH, KEY TYPE, RKW, RKP, KEYNAME, ERRRTN) "     #
#     IF AN *ON ERROR* ALTERNATE RETURN IS SPECIFIED ERRRTN WILL       #
#     HOLD THE LABEL SPECIFIED, ELSE IT WILL BE BLANKED OUT.           #
#     THE AREA ORDINAL, KEY ORDINAL, RECORD ORDINAL ARE                #007370
#     CONVERTED TO DISPLAY AND STORED IN THE CALL STMT. THE            #007380
#     RELATIONAL OPERATOR CODE IS STORED IN THE STMT.  THE             #007390
#     KEY LENGTH, KEY TYPE, RKW, AND RKP FIELDS ARE CONVERTED          #007400
#     TO DISPLAY AND STORED IN THE CALL STATEMENT.                     #007410
#                      FLAGS ARE RESET, THE CALL STATEMENT IS          #007430
#     WRITTEN ON DMLOUT AND RETURN IS TO STDYES.                       #007440
#                                                                      #007450
#**********************************************************************#007460
                                                                        007470
                                 # PICK UP REALM ORDINAL               #007480
      I = REALMORDINAL;                                                 007490
                                 # CONVERT IT TO DISPLAY               #007500
      ORDCONVERT;                                                       007510
                                 # PUT IT IN CALL STATEMENT            #007520
      C<21,4>CALLRDK = C<1,4>DISPLAYORD;                                000480
      C<26,4>CALLRDK = C<1,4>DISPLAYORD;                                000490
                                 # PICK UP KEY ORDINAL                 #007550
      I = KEYORDINAL;                                                   007560
                                 # CONVERT IT TO DISPLAY               #007570
      ORDCONVERT;                                                       007580
                                                                        007590
                                 # PUT IT IN CALL STATEMENT            #007600
      C<31,5>CALLRDK = C<0,5>DISPLAYORD;                                000510
                                                                        007620
                                 # PICK UP RECORD ORDINAL              #007630
      I = RECORDINAL;                                                   007640
                                 # CONVERT IT TO DISPLAY               #007650
      ORDCONVERT;                                                       007660
                                                                        007670
                                 # PUT IT IN CALL STATEMENT            #007680
      C<37,4>CALLRDK = C<1,4>DISPLAYORD;                                000530
                                                                        007700
                                 # PUT RELATION OP IN CALL STATEMENT   #007710
      C<42,1>CALLRDK = KEYCODE;                                         000550
                                                                        007730
                                 # PICK UP KEY LENGTH                  #007732
      I = KEYLENGTH;                                                    007734
                                 # CONVERT IT TO DISPLAY               #007736
      ORDCONVERT;                                                       007738
                                 # PUT IT IN CALL STATEMENT            #007740
      C<44,4>CALLRDK = C<1,4>DISPLAYORD;                                000570
                                 # PICK UP KEY TYPE, RKW, AND RKP      #007744
      I = KEYTYPE;                                                      007746
      ORDCONVERT;                                                       007748
      C<49,1>CALLRDK = C<4,1>DISPLAYORD;                                000590
                                                                        007752
      I = RKW;                                                          007754
      ORDCONVERT;                                                       007756
      C<51,4>CALLRDK = C<1,4>DISPLAYORD;                                000610
                                                                        007760
      I = RKP;                                                          007762
      ORDCONVERT;                                                       007764
      C<56,2>CALLRDK =C<3,2>DISPLAYORD;                                 000630
                                                                        007768
                                 # STORE KEY NAME INTO CALL STMT       #000190
      C<6,7>CALLRDK1 = C<0,KEYITEMSIZE>KEYITEM; 
                                                                        007970
                                 # RESET KEY FLAG                      #007980
      KEYFLAG = FALSE;                                                  008000
                                                                        008010
                                 # MOVE LABEL FROM DML STMT TO CALL    #000470
      C<0,5>CALLRDK = CURLABEL;                                         000480
  
      IF C<0,1>ERRSAVE EQ "*"    # IF ERRSAVE CONTAINS A VALID LABEL   #
      THEN
        BEGIN 
        C<13,8>CALLRDK1 = ",      )";  # INSERT COMMA AND RIGHT PAREN  #
        C<14,6>CALLRDK1 = ERRSAVE;  # STORE THE LABEL IN ERRRTRN       #
        END 
      ELSE                       #                 ELSE                #
        C<13,8>CALLRDK1 = ") ";  # OVERWRITE ERRRTRN PARAMETER         #
  
      ERRSAVE = "NUTHIN";        # RESET ERRSAVE                       #
      ENDSAVE = "NUTHIN";        # RESET ENDSAVE                       #
                                 # WRITE CALL STATEMENT                #008020
      WDMLOUT(CALLRDK,70);
      WDMLOUT(CALLRDK1,45); 
                                 # RETURN YES                          #008040
      STDYES;                                                           008050
                                                                        008060
  
SAVBEGID: 
#**********************************************************************#
#                                                                      #
#           S A V B E G I D                                            #
#                                                                      #
#     CHECK FOR THE VALIDITY OF BEGIN TRANSACTION IDENTIFIER           #
#     AND STORE IT IN LOCAL VARIABLE BEGINID                           #
#                                                                      #
#**********************************************************************#
      BEGINID = " ";               # PRESET BEGINID TO NULL            #
      IF CURLENG LQ 10
      THEN
        BEGIN 
        BEGINID = C<0,CURLENG>CURWRD30[0];   # STORE IDENTIFIER IN TEMP#
        STDYES; 
        END 
      ELSE
        BEGIN 
        DIAGDL(132);               # LONGER THAN 10 CHARACTERS         #
        STDNO;
        END 
  
  
BEGINCALL:  
#**********************************************************************#
#                                                                      #
#           B E G I N C A L L                                          #
#                                                                      #
#     THIS ROUTINE WRITES A CALL TO DMLBEG ON DMLOUT                   #
#                                                                      #
#     THE CALL STATEMENT IS                                            #
#     "  CALL  DMLBEG(BEGID,ERRRTN)   "                                #
#     WHERE                                                            #
#       BEGID WILL CONTAIN THE BEGINTRAN NAME                          #
#       ERRRTN CONTAINS THE LABEL NAME FOR ALTERNATE RETURN(OPTIONAL)  #
#                                                                      #
#**********************************************************************#
      C<0,5>CALLBEGTRAN = CURLABEL; 
      IF LITFLAG
      THEN
        BEGIN 
        C<18,1>CALLBEGTRAN = """";
        C<29,1>CALLBEGTRAN = """";
        C<19,10>CALLBEGTRAN = C<0,10>BEGINID; 
        END 
      ELSE                         # FTN NAME                          #
        BEGIN 
                                   # INSERT NAME INTO SKELETON         #
        C<18,7>CALLBEGTRAN=C<0,7>BEGINID; 
        C<25,5>CALLBEGTRAN = " "; 
        END 
      IF C<0,1>ERRSAVE EQ "*"      # IF ERRSAVE CONTAINS A VALID LABEL #
      THEN
        BEGIN 
        C<30,8>CALLBEGTRAN =    ",      )"; 
        C<31,6>CALLBEGTRAN = ERRSAVE; 
        END 
      ELSE
        BEGIN 
        C<30,8>CALLBEGTRAN = ") ";
        END 
      ERRSAVE = "NUTHIN"; 
      WDMLOUT(CALLBEGTRAN,40);
      BEGINID = " ";               # RESET BEGINID                     #
      LITFLAG = FALSE;             # RESET LITERAL FLAG                #
      STDYES; 
  
  
SAVRID: 
#**********************************************************************#
#                                                                      #
#         S A V R I D                                                  #
#                                                                      #
#     THIS ROUTINE WILL SAVE THE RESTART IDENTIFIER                    #
#                                                                      #
#**********************************************************************#
      RSTID = C<0,CURLENG>CURWRD30[0];  # SAVE RESTART IDENTIFIER      #
      STDYES; 
  
  
ASSIGNCALL: 
#**********************************************************************#
#                                                                      #
#       A S S I G N C A L L                                            #
#                                                                      #
#     THIS ROUTINE WRITES THE CALL STATEMENT TO DMLGTID ON DMLOUT.     #
#                                                                      #
#     THE CALL STATEMENT IS                                            #
#     CALL DMLGTID(RSTID,ERRRTN)                                       #
#                                                                      #
#**********************************************************************#
      C<0,5>CALLRSTID = CURLABEL;  # MOVE DML STMT LABEL TO SKELETON   #
      C<19,7>CALLRSTID = RSTID;    # INSERT RESTART ID INTO SKELETON   #
      IF C<0,1>ERRSAVE EQ "*"      # ERRSAVE CONTAINS A VALID LABEL    #
      THEN
        BEGIN                         # INSERT COMMA AND PAREN INTO    #
        C<26,8>CALLRSTID=",      )";  # CALL IF THEY ARE OVERWRITTEN   #
        C<27,6>CALLRSTID=ERRSAVE;  # INSERT ERROR LABEL IN CALL        #
        END 
      ELSE
        BEGIN 
        C<26,8>CALLRSTID = ") ";
        END 
      ERRSAVE = "NUTHIN"; 
      WDMLOUT(CALLRSTID,40);       # WRITE SKELETON TO DMLOUT          #
      RSTID = " ";                 # RESET RSTID                       #
      STDYES; 
  
  
SAVTYP: 
#**********************************************************************#
#                                                                      #
#         S A V T Y P                                                  #
#                                                                      #
#     THIS ROUTINE WILL CHECK THE VALIDITY OF THE TYPE PARAMETER       #
#     IN A DML LOCK STATEMENT.  IF IT IS VALID, THEN STORE IT IN       #
#     A LOCAL VARIABLE TYPID.                                          #
#                                                                      #
#**********************************************************************#
      TYPID = " ";                 # PRESET TYPID TO NULL              #
      IF LITFLAG                   # TYPE PARAMETER IS LITERAL         #
      THEN
        BEGIN 
        IF CURLENG NQ 9 
        THEN
          BEGIN 
          STDNO;                   # INVALID TYPE PARAMETER            #
          END 
        IF (C<0,CURLENG>CURWRD30[0] EQ "EXCLUSIVE"
            OR C<0,CURLENG>CURWRD30[0] EQ "PROTECTED")
        THEN
          BEGIN 
          TYPID = C<0,CURLENG>CURWRD30[0];
          STDYES; 
          END 
        ELSE
          BEGIN 
          STDNO;
          END 
        END 
      ELSE                         # FTN VARIABLE                      #
        BEGIN 
        TYPID = C<0,CURLENG>CURWRD30[0];
        STDYES; 
        END 
  
  
FINDCALL: 
#**********************************************************************#
#                                                                      #
#       F I N D C A L L                                                #
#                                                                      #
#     THIS ROUTINE WRITES CALL TO DMLASK ON DMLOUT.                    #
#                                                                      #
#     THE CALL STATEMENT IS                                            #
#     CALL DMLASK(TYPID,ERRRTN)                                        #
#                                                                      #
#**********************************************************************#
      C<0,5>CALLFIND = CURLABEL;   # MOVE DML STMT LABEL TO SKELETON   #
      C<19,7>CALLFIND = RSTID;     # MOVE RESTART IDENTIFIER INTO      #
                                   # CALL STMT SKELETON                #
      C<27,7>CALLFIND = BEGINID;   # MOVE BEGIN TRANSACTION ID         #
                                   # INTO CALL STMT SKELETON           #
      IF C<0,1>ERRSAVE EQ "*" 
      THEN
        BEGIN                      # INSERT COMMA AND RIGHT PAREN      #
        C<34,8>CALLFIND = ",      )";   # IN CASE THEY ARE OVERWRITTEN #
        C<35,6>CALLFIND = ERRSAVE; # INSERT ERROR LABEL IN CALL STMT   #
        END 
      ELSE
        BEGIN 
        C<34,8>CALLFIND = ") ";    # NO ERROR RETURN LABEL             #
        END 
  
      ERRSAVE = "NUTHIN";          # RESET ERRSAVE                     #
      WDMLOUT(CALLFIND,44);        # WRITE CALL STMT TO DMLOUT         #
      STDYES; 
RECORDORD:                                                              008070
#**********************************************************************#008080
#                                                                      #008090
#                    R E C O R D O R D                                 #008100
#                                                                      #008110
#     THIS ROUTINE IS CALLED WHEN A RECORD ORDINAL IS NEEDED.          #008120
#     A DIRECTORY ACCESS ROUTINE IS CALLED TO READ THE FIRST WORD OF   #008130
#     THE FIRST RECORD ENTRY FOR THE CURRENT REALM. IF THE REALM IS    #008140
#     NOT FOUND, RETURN IS TO STDNO. OTHERWISE RETURN IS TO STDYES.    #008150
#                                                                      #008160
#**********************************************************************#008170
                                 # CALL DER ROUTINE TO READ 1ST WORD   #008180
                                 # OF RECORD ENTRY FOR GIVEN REALM     #008190
      DE$RCSB (RLMNAME,          # NAME OF REALM                       #008200
               RECORDENTRY,      # AREA TO READ INTO                   #008210
              4);                # NUMBER OF WORDS TO READ             #000130
                                                                        008230
      IF DASTATE[0] EQ 1         # REALM ENTRY NOT FOUND               #008240
      THEN                                                              008250
        STDNO;                   # RETURN NO                           #008260
                                                                        008270
      STDYES;                    # RETURN YES ON SUCCESSFUL READ       #008280
                                                                        008290
PKEYORD:                                                                008300
#**********************************************************************#008310
#                                                                      #008320
#                    P K E Y O R D                                     #008330
#                                                                      #008340
#     THIS ROUTINE IS CALLED TO LOCATE THE PRIMARY KEY ORDINAL FOR     #008350
#     A REALM. THE REALM ENTRY CONTAINS THE ADDRESS OF THE DATA        #008360
#     CONTROL ENTRY. A DIRECTORY ACCESS ROUTINE IS CALLED TO READ      #008370
#     1 WORD OF THE DATA CONTROL ENTRY TO FIND THE OFFSET TO THE       #008380
#     KEY PART OF THE DATA CONTROL ENTRY. 3 WORDS OF THE KEY ENTRY     #008390
#     ARE READ TO GET THE WORD ADDRESS OF THE ITEM ENTRY WHICH IS      #008400
#     THE EMBEDDED KEY. THEN 1 WORD OF THE ITEM ENTRY IS READ TO GET   #008410
#     THE ITEM ORDINAL. RETURN IS TO STDYES.                           #008420
#                                                                      #008430
#**********************************************************************#008440
                                                                        008450
                                 # READ IN DATA CONTROL ENTRY FOR REALM#008460
                                                                        008470
                                 # GET WORD ADDR OF DATA CONTROL ENTRY #002440
      DCADDR = SBARDCONTRLA[0];                                         000200
      DE$GTSB (DATACONTROL,      # AREA TO READ INTO                   #008490
               1,                # NUMBER OF WORDS TO READ             #008500
              DCADDR);           # ADDR OF DATA CONTROL ENTRY          #008510
                                                                        008520
      IF DASTATE[0] EQ 1         # ADDRESS OUTSIDE FILE LIMITS         #000390
      THEN                                                              000400
        STDNO;                                                          000410
                                                                        000420
      DCADDR = DCADDR + SBDCALTRKYPT[0]; # ADD OFFSET OF               #008530
                                 # KEY ENTRY TO DATA CONTROL WORD ADDR #008540
                                 # READ KEY PART OF DATA CONTROL ENTRY #008550
      DE$GTSB(KEYENTRY,          # AREA TO READ INTO                   #008560
              3,                 # NUMBER OF WORDS TO READ             #008570
              DCADDR);           # ADDRESS TO READ FROM                #008580
                                                                        008590
      IF DASTATE[0] EQ 1         # ADDRESS OUTSIDE FILE LIMITS         #000440
      THEN                                                              000450
        STDNO;                                                          000460
      ITEMADDR = SBDCKEYDNADR[2]; # ADDR OF ITEM ENTRY                 #000220
                                                                        008610
                                 # READ 1 WORD OF ITEM ENTRY           #008620
                                                                        008630
      DE$GTSB (ITEMENTRY,        # AREA TO READ INTO                   #008640
               1,                # NUMBER OF WORDS TO READ             #008650
               ITEMADDR);        # ADDR TO READ FROM                   #008660
                                                                        008670
      IF DASTATE[0] EQ 1         # ADDRESS OUTSIDE FILE LIMITS         #000480
      THEN                                                              000490
        STDNO;                                                          000500
      STDYES;                    # RETURN YES                          #008680
                                                                        008690
WRITECALL:                                                              008700
#**********************************************************************#008710
#                                                                      #008720
#                    W R I T E C A L L                                 #008730
#                                                                      #008740
#     THIS ROUTINE WRITES CALL STATEMENT TO DMLWRT ON DMLOUT.          #008750
#                                                                      #
#     THE CALL STATEMENT IS:                                           #
#     "CALL DMLWRT (FIT,0,RECORD ORDINAL,PRIMARY KEY ORDINAL,ERRRTN) " #
#                                                                      #
#     IF AN *ON ERROR* ALTERNATE RETURN IS SPECIFIED ERRRTN WILL       #
#     HOLD THE LABEL SPECIFIED, ELSE IT WILL BE BLANKED OUT.           #
#     THE AREA ORDINAL, RECORD ORDINAL, AND PRIMARY KEY                #008780
#     ORDINAL ARE CONVERTED TO DISPLAY CODE AND STORED IN THE CALL     #008790
#     STATEMENT. THE STATEMENT IS WRITTEN ON DMLOUT AND RETURN IS      #008800
#     TO STDYES.                                                       #008810
#                                                                      #008820
#**********************************************************************#008830
      I = REALMORDINAL;          # REALM ORDINAL                       #008840
      ORDCONVERT;                # CONVERT IT TO DISPLAY               #008850
                                 # STORE IT IN CALL STATEMENT          #008860
      C<21,4>CALLWRT = C<1,4>DISPLAYORD;                                000650
                                                                        008880
      I = SBRECORDINAL[0];       # RECORD ORDINAL                      #008890
      ORDCONVERT;                # CONVERT IT TO DISPLAY               #008900
                                 # STORE IT IN CALL STATEMENT          #008910
      C<28,4>CALLWRT = C<1,4>DISPLAYORD;                                000670
                                                                        008930
      I = SBITMORDINAL[0];       # PRIMARY KEY ORDINAL                 #008940
      ORDCONVERT;                # CONVERT IT TO DISPLAY               #008950
                                 # STORE IT IN CALL STATEMENT          #008960
      C<33,5>CALLWRT = C<0,5>DISPLAYORD;                                000690
                                 # MOVE LABEL FROM DML STMT TO CALL    #000500
      C<0,5>CALLWRT = CURLABEL;                                         000510
  
      IF C<0,1>ERRSAVE EQ "*"    # IF ERRSAVE CONTAINS A VALID LABEL   #
      THEN
        BEGIN 
        C<38,8>CALLWRT = ",      )";  # INSERT COMMA AND RIGHT PAREN   #
        C<39,6>CALLWRT = ERRSAVE;# STORE THE LABEL IN ERRRTRN          #
        END 
      ELSE                       #                 ELSE                #
        C<38,8>CALLWRT = ") ";   # OVERWRITE ERRRTRN PARAMETER         #
  
      ERRSAVE = "NUTHIN";        # RESET ERRSAVE                       #
                                 # WRITE CALL STATEMENT                #008980
      WDMLOUT (CALLWRT,70); 
                                 # RETURN YES                          #009000
      STDYES;                                                           009010
                                                                        009020
REWRITECALL:                                                            009030
#**********************************************************************#009040
#                                                                      #009050
#                      R E W R I T E C A L L                           #009060
#                                                                      #009070
#     THIS ROUTINE WRITES THE CALL STATEMENT TO DMLREW ON DMLOUT.      #009080
#                                                                      #
#     THE CALL STATEMENT IS:                                           #
#     "CALL DMLREW (FIT,0,RECORD ORDINAL,PRIMARY KEY ORDINAL,ERRRTN) " #
#                                                                      #
#     IF AN *ON ERROR* ALTERNATE RETURN IS SPECIFIED ERRRTN WILL       #
#     HOLD THE LABEL SPECIFIED, ELSE IT WILL BE BLANKED OUT.           #
#     THE AREA ORDINAL, RECORD ORDINAL, AND PRIMARY KEY ORDINAL ARE    #009110
#     CONVERTED TO DISPLAY CODE AND STORED IN THE CALL STATEMENT.  THE #009120
#     STATEMENT IS WRITTEN ON DMLOUT AND RETURN IS TO STDYES.          #009130
#                                                                      #009140
#**********************************************************************#009150
                                                                        009160
      I = REALMORDINAL;          # REALM ORDINAL                       #009170
      ORDCONVERT;                # CONVERT IT TO DISPLAY               #009180
                                 # STORE IT IN CALL STATEMENT          #009190
      C<21,4>CALLREW = C<1,4>DISPLAYORD;                                000710
                                                                        009210
      I = SBRECORDINAL[0];       # RECORD ORDINAL                      #009220
      ORDCONVERT;                # CONVERT IT TO DISPLAY               #009230
                                 # STORE IT IN CALL STATEMENT          #009240
                                                                        009250
      C<28,4>CALLREW = C<1,4>DISPLAYORD;                                000730
                                                                        009270
      I = SBITMORDINAL[0];       # PRIMARY KEY ORDINAL                 #009280
      ORDCONVERT;                # CONVERT IT TO DISPLAY               #009290
                                 # STORE IT IN CALL STATEMENT          #009300
      C<33,5>CALLREW = C<0,5>DISPLAYORD;                                000750
                                 # MOVE LABEL FROM DML STMT TO CALL    #000530
      C<0,5>CALLREW = CURLABEL;                                         000540
  
      IF C<0,1>ERRSAVE EQ "*"    # IF ERRSAVE CONTAINS A VALID LABEL   #
      THEN
        BEGIN 
        C<38,8>CALLREW = ",      )";  # INSERT COMMA AND RIGHT PAREN   #
        C<39,6>CALLREW = ERRSAVE;# STORE THE LABEL IN ERRRTRN          #
        END 
      ELSE                       #                 ELSE                #
        C<38,8>CALLREW = ") ";   # OVERWRITE ERRRTRN PARAMETER         #
  
      ERRSAVE = "NUTHIN";        # RESET ERRSAVE                       #
                                 # WRITE CALL STATEMENT                #009320
      WDMLOUT (CALLREW,70); 
  
      STDYES;                    # RETURN YES                          #009340
DELETECALL:                                                             009350
#**********************************************************************#009360
#                                                                      #009370
#                     D E L E T E C A L L                              #009380
#                                                                      #009390
#     THIS ROUTINE WRITES THE CALL STATEMENT TO DMLDEL ON DMLOUT.      #009400
#                                                                      #
#     THE CALL STATEMENT IS:                                           #
#     "CALL DMLDEL (FIT,0,REALM ORDINAL,PRIMARY KEY ORDINAL,ERRRTN) "  #
#                                                                      #
#     IF AN *ON ERROR* ALTERNATE RETURN IS SPECIFIED ERRRTN WILL       #
#     HOLD THE LABEL SPECIFIED, ELSE IT WILL BE BLANKED OUT.           #
#     THE AREA ORDINAL AND PRIMARY KEY ORDINAL ARE                     #009430
#     CONVERTED TO DISPLAY CODE AND STORED IN THE CALL STATEMENT. THE  #009440
#     STATEMENT IS WRITTEN ON DMLOUT AND RETURN IS TO STDYES.          #009450
#                                                                      #009460
#**********************************************************************#009470
                                                                        009480
      I = REALMORDINAL;          # REALM ORDINAL                       #009490
      ORDCONVERT;                # CONVERT IT TO DISPLAY               #009500
                                 # STORE IT IN CALL STATEMENT          #009510
      C<21,4>CALLDEL = C<1,4>DISPLAYORD;                                000770
      C<28,4>CALLDEL = C<1,4>DISPLAYORD;                                000780
                                                                        009540
      I = SBITMORDINAL[0];       # PRIMARY KEY ORDINAL                 #009550
      ORDCONVERT;                # CONVERT IT TO DISPLAY               #009560
                                 # STORE IT IN CALL STATEMENT          #009570
      C<33,5>CALLDEL = C<0,5>DISPLAYORD;                                000800
                                 # MOVE LABEL FROM DML STMT TO CALL    #000560
      C<0,5>CALLDEL = CURLABEL;                                         000570
  
      IF C<0,1>ERRSAVE EQ "*"    # IF ERRSAVE CONTAINS A VALID LABEL   #
      THEN
        BEGIN 
        C<38,8>CALLDEL = ",      )";  # INSERT COMMA AND RIGHT PAREN   #
        C<39,6>CALLDEL = ERRSAVE;# STORE THE LABEL IN ERRRTRN          #
        END 
      ELSE                       #                 ELSE                #
        C<38,8>CALLDEL = ") ";   # OVERWRITE ERRRTRN PARAMETER         #
  
      ERRSAVE = "NUTHIN";        # RESET ERRSAVE                       #
                                 # WRITE CALL STATEMENT                #009590
      WDMLOUT (CALLDEL,70); 
  
      STDYES;                    # RETURN YES                          #009610
                                                                        009620
RELCALL:                                                                009630
#**********************************************************************#009640
#                                                                      #009650
#                      R E L C A L L                                   #009660
#                                                                      #009670
#     THIS ROUTINE IS CALLED BY READCALL  WHEN A READ RELATION IS      #009680
#     BEING PROCESSED TO WRITE THE CALL STATEMENT TO DMLRL ON DMLOUT.  #009690
#                                                                      #
#     THE CALL STATEMENT IS:                                           #
#     "CALL DMLRL(FIT,RELATION ORD,ERRFLAG,ENDFLAG,ERRRTN,ENDRTN)"     #
#                                                                      #
#     IF AN *ON ERROR* AND/OR *ON END* ALTERNATE RETURN IS SPECIFIED   #
#     ERRRTN OR ENDRTN WILL HOLD THE APPROPRIATE LABEL, ELSE THE       #
#     PARAMETER NOT SPECIFIED WILL BE BLANKED OUT FROM THE CALL STMT.  #
#     IF A READ RELATION WITH KEY STATEMENT IS                         #009720
#     BEING PROCESSED, THEN TRANSFER CONTROL TO RELKCALL.              #009730
#     THE RELATION ORDINAL IS CONVERTED TO DISPLAY CODE AND STORED     #009740
#     IN THE CALL STATEMENT.  THE CALL STATEMENT IS WRITTEN ON DMLOUT  #009750
#     AND THE RELATION FLAG IS TURNED OFF.  RETURN IS TO STDYES.       #009760
#                                                                      #009770
#**********************************************************************#009780
                                                                        009790
                                 # IF A READ RELATION WITH KEY         #009800
                                 # IS BEING PROCESSED, GO TO RELKCALL  #009810
      IF KEYFLAG                                                        009820
      THEN                                                              009830
        GOTO RELKCALL;                                                  009840
                                                                        009850
                                 # PICK UP RELATION ORDINAL            #009860
      I = RELATIONORD;                                                  009870
      ORDCONVERT;                # CONVERT IT TO DISPLAY               #009880
                                                                        009890
                                 # PUT ORDINAL IN CALL STATEMENT       #009900
      C<20,4>CALLRL = C<1,4>DISPLAYORD;                                 000820
      C<25,4>CALLRL = C<1,4>DISPLAYORD;                                 000830
                                 # MOVE LABEL FROM DML STMT TO CALL    #000590
      C<0,5>CALLRL = CURLABEL;                                          000600
  
                                 #            ERR PARAMETER            #
      IF C<0,1>ERRSAVE EQ "*"    # IF ERRSAVE CONTAINS A VALID LABEL   #
      THEN
        BEGIN 
        C<30,1>CALLRL = "1";     # SET ERRFLAG TO TRUE                 #
        C<33,1>CALLRL = ",";
        C<34,6>CALLRL = ERRSAVE; # STORE THE LABEL IN ERRRTRN          #
        PARMLOC = 40;            # SET THE LOC OF NEXT PARAM AFTER ERR #
        END 
      ELSE                       #                 ELSE                #
        BEGIN 
        C<30,1>CALLRL = "0";     # SET ERRFLAG TO FALSE                #
        PARMLOC = 33;            # SET THE LOC OF NEXT PARAM BEFORE ERR#
        END 
  
                                 #         END PARAMETER               #
      IF C<0,1>ENDSAVE EQ "*"    # IF ENDSAVE CONTAINS A VALID LABEL   #
      THEN
        BEGIN 
        C<32,1>CALLRL = "1";     # SET ENDFLAG TO TRUE                 #
        C<PARMLOC,1>CALLRL = ",";  # PLACE COMMA TO CONTINUE PARAMETERS#
        C<PARMLOC+1,6>CALLRL = ENDSAVE; # INSERT ENDRTRN PARAMETER     #
        C<PARMLOC+7,8>CALLRL = ") ";  # INSERT END PARENTHESIS         #
                                      # AND BLANK OUT REST OF STMT     #
        END 
      ELSE                       #               ELSE                  #
        BEGIN 
        C<32,1>CALLRL = "0";     # SET ENDFLAG TO FALSE                #
        C<PARMLOC,15>CALLRL = ") ";  # TERMINATE CALL STMT AT LAST PARM#
                                     # AND BLANK OUT REST OF STMT      #
        END 
                                 # RESET LABEL STORAGE AREAS           #
      ERRSAVE = "NUTHIN"; 
      ENDSAVE = "NUTHIN"; 
                                 # WRITE CALL STATEMENT                #009930
      WDMLOUT (CALLRL,70);
                                                                        009950
      RELFLAG = FALSE;           # TURN OFF RELATION FLAG              #009960
                                                                        009970
      STDYES;                    # RETURN YES                          #009980
                                                                        009990
RELKCALL:                                                               010000
#**********************************************************************#010020
#                                                                      #010030
#                        R E L K C A L L                               #010040
#                                                                      #010050
#     WRITES CALL STATEMENT TO DMLRLK ON DMLOUT.                       #010060
#     THE CALL STATEMENT IS "CALL DMLRLK(FITLIST, RELATION             #010070
#     ORDINAL,KEY ORDINAL, RECORD ORDINAL,RELATIONAL                   #010080
#     OPERATOR,KEY LENGTH,KEY TYPE RKW,RKP,ERRRTN) "                   #
#     IF AN *ON ERROR* ALTERNATE RETURN IS SPECIFIED ERRRTN WILL       #
#     HOLD THE LABEL SPECIFIED, ELSE IT WILL BE BLANKED OUT.           #
#     THE RELATION ORDINAL, KEY ORDINAL, RECORD ORDINAL ARE            #010100
#     CONVERTED TO DISPLAY AND STORED IN THE CALL STMT. THE            #010110
#     RELATIONAL OPERATOR CODE IS STORED IN THE STMT.  THE             #010120
#     KEY LENGTH, KEY TYPE, RKW, AND RKP ARE CONVERTED                 #010130
#      AND STORED IN THE CALL STATEMENT.                               #010140
#                      FLAGS ARE RESET, THE CALL STATEMENT IS          #010160
#     WRITTEN ON DMLOUT AND RETURN IS TO STDYES.                       #010170
#                                                                      #010180
#**********************************************************************#010190
                                                                        010200
                                 # PICK UP RELATION ORDINAL            #010210
      I = RELATIONORD;                                                  010220
                                 # CONVERT IT TO DISPLAY               #010230
      ORDCONVERT;                                                       010240
                                 # PUT IT IN CALL STATEMENT            #010250
      C<21,4>CALLRLK = C<1,4>DISPLAYORD;                                000870
      C<26,4>CALLRLK = C<1,4>DISPLAYORD;                                000880
                                 # PICK UP ORDINAL OF ROOT RANK        #000210
      I = REALMORDINAL;                                                 000220
                                 # CONVERT IT TO DISPLAY               #000230
      ORDCONVERT;                                                       000240
                                 # PUT IT IN CALL STATEMENT            #000250
      C<7,4>CALLRLK1 = C<1,4>DISPLAYORD;                                000260
                                 # PICK UP KEY ORDINAL                 #010280
      I= KEYORDINAL;                                                    010290
                                 # CONVERT IT TO DISPLAY               #010300
      ORDCONVERT;                                                       010310
                                                                        010320
                                 # PUT IT IN CALL STATEMENT            #010330
      C<31,5>CALLRLK = C<0,5>DISPLAYORD;                                000900
                                                                        010350
                                 # PICK UP RECORD ORDINAL              #010360
      I = RECORDINAL;                                                   010370
                                 # CONVERT IT TO DISPLAY               #010380
      ORDCONVERT;                                                       010390
                                                                        010400
                                 # PUT IT IN CALL STATEMENT            #010410
      C<37,4>CALLRLK = C<1,4>DISPLAYORD;                                000920
                                                                        010430
                                 # PUT RELATION OP IN CALL STATEMENT   #010440
      C<42,1>CALLRLK = KEYCODE;                                         000940
                                                                        010460
                                 # PICK UP KEY LENGTH, KEY TYPE, RKW,  #010462
                                 # AND RKP, CONVERT THEM TO DISPLAY    #010464
                                 # AND STORE THEM IN CALL STMT         #010466
      I = KEYLENGTH;                                                    010468
      ORDCONVERT;                                                       010470
      C<44,4>CALLRLK = C<1,4>DISPLAYORD;                                000960
                                                                        010474
      I = KEYTYPE;                                                      010476
      ORDCONVERT;                                                       010478
      C<49,1>CALLRLK = C<4,1>DISPLAYORD;                                000980
                                                                        010482
      I = RKW;                                                          010484
      ORDCONVERT;                                                       010486
      C<51,4>CALLRLK = C<1,4>DISPLAYORD;                                001000
                                                                        010490
      I = RKP;                                                          010492
      ORDCONVERT;                                                       010494
      C<56,2>CALLRLK = C<3,2>DISPLAYORD;                                001020
                                                                        010498
                                 # STORE KEY NAME INTO CALL STMT       #000240
      C<59,7>CALLRLK = C<0,KEYITEMSIZE>KEYITEM;                         000250
                                                                        010700
                                 # RESET KEY FLAG                      #010710
      KEYFLAG = FALSE;                                                  010730
                                                                        010740
                                 # MOVE LABEL FROM DML STMT TO CALL    #000620
      C<0,5>CALLRLK = CURLABEL;                                         000630
  
      IF C<0,1>ERRSAVE EQ "*"    # IF ERRSAVE CONTAINS A VALID LABEL   #
      THEN
        BEGIN 
        C<11,8>CALLRLK1 = ",      )";  # INSERT COMMA AND RIGHT PAREN  #
        C<12,6>CALLRLK1 = ERRSAVE;  # STORE THE LABEL IN ERRRTRN       #
        END 
      ELSE                       #                 ELSE                #
        C<11,8>CALLRLK1 = ") ";  # OVERWRITE ERRRTRN PARAMETER         #
  
      ERRSAVE = "NUTHIN";        # RESET ERRSAVE                       #
      ENDSAVE = "NUTHIN";        # RESET ENDSAVE                       #
                                 # WRITE CALL STATEMENT                #010750
      WDMLOUT(CALLRLK,67);                                              000310
      WDMLOUT (CALLRLK1,45);
                                 # RETURN YES                          #010770
      STDYES;                                                           010780
                                                                        010790
STKEYCK:  
#**********************************************************************#
#                                                                      #
#                          S T K E Y C K                               #
#                                                                      #
#     CHECKS IF A KEY HAS BEEN SPECIFIED FOR THE START DIRECTIVE.      #
#     IF NOT, SETS *STKEYFLAG* TO FALSE TO INDICATE THAT THE PRIMARY   #
#     KEY SHOULD BE USED.                                              #
#     RETURN IS TO STDYES IF A KEY HAS BEEN SPECIFIED ELSE, RETURN IS  #
#     TO STDNO.                                                        #
#                                                                      #
#**********************************************************************#
  
      IF KEYFLAG                 # IF A KEY HAS BEEN SPECIFIED         #
      THEN
        STDYES;                  # RETURN TO STDYES                    #
  
                                 # IF NOT INDICATE THAT THE PRIMARY    #
      STKEYFLAG = FALSE;         # KEY SHOULD BE USED                  #
      STDNO;                     # RETURN TO STDNO TO CALL KEYNAME     #
  
KEYOPR:                                                                 010810
#**********************************************************************#010820
#                                                                      #010830
#                    K E Y O P R                                       #010840
#                                                                      #010850
#     CONVERTS KEY OPERATOR INTO CRM CODE. IT IS STORED IN             #010860
#     DISPLAY FORM IN KEYCODE FOR LATER INSERTION IN A CALL            #010870
#     STATEMENT.                                                       #
#     RETURN IS TO STDYES.                                             #
#                                                                      #010890
#**********************************************************************#010900
                                                                        010910
      IF C<0,2>CURWRD30[0] EQ "EQ" OR C<0,1>CURWRD30[0] EQ "="          000550
      THEN                                                              010930
        KEYCODE = DISP1;                                                010940
                                                                        010950
      IF C<0,2>CURWRD30[0] EQ "GE"                                      000570
      THEN                                                              010970
        KEYCODE = DISP3;                                                010980
                                                                        010990
      IF C<0,2>CURWRD30[0] EQ "GT"                                      000590
      THEN                                                              011010
        KEYCODE = DISP6;                                                011020
                                                                        011050
      STDYES;                                                           011060
                                                                        011070
KEYNAME:                                                                011080
#**********************************************************************#011090
#                                                                      #011100
#                    K E Y N A M E                                     #011110
#                                                                      #011120
#     VERIFIES THAT THE KEY SPECIFIED ON A START STATEMENT IS A VALID  #
#     KEY FOR THAT RELATION OR REALM.  IF IT IS A START RELATION, THE  #
#     RELATION ENTRY IS READ TO DETERMINE THE ADDRESS OF THE FIRST     #
#     REALM IN THE RELATION.  IN BOTH CASES, THE REALM ENTRY IS THEN   #
#     READ TO GET THE ADDRESS OF THE DATA CONTROL ENTRY. THE KEY ENTRY #
#     OF THE DATA CONTROL ENTRY IS READ.                               #
#                                                                      #
#     IF THE KEY IS A REGULAR IMBEDDED KEY, THE ITEM ENTRY FOR THE KEY #
#     ITEM IS READ.  IF THE ITEM NAME IN THE DML STATEMENT MATCHES THE #
#     ITEM NAME IN THE ITEM ENTRY, THE KEY ORDINAL AND RECORD ORDINAL, #
#     KEY TYPE, KEY LENGTH, RKW, AND RKP ARE SAVED.                    #
#                                                                      #
#     IF THE KEY IS A CONCATENATED KEY, THE KEY NAME IN THE DML STATE- #
#     MENT IS MATCHED AGAINST THE KEY NAME IN THE CONCATENATED KEY     #
#     ENTRY.  IF THERE IS A MATCH, THE KEY ORDINAL AND RECORD ORDINAL, #
#     KEY TYPE, KEY LENGTH, RKW, AND RKP ARE SAVED. ALSO, THE NAME OF  #
#     THE FIRST ITEM IS SAVED FOR LATER INSERTION INTO THE START CALL  #
#     STATEMENT INSTEAD OF THE CONCATENATED KEY NAME.                  #
#                                                                      #
#     IF THE KEY IS A MAJOR KEY, THE ITEM ENTRY FOR THE CONSTITUENT    #
#     ITEM IS READ.  IF THE ITEM NAME IN THE START STATEMENT MATCHES   #
#     THE ITEM NAME IN THE ITEM ENTRY, THE KEY ORDINAL AND RECORD      #
#     ORDINAL, KEY TYPE, KEY LENGTH, RKW, AND RKP ARE SAVED.  THE      #
#     REMAINING ITEMS OF A MAJOR KEY ARE VERIFIED AND THE ITEM SIZES   #
#     ARE ADDED TO THE MKL COUNTER. ALSO, THE NAME OF THE FIRST ITEM   #
#     OF THE MAJOR KEY IS SAVED FOR LATER INSERTION INTO THE START     #
#     CALL STATEMENT.                                                  #
#                                                                      #
#     THE KEY FLAG IS SET AND RETURN IS TO STDYES.                     #
#                                                                      #
#     EACH KEY ENTRY OF THE DATA CONTROL ENTRY IS SEARCHED UNTIL A     #
#     MATCH IS FOUND.  IF NO MATCH IS FOUND, RETURN IS TO STDNO.       #
#                                                                      #011240
#**********************************************************************#011250
                                                                        011260
                                 # SAVE NAME AND LENGTH IN CHARACTERS  #011270
      KEYITEM = C<0,CURLENG>CURWRD30[0];                                000330
      KEYITEMSIZE = CURLENG;                                            011290
                                 # ZERO OUT FIELD SO 1ST 7 WORDS       #011300
                                 # OF ENTRY WILL BE READ               #011310
      DAPART[0] = 0;                                                    011320
                                                                        011330
      IF CONCTFG
      THEN
        BEGIN 
        STDNO;                   # CONCATENATED KEY ALREADY FOUND,     #
                                 # ILLEGAL KEY NAME MENTIONED          #
        END 
  
      IF MAJORFLAG               # IF IT IS A MAJOR KEY, BRANCH TO     #
      THEN                       # MAJOR KEY PROCESSING SECTION        #
        BEGIN 
        GOTO MAJORKEY;
        END 
  
                                 # IF IT IS A START RELATION, READ     #
                                 # IN RELATION ENTRY TO GET ADDRESS    #011350
                                 # OF FIRST REALM                      #011360
      IF RELFLAG                                                        011370
      THEN                                                              011380
        BEGIN                                                           011390
          DE$ARSB (RLMNAME,      # RELATION NAME                       #011400
                   RELENTRY,     # AREA TO READ INTO                   #011410
                   7);           # NUMBER OF WORDS TO READ             #011420
                                                                        011430
          IF DASTATE[0] EQ 1     # REALM NOT FOUND                     #000610
          THEN                                                          000620
            DIAGDL(118);         # INTERNAL DML ERROR                  #000630
                                                                        000640
                                 # READ 2 WORDS OF REALM ENTRY         #011440
                                                                        011450
          DE$GTSB (REALMENTRY,   # AREA TO READ INTO                   #011460
                   2,            # NUMBER OF WORDS TO READ             #011470
                                 # ADDR TO READ FROM                   #002490
                   RSTAREAADR[RSTRELNMELW[0] + 2]);                     000500
                                                                        011490
          IF DASTATE[0] EQ 1     # ADDRESS OUTSIDE FILE LIMITS         #000660
          THEN                                                          000670
            DIAGDL(118);         # INTERNAL DML ERROR                  #000680
                                                                        000130
                                 # PICK UP ORDINAL OF ROOT RANK        #000140
      REALMORDINAL = SBARORDINAL[0];                                    000150
                                                                        000690
        END                                                             011500
                                 # FOR START REALM, READ 2 WORDS       #
                                 # OF REALM ENTRY                      #011520
      ELSE                                                              011530
        BEGIN                                                           000920
        DE$ARSB (RLMNAME,        # REALM NAME                          #011540
                 REALMENTRY,     # AREA TO READ INTO                   #011550
                 2);             # NUMBER OF WORDS TO READ             #011560
                                                                        011570
        IF DASTATE[0] EQ 1       # REALM NOT FOUND                     #000710
        THEN                                                            000720
          DIAGDL(118);           # INTERNAL DML ERROR                  #000730
        END                                                             000740
                                                                        000750
                                 # READ DATA CONTRO ENTRY FOR REALM    #011580
      DCADDR = SBARDCONTRLA[0];                                         000260
                                                                        011590
      DE$GTSB (DATACONTROL,      # AREA TO READ INTO                   #011600
               2,                # NUMBER OF WORDS TO READ             #
               DCADDR);          # ADDR OF DATA CONTROL ENTRY          #002540
                                                                        011630
      IF DASTATE[0] EQ 1         # ADDRESS OUTSIDE FILE LIMITS         #000770
      THEN                                                              000780
        DIAGDL(118);             # INTERNAL DML ERROR                  #000790
                                                                        000800
                                 # GET ADDR OF DATA CONTROL FIT        #
      FITPTR = DCADDR + SBDCFITPTR[0];
                                 # READ FIT INTO MEMORY                #
      DE$GTSB(FIT,               # AREA TO READ INTO                   #
              FITLEN,            # NUMBER OF WORDS TO READ             #
              FITPTR);           # ADDRESS OF FIT                      #
  
      IF DASTATE[0] EQ 1         # ADDRESS OUTSIDE FILE LIMITS         #
      THEN
        DIAGDL(118);             # INTERNAL DML ERROR                  #
                                 # ADD OFFSET OF KEY ENTRY TO          #011640
                                 # DATA CONTROL WORD ADDRESS           #011650
      DCADDR = DCADDR + SBDCALTRKYPT[0];                                002560
                                                                        011670
KEYLOOP:                         # LOOK FOR MATCHING NAME              #011680
                                 # READ KEY PART OF DATA CONTROL ENTRY #011690
                                                                        011700
      DE$GTSB (KEYENTRY,         # AREA TO READ INTO                   #011710
               3,                # NUMBER OF WORDS TO READ             #011720
               DCADDR);          # ADDR TO READ FROM                   #011730
                                                                        011740
      IF DASTATE[0] EQ 1         # ADDRESS OUTSIDE FILE LIMITS         #000820
      THEN                                                              000830
        DIAGDL(118);             # INTERNAL DML ERROR                  #000840
  
      IF SBDCKEYOMIT[1]          # IF ALTERNATE KEY NOT SPECIFIED IN   #
      THEN                       # SUBSCHEMA, GET NEXT KEY ENTRY       #
        BEGIN 
        GOTO NEXTKEY; 
        END 
  
                                 # WORD ADDR OF ITEM ENTRY             #
      ITEMADDR = SBDCKEYDNADR[2]; 
  
                                 # READ 12 WORDS OF ITEM ENTRY         #
      DE$GTSB (ITEMENTRY,        # AREA TO READ INTO                   #
               12,               # NUMBER OF WORDS TO READ             #
               ITEMADDR);        # ADDR TO READ FROM                   #
  
      IF DASTATE[0] EQ 1         # ADDRESS OUTSIDE FILE LIMITS         #
      THEN
        BEGIN 
        DIAGDL(118);             # INTERNAL DML ERROR                  #
        END 
  
      NAMEPTR = SBITMNAMEPTR[0]; # PTR TO ITEM NAME                    #
  
                                 # TEST IF CONCATENATED KEY            #
      IF NOT SBDCCONCTFG[1] 
      THEN
        BEGIN                    # PROCESS IMBEDDED KEY                #
                                 # LOOK FOR MATCHING NAME              #
                                                                        000850
                                 # DOES KEY NAME MATCH ITEM ENTRY      #011950
                                 # OR IF NO KEY SPECIFIED FOR START    #
                                 # USE THE FIRST KEY FOUND (PRIMARY)   #
  
      IF C<0,KEYITEMSIZE>KEYITEM EQ 
                               C<0,SBITMNMELENC[0]>SBITMNAME30[NAMEPTR] 
        OR NOT(STKEYFLAG) 
      THEN                                                              011970
        BEGIN                    # YES                                 #011980
                                 # PICK UP FIT INFORMATION             #011982
                                 # IF AK FILE, GET INFO FROM FIT       #
                                 # IF KEY IS PRIMARY KEY               #
          IF FITFO[0] EQ AK AND SBITMKEYFLG[0]
          THEN
            BEGIN 
              RKW = FITRKW[0];
              RKP = FITRKP[0];
              KEYLENGTH = FITKL[0]; 
            END 
          ELSE BEGIN
          RKW = SBITMBWP[0];                                            000250
          RKP = SBITMBBP[0] / 6;                                        000260
          KEYLENGTH = SBITMUSESIZE[0];                                  011989
          END 
  
          MKL = 0;
          KEYTYPE = SBDCKEYTYPE[0]; 
                                 # PICK UP RECORD ORDINAL              #011990
          RECORDINAL = SBDCRECORD[2];                                   011992
                                                                        011994
          KEYORDINAL = SBITMORDINAL[0];                                 012030
  
          KEYFLAG = TRUE;        # INDICATE THAT A KEY HAS BEEN FOUND  #
  
          IF NOT(STKEYFLAG)      # IF NO KEY SPECIFIED FOR START       #
          THEN                   # USE THE KEY NAME AND LENGTH FROM    #
            BEGIN                # THE SUB-SCHEMA                      #
            KEYITEM = C<0,SBITMNMELENC[0]>SBITMNAME30[NAMEPTR]; 
            KEYITEMSIZE = SBITMNMELENC[0];
            KEYCODE = DISP1;     # SET THE OPERATOR CODE TO *EQ*       #
            END 
  
          STDYES;                # RETURN TO STDYES                    #
  
        END                                                             012050
  
      END 
  
        ELSE
          BEGIN                  # PROCESS CONCATENATED KEY            #
                                 # LOOK FOR MATCHING NAME              #
  
                                 # READ KEY PART OF DATA CONTROL ENTRY #
                                 # FOR A CONCATENATED KEY              #
          DE$GTSB (KEYENTRY,
                   SBDCCNNBRITM[2] + SBDCCNNMELW[2] + 3,
                   DCADDR); 
  
                                 # DOES KEY NAME MATCH CONCATENATED    #
                                 # KEY NAME                            #
          IF (C<0,KEYITEMSIZE>KEYITEM EQ
                         C<0,SBDCCNNMELC[2]>SBDCCNNME30[3]) 
              OR (NOT STKEYFLAG)
          THEN
            BEGIN 
            RKW = SBDCKEYBWP[1];
            RKP = SBDCKEYBCP[1];
            KEYLENGTH = SBDCKEYSIZ[1];
            MKL = 0;
            KEYTYPE = SBDCKEYTYPE[0]; 
            RECORDINAL = SBDCRECORD[2]; 
  
                                 # SET KEY ORDINAL TO ORDINAL OF FIRST #
                                 # ITEM                                #
            KEYORDINAL = SBITMORDINAL[0]; 
  
            KEYFLAG = TRUE;      # INDICATE THAT A KEY HAS BEEN FOUND  #
  
            CONCTFG = TRUE;      # INDICATE THAT A CONCATENATED KEY    #
                                 # HAS BEEN FOUND                      #
  
                                 # SET KEY ITEM TO FIRST CONSTITUENT   #
                                 # ITEM NAME OF THE CONCATENATED KEY   #
                                 # FROM THE SUBSCHEMA                  #
            KEYITEM = C<0,SBITMNMELENC[0]>SBITMNAME30[NAMEPTR]; 
            KEYITEMSIZE = SBITMNMELENC[0];
  
            IF NOT(STKEYFLAG) 
            THEN
                BEGIN            # SET THE OPERATOR CODE TO *EQ*       #
                KEYCODE = DISP1;
                END 
  
            STDYES; 
            END 
  
          ELSE
            BEGIN                # VERIFY IF MAJOR KEY                 #
  
                                 # COMPARE KEY NAMES                   #
            IF C<0,KEYITEMSIZE>KEYITEM EQ 
                           C<0,SBITMNMELENC[0]>SBITMNAME30[NAMEPTR] 
            THEN
              BEGIN 
              RKW = SBDCKEYBWP[1];
              RKP = SBDCKEYBCP[1];
              MKL = SBITMUSESIZE[0];
              KEYLENGTH = SBDCKEYSIZ[1];
              KEYTYPE = SBDCKEYTYPE[0]; 
              RECORDINAL = SBDCRECORD[2]; 
              KEYORDINAL = SBITMORDINAL[0]; 
              KEYFLAG = TRUE; 
              MAJORFLAG = TRUE; 
              NEXTDBI = 3 + SBDCCNNMELW[2]; 
  
                                 # SAVE NAME AND LENGTH OF 1ST ITEM OF #
                                 # MAJOR KEY                           #
              SAVENAM = KEYITEM;
              SAVELEN = KEYITEMSIZE;
  
              STDYES; 
              END 
  
            END 
  
          END 
  
NEXTKEY:  
                                 # NAMES DONT MATCH                    #012060
                                 # IS THERE ANOTHER KEY ENTRY          #012070
      IF SBDCKEYNITM[1] EQ 0                                            012080
      THEN                                                              012090
        STDNO;                   # NO, RETURN NO                       #012100
                                                                        012110
                                 # GET ADDR OF NEXT KEY ENTRY          #012120
      DCADDR = DCADDR + SBDCKEYNITM[1];                                 000120
      GOTO KEYLOOP;                                                     012140
  
MAJORKEY:                        # PROCESS ITEMS OF MAJOR KEY          #
  
      NEXTDBI = NEXTDBI + 1;     # SET POINTER TO NEXT DBI WORD        #
  
                                 # GET ADDR OF NEXT CONCAT KEY ITEM    #
      ITEMADDR = SBDCCNDBIS[NEXTDBI]; 
  
                                 # READ THE ITEM ENTRY OF THE CONCAT-  #
                                 # ENATED KEY ITEM                     #
  
      DE$GTSB(ITEMENTRY,         # AREA TO READ INTO                   #
              12,                # NUMBER OF WORDS TO READ             #
              ITEMADDR);         # ADDRESS OF DATA ITEM ENTRY          #
  
      NAMEPTR = SBITMNAMEPTR[0]; # POINTER TO ITEM NAME                #
  
                                 # IF MATCH, INCREMENT MAJOR KEY LENGTH#
      IF C<0,KEYITEMSIZE>KEYITEM EQ 
                          C<0,SBITMNMELENC[0]>SBITMNAME30[NAMEPTR]
      THEN
        BEGIN 
        MKL = MKL + SBITMUSESIZE[0];
        KEYITEM = SAVENAM;       # REPLACE WITH NAME AND LENGTH OF 1ST #
        KEYITEMSIZE = SAVELEN;   # ITEM OF MAJOR KEY                   #
        STDYES; 
        END 
  
      ELSE                       # ELSE                                #
        BEGIN 
        DIAGDL (138);            # ITEM IN MAJOR KEY INVALID           #
        STDNO;
        END 
                                                                        012150
READKEY:  
#**********************************************************************#
#                                                                      #
#                    R E A D K E Y                                     #
#                                                                      #
#     VERIFIES THAT THE KEY SPECIFIED ON A READ STATEMENT IS A VALID   #
#     KEY FOR THAT RELATION OR REALM.  IF IT IS A READ RELATION, THE   #
#     RELATION ENTRY IS READ TO DETERMINE THE ADDRESS OF THE FIRST     #
#     REALM IN THE RELATION.  IN BOTH CASES, THE REALM ENTRY IS THEN   #
#     READ TO GET THE ADDRESS OF THE DATA CONTROL ENTRY. THE KEY ENTRY #
#     OF THE DATA CONTROL ENTRY IS READ.                               #
#                                                                      #
#     IF THE KEY IS A REGULAR IMBEDDED KEY, THE ITEM ENTRY FOR THE KEY #
#     ITEM IS READ.  IF THE ITEM NAME IN THE DML STATEMENT MATCHES THE #
#     ITEM NAME IN THE ITEM ENTRY, THE KEY ORDINAL AND RECORD ORDINAL, #
#     KEY TYPE, KEY LENGTH, RKW, AND RKP ARE SAVED.                    #
#                                                                      #
#     IF THE KEY IS A CONCATENATED KEY, THE KEY NAME IN THE DML STATE- #
#     MENT IS MATCHED AGAINST THE KEY NAME IN THE CONCATENATED KEY     #
#     ENTRY.  IF THERE IS A MATCH, THE KEY ORDINAL AND RECORD ORDINAL, #
#     KEY TYPE, KEY LENGTH, RKW, AND RKP ARE SAVED. ALSO, THE NAME OF  #
#     THE FIRST ITEM IS SAVED FOR LATER INSERTION IN THE READ CALL     #
#     STATEMENT.                                                       #
#                                                                      #
#     THE KEY FLAG IS SET AND RETURN IS TO STDYES.                     #
#                                                                      #
#     EACH KEY ENTRY OF THE DATA CONTROL ENTRY IS SEARCHED UNTIL A     #
#     MATCH IS FOUND.  IF NO MATCH IS FOUND, RETURN IS TO STDNO.       #
#                                                                      #
#**********************************************************************#
  
                                 # SAVE NAME AND LENGTH IN CHARACTERS  #
      KEYITEM = C<0,CURLENG>CURWRD30[0];
      KEYITEMSIZE = CURLENG;
                                 # ZERO OUT FIELD SO 1ST 7 WORDS       #
                                 # OF ENTRY WILL BE READ               #
      DAPART[0] = 0;
  
                                 # IF IT IS A READ RELATION, READ      #
                                 # IN RELATION ENTRY TO GET ADDRESS    #
                                 # OF FIRST REALM                      #
      IF RELFLAG
      THEN
        BEGIN 
        DE$ARSB (RLMNAME,        # RELATION NAME                       #
                 RELENTRY,       # AREA TO READ INTO                   #
                 7);             # NUMBER OF WORDS TO READ             #
  
        IF DASTATE[0] EQ 1       # REALM NOT FOUND                     #
        THEN
          BEGIN 
          DIAGDL(118);           # INTERNAL DML ERROR                  #
          END 
  
                                 # READ 2 WORDS OF REALM ENTRY         #
        DE$GTSB (REALMENTRY,     # AREA TO READ INTO                   #
                 2,              # NUMBER OF WORDS TO READ             #
                                 # ADDR TO READ FROM                   #
                 RSTAREAADR[RSTRELNMELW[0] + 2]); 
  
        IF DASTATE[0] EQ 1       # ADDRESS OUTSIDE FILE LIMITS         #
        THEN
          BEGIN 
          DIAGDL(118);           # INTERNAL DML ERROR                  #
          END 
                                 # PICK UP ORDINAL OF ROOT RANK        #
        REALMORDINAL = SBARORDINAL[0];
  
        END 
                                 # FOR READ REALM, READ 2 WORDS        #
                                 # OF REALM ENTRY                      #
      ELSE
        BEGIN 
        DE$ARSB (RLMNAME,        # REALM NAME                          #
                 REALMENTRY,     # AREA TO READ INTO                   #
                 2);             # NUMBER OF WORDS TO READ             #
  
        IF DASTATE[0] EQ 1       # REALM NOT FOUND                     #
        THEN
          BEGIN 
          DIAGDL(118);           # INTERNAL DML ERROR                  #
          END 
        END 
  
                                 # READ DATA CONTROL ENTRY FOR REALM   #
      DCADDR = SBARDCONTRLA[0]; 
  
      DE$GTSB (DATACONTROL,      # AREA TO READ INTO                   #
               2,                # NUMBER OF WORDS TO READ             #
               DCADDR);          # ADDR OF DATA CONTROL ENTRY          #
  
      IF DASTATE[0] EQ 1         # ADDRESS OUTSIDE FILE LIMITS         #
      THEN
        BEGIN 
        DIAGDL(118);             # INTERNAL DML ERROR                  #
        END 
                                 # GET ADDR OF DATA CONTROL FIT        #
      FITPTR = DCADDR + SBDCFITPTR[0];
  
                                 # READ FIT INTO MEMORY                #
      DE$GTSB(FIT,               # AREA TO READ INTO                   #
              FITLEN,            # NUMBER OF WORDS TO READ             #
              FITPTR);           # ADDRESS OF FIT                      #
  
      IF DASTATE[0] EQ 1         # ADDRESS OUTSIDE FILE LIMITS         #
      THEN
        BEGIN 
        DIAGDL(118);             # INTERNAL DML ERROR                  #
        END 
                                 # ADD OFFSET OF KEY ENTRY TO          #
                                 # DATA CONTROL WORD ADDRESS           #
      DCADDR = DCADDR + SBDCALTRKYPT[0];
  
LOOP:                            # LOOK FOR MATCHING NAME              #
                                 # READ KEY PART OF DATA CONTROL ENTRY #
  
      DE$GTSB (KEYENTRY,         # AREA TO READ INTO                   #
               3,                # NUMBER OF WORDS TO READ             #
               DCADDR);          # ADDR TO READ FROM                   #
  
      IF DASTATE[0] EQ 1         # ADDRESS OUTSIDE FILE LIMITS         #
      THEN
        BEGIN 
        DIAGDL(118);             # INTERNAL DML ERROR                  #
        END 
  
      IF SBDCKEYOMIT[1]          # IF ALTERNATE KEY NOT SPECIFIED IN   #
      THEN                       # SUBSCHEMA, GET NEXT KEY ENTRY       #
        BEGIN 
        GOTO GETNEXT; 
        END 
  
                                 # WORD ADDR OF ITEM ENTRY             #
      ITEMADDR = SBDCKEYDNADR[2]; 
  
                                 # READ 12 WORDS OF ITEM ENTRY         #
      DE$GTSB (ITEMENTRY,        # AREA TO READ INTO                   #
               12,               # NUMBER OF WORDS TO READ             #
               ITEMADDR);        # ADDR TO READ FROM                   #
  
      IF DASTATE[0] EQ 1         # ADDRESS OUTSIDE FILE LIMITS         #
      THEN
        BEGIN 
        DIAGDL(118);             # INTERNAL DML ERROR                  #
        END 
  
      NAMEPTR = SBITMNAMEPTR[0]; # PTR TO ITEM NAME                    #
  
                                 # TEST IF CONCATENATED KEY            #
      IF NOT SBDCCONCTFG[1] 
      THEN
        BEGIN                    # PROCESS IMBEDDED KEY                #
                                 # LOOK FOR MATCHING NAME              #
  
                                 # DOES KEY NAME MATCH ITEM ENTRY      #
  
        IF C<0,KEYITEMSIZE>KEYITEM EQ 
                               C<0,SBITMNMELENC[0]>SBITMNAME30[NAMEPTR] 
        THEN
          BEGIN                  # YES                                 #
                                 # PICK UP FIT INFORMATION             #
                                 # IF AK FILE, GET INFO FROM FIT       #
                                 # IF KEY IS PRIMARY KEY               #
          IF FITFO[0] EQ AK AND SBITMKEYFLG[0]
          THEN
            BEGIN 
            RKW = FITRKW[0];
            RKP = FITRKP[0];
            KEYLENGTH = FITKL[0]; 
            END 
          ELSE
            BEGIN 
            RKW = SBITMBWP[0];
            RKP = SBITMBBP[0] / 6;
            KEYLENGTH = SBITMUSESIZE[0];
            END 
  
          KEYTYPE = SBDCKEYTYPE[0]; 
                                 # PICK UP RECORD ORDINAL              #
          RECORDINAL = SBDCRECORD[2]; 
  
          KEYORDINAL = SBITMORDINAL[0]; 
  
          KEYFLAG = TRUE;        # INDICATE THAT A KEY HAS BEEN FOUND  #
  
          STDYES;                # RETURN TO STDYES                    #
  
          END 
  
        END 
  
      ELSE
        BEGIN                    # PROCESS CONCATENATED KEY            #
                                 # LOOK FOR MATCHING NAME              #
  
                                 # READ KEY PART OF DATA CONTROL ENTRY #
                                 # FOR A CONCATENATED KEY              #
        DE$GTSB (KEYENTRY,
                 SBDCCNNBRITM[2] + SBDCCNNMELW[2] + 3,
                 DCADDR); 
  
                                 # DOES KEY NAME MATCH CONCATENATED    #
                                 # KEY NAME                            #
        IF C<0,KEYITEMSIZE>KEYITEM EQ 
                         C<0,SBDCCNNMELC[2]>SBDCCNNME30[3]
        THEN
          BEGIN 
          RKW = SBDCKEYBWP[1];
          RKP = SBDCKEYBCP[1];
          KEYLENGTH = SBDCKEYSIZ[1];
          KEYTYPE = SBDCKEYTYPE[0]; 
          RECORDINAL = SBDCRECORD[2]; 
  
                                 # SET KEY ORDINAL TO ORDINAL OF FIRST #
                                 # ITEM                                #
          KEYORDINAL = SBITMORDINAL[0]; 
  
          KEYFLAG = TRUE;        # INDICATE THAT A KEY HAS BEEN FOUND  #
  
                                 # SET KEY ITEM TO FIRST CONSTITUENT   #
                                 # ITEM NAME OF THE CONCATENATED KEY   #
                                 # IN THE SUBSCHEMA                    #
          KEYITEM = C<0,SBITMNMELENC[0]>SBITMNAME30[NAMEPTR]; 
          KEYITEMSIZE = SBITMNMELENC[0];
  
          STDYES; 
          END 
  
        END 
  
GETNEXT:  
                                 # NAMES DONT MATCH                    #
                                 # IS THERE ANOTHER KEY ENTRY          #
      IF SBDCKEYNITM[1] EQ 0
      THEN
        BEGIN 
        STDNO;                   # NO, RETURN NO                       #
        END 
                                 # GET ADDR OF NEXT KEY ENTRY          #
      DCADDR = DCADDR + SBDCKEYNITM[1]; 
      GOTO LOOP;
  
ERRRTRN:  
#**********************************************************************#
#                                                                      #
#                            ERRRTRN                                   #
#                                                                      #
#     CHECKS FORTRAN VERSION FOR FTN5, IF NOT, PARAMETER INVALID (D130)#
#     CHECKS FOR DUPLICATE PARAMETER, IF SO, - DIAG 123, STDNO -       #
#     CHECKS CURWORD FOR A VALID FORTRAN LABEL (1-5 INTEGERS)          #
#                       NO - STDNO                                     #
#                  YES - STORE LABEL, STDYES                           #
#                                                                      #
#**********************************************************************#
  
      IF DDLCOMP NQ F5           # CHECK FOR FORTRAN VERSION 5         #
      THEN
        BEGIN 
        DIAGDL(130);             # NO, INVLAID PARAMETER ERROR         #
        WDMLOUT(OUTERR,LOUTERR); # ISSUE *DML ERROR* MESSAGE           #
        STDYES;                  # RETURN TO STDYES                    #
        END 
  
                                 # CHECK FOR DUPLICATE PARAMETERS      #
  
      ERRPARCNT = ERRPARCNT + 1;
      IF ERRPARCNT GR 1 
      THEN
        BEGIN 
        DIAGDL(123);             # DUPLICATE PARAMETER                 #
        STDNO;                   # ERROR RETURN                        #
        END 
  
      ERRSAVE = " ";             # BLANK OUT ERR LABEL SAVE AREA       #
  
      FOR I=0 STEP 1             # CHECK AND SAVE FORTRAN LABEL        #
        UNTIL CURLENG-1 
      DO
        BEGIN 
        IF C<I,1>CURWRD30[0] LS "0"   # IF LABEL HAS NON-INTEGER CHAR  #
          OR C<I,1>CURWRD30[0] GR "9" 
            OR I GR 4            # OR LABEL HAS MORE THAN FIVE CHAR    #
        THEN
          BEGIN 
          DIAGDL(128);           # INVALID LABEL                       #
          STDNO;                 # ERROR RETURN                        #
          END 
        ELSE                     #               ELSE                  #
          C<I+1,1>ERRSAVE = C<I,1>CURWRD30[0];  # SAVE THE CHARACTER   #
          END 
  
      C<0,1>ERRSAVE = "*";       # IF LABEL IS VALID PLACE * IN FRONT  #
      STDYES;                    # RETURN STDYES                       #
  
ENDRTRN:  
#**********************************************************************#
#                                                                      #
#                            ENDRTRN                                   #
#                                                                      #
#     CHECKS FORTRAN VERSION FOR FTN5, IF NOT, PARAMETER INVALID (D129)#
#     CHECKS FOR DUPLICATE PARAMETERS, IF SO, -DIAG 123, STDNO-        #
#     CHECKS FOR READ WITH KEY, IF SO, PARAMETER IS IGNORED - STDYES.  #
#     CHECKS CURWORD FOR VALID FORTRAN LABEL (1-5 INTEGERS)            #
#                       NO - STDNO                                     #
#                  YES - STORE LABEL - STDYES                          #
#                                                                      #
#**********************************************************************#
  
      IF DDLCOMP NQ F5           # CHECK FOR FORTRAN VERSION 5         #
      THEN
        BEGIN 
        DIAGDL(129);             # NO INVALID PARAMETER ERROR          #
        WDMLOUT(OUTERR,LOUTERR); # ISSUE *DML ERROR* MESSAGE           #
        STDYES;                  # RETURN STDYES                       #
        END 
  
                                 # CHECK FOR DUPLICATE PARAMETERS      #
  
      ENDPARCNT = ENDPARCNT + 1;
      IF ENDPARCNT GR 1 
      THEN
        BEGIN 
        DIAGDL(123);             # DUPLICATE PARAMETER                 #
        STDNO;                   # ERROR RETURN                        #
        END 
  
      IF KEYFLAG                 # IF READ WITH KEY *ON END* IS IGNORED#
      THEN
        STDYES; 
  
      ENDSAVE = " ";             # BLANK OUT END LABEL SAVE AREA       #
  
      FOR I=0 STEP 1             # CHECK AND SAVE FORTRAN LABEL        #
        UNTIL CURLENG-1 
      DO
        BEGIN 
        IF C<I,1>CURWRD30[0] LS "0"   # IF LABEL HAS NON-INTEGER CHAR  #
          OR C<I,1>CURWRD30[0] GR "9" 
            OR I GR 4            # OR LABEL HAS MORE THAN FIVE CHAR    #
        THEN
          BEGIN 
          DIAGDL(128);           # INVALID LABEL                       #
          STDNO;                 # ERROR RETURN                        #
          END 
        ELSE                     #             ELSE                    #
          C<I+1,1>ENDSAVE = C<I,1>CURWRD30[0];  # SAVE THE CHARACTER   #
        END 
  
      C<0,1>ENDSAVE = "*";       # IF LABEL IS VALID, PLACE * IN FRONT #
      STDYES;                    # RETURN STDYES                       #
  
  
SAVEPGMNAME:                                                            001040
#**********************************************************************#001050
#                                                                      #001060
#                    S A V E P G M N A M E                             #001070
#                                                                      #001080
#     SAVES NAME OF PROGRAM UNIT. RETURNS YES                          #001090
#                                                                      #001100
#**********************************************************************#001110
                                                                        001120
      C<0,CURLENG>PGMNAME = C<0,CURLENG>CURWRD30[0]; # SAVE NAME       #001130
      C<CURLENG,10-CURLENG>PGMNAME = BLANK; # BLANK OUT REST OF WORD   #001140
      STDYES;                                                           001150
                                                                        001160
DEFAULTNAME:                                                            001170
#**********************************************************************#001180
#                                                                      #001190
#                    D E F A U L T N A M E                             #001200
#                                                                      #001210
#     SET PROGRAM UNIT NAME TO DEFAULT OF START. RETURNS NO            #001220
#                                                                      #001230
#**********************************************************************#001240
                                                                        001250
      PGMNAME = "START.    ";                                           001260
      STDNO;                                                            001270
                                                                        001280
DATAPGMNAME:                                                            001290
#**********************************************************************#001300
#                                                                      #001310
#                  D A T A P G M N A M E                               #001320
#                                                                      #001330
#     WRITES DATA STATEMENT TO SET DBRUID TO PROGRAM UNIT NAME.        #001340
#     PICKS UP PROGRAM NAME, STORES IT IN DATA STATEMENT, AND          #001350
#     WRITES DATA STATEMENT ON DMLOUT.  RETURNS YES.                   #001360
#                                                                      #001370
#**********************************************************************#001380
                                                                        001390
                                                                        000580
      IF NOT DSOPT               # IF DS OPTION NOT SELECTED           #000590
      THEN                       # GENERATE LIST,NONE DIRECTIVE        #000600
        BEGIN 
        IF DDLCOMP EQ F4         #              IF FTN4                #
        THEN
          WDMLOUT(LISTNONE4,20); # WRITE OUT FTN4 LIST,NONE DIRECTIVE  #
        ELSE                     #         ELSE, ASSUME FTN5           #
          WDMLOUT(LISTNONE5,20); # WRITE OUT FTN5 LIST,NONE DIRECTIVE  #
        END 
                                 # PUT PGM NAME IN DATA STATEMENT      #001400
      C<22,10>DATANAME = PGMNAME;                                       001410
                                 # WRITE DATA STATEMENT                #001420
      WDMLOUT(DATANAME,40);                                             001430
      STDYES;                    # RETURN YES                          #001440
                                                                        001450
FITCALL:                                                                001460
#**********************************************************************#001470
#                                                                      #001480
#                    F I T C A L L                                     #001490
#                                                                      #001500
#     WRITES ASSIGNMENT STATEMENTS TO INITIALIZE WSA AND KA FIELDS     #000210
#     OF EACH FIT. THE STATEMENTS ARE "DBFXXXX(16)=LOCF(DBIXXXX)"      #000220
#     AND "DBFXXXX(25)=DBFXXXX(25)+DBFXXXX(16)". THE RH 18 BITS OF     #000230
#     WORD 16 OF THE FIT IS THE WORKING STORAGE ADDRESS. THIS IS SET   #000240
#     TO THE ADDRESS OF THE ITEM CREATED BY THE SS WHICH IS            #000250
#     EQUIVALENCED TO THE FIRST ITEM IN THE RECORD. THE LOWER 18 BITS  #000260
#     OF WORD 25 OF THE FIT IS THE KEY ADDRESS. THIS IS SET TO THE     #000270
#     BEGINNING WORD POSITION OF THE KEY IN THE RECORD BY THE SS.      #000280
#     IN CASE OF MULTIPLE INVOKES, THE FIT KA FIELD IS RESET TO        #
#     THE RELATIVE KEY POSITION IN THE RECORD EVERY TIME THE           #
#     INVOKE STATEMENT IS ENCOUNTERED.                                 #
#     THE GENERATED ASSIGNMENT STATEMENT ADDS THE KA TO THE WSA TO GET #000290
#     THE ACTUAL KA. THESE 2 ASSIGNMENT STATEMENTS ARE WRITTEN ON      #000300
#     DMLOUT FOR EACH FIT IN THE SS.                                   #000310
#                                                                      #000320
#**********************************************************************#000330
                                                                        000340
      K = SBCWNUMAREAS[0];       # NUMBER OF REALMS IN SS              #000350
      DCADDR = SBCWDCADDR[0];      # ADDRESS OF DATA CONTROL ENTRY     #
      FOR J = 1 STEP 1 UNTIL K DO                                       000360
        BEGIN                                                           000370
        DE$GTSB(DATACONTROL,1,     # USE DIRECTORY ACCESS ROUTINE      #
        DCADDR);                   # TO READ 1 WORD FROM DATA CONTROL  #
                                   # ENTRY INTO THE ADDRESS OF ARRAY   #
                                   # DATACONTROL                       #
        IF DASTATE[0] EQ 1         # ADDRESS OUTSIDE FILE LIMITS       #
        THEN
          BEGIN 
          DIAGDL(118);             # INTERNAL DML ERROR                #
          END 
        L=DCADDR;                  # SAVE POINTER TO DC ENTRY          #
        DCADDR = DCADDR + 
                        SBDCALTRKYPT[0];    #GET KEY ADDRESS           #
        PRIMKEY = FALSE;           # PRESET PRIMARY KEY FLAG           #
        FOR I = I WHILE (NOT PRIMKEY) DO
          BEGIN 
          DE$GTSB(KEYENTRY,3,      # USE DIRECTORY ACCESS ROUTINE TO   #
                DCADDR);           # READ 3 WORDS FROM KEY ADDRESS INTO#
                                   # ARRAY KEYENTRY                    #
         IF DASTATE[0] EQ 1        # ADDRESS OUTSIDE FILE LIMITS       #
         THEN 
           BEGIN
           DIAGDL(118);            # INTERNAL DML ERROR                #
           END
          IF SBDCKEYPRI[1]         # IF PRIMARY KEY                    #
          THEN
            BEGIN 
            DCADDR = SBDCNXTAREAP[0]
                 + L;         # GET ADDRESS OF NEXT AREA DC ENTRY      #
            PRIMKEY = TRUE;        # SET PRIMARY KEY FLAG              #
            ITEMADDR = SBDCKEYDNADR[2];    # WORD ADDRESS OF KEY ENTRY #
            DE$GTSB(ITEMENTRY,2,   # USE DIRECTORY ACCESS ROUTINE TO   #
                ITEMADDR);         # READ 2 WORDS FROM ITEMADDR INTO   #
                                   # ARRAY ITEMENTRY                   #
            IF DASTATE[0] EQ 1     # ADDRESS OUTSIDE FILE LIMITS       #
            THEN
              BEGIN 
              DIAGDL(118);         # INTERNAL DML ERROR                #
              END 
            I=SBITMBWP[0];         # GET BEGINNING WORD POS OF KEY     #
            C<18,10>SETINVOKEKA =  # CONVERT TO OCTAL DISPLAY AND      #
                  XCOD(I);         # WRITE TO SKELETON CALL            #
            C<32,10>FT5INVOKEKA =  # WRITE BEGINNING WORD POS OF KEY TO#
                   XCOD(I);        # FTN5 SKELETON CALL                #
            END 
          ELSE
            BEGIN 
            DCADDR=SBDCKEYNITM[1]+DCADDR;   # GET NEXT KEY ENTRY       #
            END 
          END 
  
          I = J;                 # I BECOMES REALM ORDINAL             #000380
          ORDCONVERT;            # CONVERT ORDINAL TO DISPLAY          #000390
          IF SBCWSSTYPE[0] EQ "FT4"  # IF FORTRAN 4 SUBSCHEMA, USE A   #
          THEN                       # DIFFERENT FORMATTED DML STMT.   #
            BEGIN 
            C<9,4>SETWSA = C<1,4>DISPLAYORD;
            C<26,4>SETWSA = C<1,4>DISPLAYORD; 
            WDMLOUT(SETWSA,35); 
            END 
          ELSE                       # FORTRAN 5 SUBSCHEMA.            #
            BEGIN 
            C<9,4>SETWSAF5 = C<1,4>DISPLAYORD;
            C<26,4>SETWSAF5 = C<1,4>DISPLAYORD; 
            WDMLOUT(SETWSAF5,60); 
            END 
        C<9,4>SETINVOKEKA =        # INSERT REALM ORDINAL              #
                          C<1,4>DISPLAYORD; 
        C<9,4>FT5INVOKEKA = 
                           C<1,4>DISPLAYORD;
          C<9,4>SETKA = C<1,4>DISPLAYORD;                               000420
          C<21,4>SETKA = C<1,4>DISPLAYORD;                              000430
          C<33,4>SETKA = C<1,4>DISPLAYORD;                              000440
                                                                        000450
            IF DDLCOMP EQ F4       # IF FTN4 COMPILATION               #
            THEN
              BEGIN 
              WDMLOUT(SETINVOKEKA,29);
              END 
            ELSE
              BEGIN 
              WDMLOUT(FT5INVOKEKA,44);
              END 
          WDMLOUT(SETKA,41);                                            000470
        END                                                             000480
      STDYES;                    # RETURN YES                          #000490
                                                                        000500
FITLISTCALL:                                                            000510
#**********************************************************************#000520
#                                                                      #000530
#                   F I S T L I S T C A L L                            #000540
#                                                                      #000550
#     WRITES ASSIGNMENT STMT TO INITIALIZE THE FITLIST                 #000560
#     FOR EACH RELATION. THE STMT IS "DBNXXXX(XXXX)=LOCF(DBFXXXX)."    #000570
#     A STMT IS GENERATED FOR EACH ENTRY IN EACH FITLIST. IF THERE ARE #000580
#     NO RELATIONS, RETURNS NO. EACH RELATION ENTRY IS READ. IF THERE  #000590
#     ARE ANY DATA NAMES IN THE SUBSCHEMA AND IF THERE IS A RESTRICT   #000600
#     FOR THIS RELATION, THE CODE TO INITIALIZE THE RELATION USAGE     #000610
#     LIST IS EXECUTED. THE RELATION USAGE LIST CODE IS DESCRIBED      #000620
#     BELOW. THE RELATION ORDINAL IS STORED IN THE STATEMENT AND ALL   #000630
#     DBI ENTRIES FOR THAT RELATION ARE READ. STMTS ARE GENERATED FOR  #000640
#     EACH AREA IN THE RELATION AND THEN THE PROCESS CONTINUES FOR EACH#000650
#     RELATION. RETURNS TO STDYES.                                     #000660
#                                                                      #000670
#**********************************************************************#000680
                                                                        000690
      IF SBCWNUMRELS[0] EQ 0     # IF NO RELATIONS, RETURN NO          #000700
      THEN                                                              000710
        STDNO;                                                          000720
                                                                        000730
                                 # GET ADDR OF 1ST RELATION ENTRY      #000740
      RELADDR = SBCWFRSTRELA[0];                                        000300
                                 # LOOP ON NUMBER OF RELATIONS         #000760
      FOR J = 1 STEP 1 UNTIL SBCWNUMRELS[0] DO                          000770
        BEGIN                                                           000780
                                 # READ RELATION ENTRY                 #000790
          DE$GTSB (RELENTRY,     # AREA TO READ INTO                   #000800
                   2,            # NUMBER OF WORDS TO READ             #000810
                   RELADDR);     # ADDR TO READ FROM                   #000820
                                                                        000830
          IF DASTATE[0] EQ 1     # ADDRESS OUTSIDE FILE LIMITS         #000840
          THEN                                                          000850
            DIAGDL(118);         # INTERNAL DML ERROR                  #000860
                                                                        000870
          IF SBCWDNSBUFSZ[0] NQ 0 # IF THERE ARE                       #000880
                                 # DATA NAMES IN THE SS                #000890
          AND                    # AND IF THERE IS A RESTRICT          #000900
                                 # FOR THIS RELATION                   #000910
          RSTRQTPTR[0] NQ 0                                             000480
          THEN BEGIN                                                    000930
#     THIS SECTION OF FITLISTCALL GENERATES THE ASSIGNMENT STMTS       #000940
#     TO STORE THE ADDRESSES OF THE DATA NAMES INTO THE RELATION       #000950
#     USAGE LIST.  IF FTN4, THE STMT IS "DBRELST(XXXX)=DBRELST(XXXX)   #
#     .OR. LOCF(DATANAME)".  THE ADDRESS IS OR'D IN SO THE REST OF THE #
#     DATA IN THE WORD WILL NOT BE AFFECTED.  IF FTN5, THE BEGINNING   #
#     CHARACTER POSITION IS ALSO STORED.  THERE ARE SEVERAL STATEMENTS #
#     TO DO THIS SINCE THE BCP FIELD MUST FIRST BE SHIFTED TO MATCH    #
#     THE FORMAT USED BY CDCS.  THE RQT ENTRY FOR THE RELATION IS READ.#
#     IF ANY OF THE ENTRIES ARE DATA NAMES, THE ASSOCIATED ATTRIBUTE   #
#     ENTRY IS ADDRESSED.  THE DATA NAME IS STORED IN THE STMT AND     #
#     SUBSCRIPT IS INCREMENTED.                                        #
                                                                        001020
            TEMP = RELISTSUB;    # SAVE RELIST SUBSCRIPT               #001030
                                 # READ RQT HEADER                     #001040
            DE$GTSB (RQTHEADER,  # AREA TO READ INTO                   #001050
                     1,          # NUMBER OF WORDS TO READ             #001060
                                 # ADDR TO READ FROM                   #001070
                   RELADDR + RSTRQTPTR[0]);                             000520
                                                                        001090
            P<RQTSTACK> = WORKPTR + FIRSTWORD; # WORKAREA POINTER      #000140
                                 # UPDATE STORAGE TO BE USED           #001110
            WORKPTR = WORKPTR + RQTTBLLENG;                             001120
            CHECKFL;             # CHECK IF WITHIN FIELD LENGTH        #001130
                                                                        001140
                                 # READ RQT ENTRY                      #001150
            DE$GTSB (RQTSTACK,   # AREA TO READ INTO                   #001160
                     RQTTBLLENG, # NUMBER OF WORDS TO READ             #001170
                                 # ADDR TO READ FROM                   #001180
                   RELADDR + RSTRQTPTR[0]);                             000540
                                 # SKIP 1ST WORD (HEADER) WHILE        #001200
                                 # PROCESSING STACK ENTRIES            #001210
            FOR K = 1 STEP 1 UNTIL RQTATTRIBPTR - 1 DO
            BEGIN                                                       001230
                                 # IF IT IS A DATA NAME ENTRY          #001240
              IF RQTSTACKTYPE[K] EQ 3                                   001250
              THEN                                                      001260
              BEGIN                                                     001270
                                 # GET ADDR OF CORRESPONDING           #001280
                                 # ATTRIBUTE ENTRY                     #001290
                P<RQTATTR> = LOC(RQTSTACK) + RQTATRIBTEWA[K]; 
                                 # PICK UP SUBSCRIPT FOR               #001330
                                 # RELATION USAGE LIST                 #001340
                I = RELISTSUB;                                          001350
                ORDCONVERT;                                             001360
                IF DDLCOMP EQ F4
                THEN
                  BEGIN 
                                   # STORE DATA NAME IN STATEMENT      #
                  C<44,7>SETRELIST = C<0,RQTDATALENC>RQTDATANM30; 
                                   # STORE REALM ORD IN STATEMENT      #
                  C<14,4>SETRELIST = C<1,4>DISPLAYORD;
                  C<28,4>SETRELIST = C<1,4>DISPLAYORD;
                  WDMLOUT(SETRELIST,55);  # WRITE OUT STATEMENT        #
                  END 
                ELSE
                  BEGIN 
                                   # STORE DATA NAME IN STATEMENTS     #
                  C<18,7>SETRELST5A = C<0,RQTDATALENC>RQTDATANM30;
                  C<18,7>SETRELST5C = C<0,RQTDATALENC>RQTDATANM30;
                                   # STORE REALM ORD IN STATEMENTS     #
                  C<14,4>SETRELST5B = C<1,4>DISPLAYORD; 
                  C<28,4>SETRELST5B = C<1,4>DISPLAYORD; 
                                   # WRITE OUT STATEMENTS              #
                  WDMLOUT(SETRELST5A,55);  # PICK UP ITEM ADDRESS      #
                  WDMLOUT(SETRELST5B,43);  # STORE ADDRESS             #
                  WDMLOUT(SETRELST5C,55);  # PICK UP BCP               #
                  WDMLOUT(SETRELST5D,28);  # SHIFT BCP TO MATCH CDCS   #
                  WDMLOUT(SETRELST5B,43);  # STORE BCP                 #
                  END 
                                 # INCREMENT SUBSCRIPT FOR             #001400
                                 # RELATION USAGE LIST                 #001410
                RELISTSUB = RELISTSUB + 1;                              001420
              END                                                       001430
                                                                        001440
            END                                                         001450
                                 # IF ANY OF THE RELATION USAGE LIST   #001460
                                 # ENTRIES HAVE BEEN PROCESSED, THEN   #001470
                                 # ADD 1 TO SUBSCRIPT TO BYPASS HEADER #001480
                                 # WORD FOR NEXT RELATION              #001490
            IF RELISTSUB GR TEMP                                        001500
            THEN                                                        001510
              RELISTSUB = RELISTSUB + 1;                                001520
                                 # REUSE STORAGE FOR RQT TABLE         #001530
            WORKPTR = WORKPTR - RQTTBLLENG;                             001540
          END                                                           001550
                                                                        001560
          IF RSTRQTPTR[0] EQ 0 THEN # THERE ISN'T ANY RESTRICT FOR     #
                                 # THIS RELATION                       #
            BEGIN 
            RELISTSUB = RELISTSUB + 1; # BYPASS HEADER WORD OF NEXT REL#
            END 
  
                                                                        001570
          I = RSTRELORD[0];      # PICK UP RELATION ORDINAL            #000560
          ORDCONVERT;            # CONVERT IT TO DISPLAY               #001590
          C<9,4>SETRL = C<1,4>DISPLAYORD; # STORE IT IN STMT           #001600
                                 # LENGTH OF DBI ENTRY IS 2 WORDS FOR  #000122
                                 # 1ST AND LAST AREA AND 4 WORDS       #000124
                                 # FOR ALL OTHER AREAS                 #000126
          K = (RSTHIGHRANK[0] - 2) * 4 + 2*2;                           000130
          P<DBIARRAY> = WORKPTR + FIRSTWORD; # WORKAREA POINTER        #000160
          WORKPTR = WORKPTR + K;  # UPDATE STORAGE TO BE USED          #000150
          CHECKFL;               # CHECK IF WITHIN FIELD LENGTH        #001640
                                                                        001650
                                 # GET ADDR OF FIRST DBI ENTRY         #001660
          DBIADDR = RELADDR + RSTRELNMELW[0] + 2;                       000600
                                 # READ ALL DBI ENTRIES                #001680
                                 # FOR THIS RELATION                   #001690
          DE$GTSB (DBIARRAY,     # AREA TO READ INTO                   #001700
                   K,            # NUMBER OF WORDS TO READ             #000170
                   DBIADDR);     # ADDR TO READ FROM                   #001720
          IF DASTATE[0] EQ 1     # ADDRESS OUTSIDE FILE LIMITS         #001730
          THEN                                                          001740
            DIAGDL(118);         # INTERNAL DML ERROR                  #001750
                                                                        001760
          SUB = 0;               # INITIALIZE SUBSCRIPT                #000320
                                 # LOOP ON NUMBER OF AREAS IN RELATION #001770
          FOR L=1 STEP 1 UNTIL K/2 DO                                   000190
            BEGIN                                                       001790
              I = AREAORD[L];    # PICK UP REALM ORDINAL               #001830
                                                                        000210
              IF L NQ 1                                                 000220
              THEN                                                      000230
                BEGIN                                                   000240
                                 # CHECK FOR SAME AREA                 #000245
                  IF I EQ AREAORD[L-1]                                  000250
                  THEN                                                  000260
                    TEST L;                                             000270
                END                                                     000280
              ORDCONVERT;        # CONVERT IT TO DISPLAY               #001840
              C<28,4>SETRL = C<1,4>DISPLAYORD;                          001850
              SUB = SUB + 1;     # INCREMENT SUBSCRIPT                 #000350
              I = SUB;           # CONVERT IT TO DISPLAY               #000360
              ORDCONVERT;                                               000370
              C<14,4>SETRL = C<1,4>DISPLAYORD; # STORE SUBSCRIPT       #000380
              WDMLOUT(SETRL,35);                                        001860
            END                                                         001870
                                                                        001880
          WORKPTR = WORKPTR - K;   # REUSE MEMORY FOR DBIARRAY         #000300
                                                                        001900
                                 # POINT TO NEXT RELATION ENTRY        #001910
         RELADDR = RELADDR + RSTNXTRSTPTR[0];                           000620
        END                                                             001930
      STDYES;                                                           001940
                                                                        000230
ENDOFPROG:                                                              000240
#**********************************************************************#000250
#                                                                      #000260
#                  E N D O F P R O G                                   #000270
#                                                                      #000280
#     CALLED AT END OF PROGRAM UNIT. VERIFIES THAT IF A SUBSCHEMA      #000290
#     STATEMENT WAS PRESENT, AN INVOKE WAS ALSO INCLUDED. IF NOT       #000300
#     RETURNS NO. TURNS OFF INVOKE FLAG AND ZEROS SUBSCHEMA NAME       #000310
#                                                                      #000320
#**********************************************************************#000330
                                                                        000340
                                 # IF NO SS, THEN NO INVOKE OR DML     #000350
      IF SUBSCHNAME[0] EQ 0                                             000360
      THEN                                                              000370
        STDYES;                                                         000380
                                 # ZERO OUT SUBSCHEMA NAME             #000390
      SUBSCHNAME[0] = 0;                                                000400
      SUBSCHNAME[1] = 0;                                                000410
      SUBSCHNAME[2] = 0;                                                000420
                                 # SS AND INVOKE WERE INCLUDED         #000430
      IF INVOKEFLAG                                                     000440
      THEN                                                              000450
        BEGIN                                                           000460
          INVOKEFLAG = FALSE;                                           000470
          STDYES;                                                       000480
        END                                                             000490
                                 # ERROR - SS STMT BUT NO INVOKE       #000500
      STDNO;                                                            000510
                                                                        001950
SAVERS: 
#**********************************************************************#
#                                                                      #
#           S A V E R S                                                #
#                                                                      #
#     CHECK FOR VALIDITY OF VERSION NAME AND SAVE IT IN A              #
#     LOCAL VARIABLE VERSID                                            #
#                                                                      #
#**********************************************************************#
      VERSID = " ";                # PRESET VERSID TO NULL             #
      IF LITFLAG                   # IF VERSION NAME IS LITERAL        #
      THEN
        BEGIN 
        IF CURLENG LQ 10           # LITERAL LENGTH NOT MORE THAN 10   #
        THEN
          BEGIN 
          VERSID = C<0,CURLENG>CURWRD30[0]; 
          STDYES; 
          END 
        ELSE
          BEGIN 
          STDNO;                   # LITERAL LENGTH TOO LONG.          #
          END 
        END                        # END LITERAL PROCESING             #
  
      ELSE                         # FORTRAN VARIABLE                  #
        BEGIN 
        VERSID = C<0,CURLENG>CURWRD30[0]; 
        STDYES; 
        END 
  
INVOKECALL:                                                             001960
#**********************************************************************#001970
#                                                                      #001980
#                     I N V O K E C A L L                              #001990
#                                                                      #002000
#     WRITES CALL TO DMLINV ON DMLOUT. THE CALL STATEMEMT IS           #002010
#     "CALL DMLINV(XXXX,DBF0001,SS1,SS2,SS3,CHKSUM)"                   #
#     WHERE:                                                           #
#             XXXX     = NUMBER OF REALMS IN SS                        #
#             DBF0001  = ADDR OF FIT FOR REALM 1                       #
#             SS1 - SS3= THIRTY CHARACTER SS NAME                      #
#             CHKSUM   = CHECKSUM                                      #
#     RETURN IS TO STDYES.                                             #
#                                                                      #002040
#**********************************************************************#002050
                                                                        000590
      IF NOT DSOPT               # IF DS OPTION NOT SELECTED           #000630
      THEN                       # GENERATE LIST,ALL DIRECTIVE         #000640
        BEGIN 
        IF DDLCOMP EQ F4         #             IF FTN4                 #
        THEN
          WDMLOUT(LISTALL4,20);  # WRITE OUT FTN4 LIST,ALL DIRECTIVE   #
        ELSE                     #         ELSE, ASSUME FTN5           #
          WDMLOUT(LISTALL5,20);  # WRITE OUT FTN5 LIST,ALL DIRECTIVE   #
        END 
  
      INVOKEFLAG = TRUE;                                                000600
  
                                 #------INSERT NUMBER OF REALMS--------#
                                                                        002060
      I = SBCWNUMAREAS[0];       # NUMBER OF REALMS IN SUBSCHEMA       #002070
      ORDCONVERT;                # CONVERT IT TO DISPLAY               #002080
      IF VERSID EQ " "             # NO VERSION NAME SPECIFIED         #
      THEN
      BEGIN 
      C<18,4>CALLINV = C<1,4>DISPLAYORD; # PUT IT IN STMT              #002090
  
                                   #----------INSERT LABEL-------------#
  
      C<0,5>CALLINV = CURLABEL;    # MOVE LABEL FROM DML STMT TO CALL  #
  
                                   #--------INSERT NAME----------------#
  
      CHARTEMP = C<0,SSLENG>SSNAME30[0];  # BLANK FILL SS NAME         #
      C<34,10>CALLINV = C<0,10>CHARTEMP;  # PLACE 20 CHAR OF SS NAME   #
      C<48,10>CALLINV = C<10,10>CHARTEMP;  # INTO INVOKE CALL STMT     #
  
                                   #-------PRINT COMMON PORTION--------#
  
      WDMLOUT(CALLINV,70);         # WRITE COMMON PART OF INVOKE CALL  #
      END 
      ELSE                         # VERSION NAME USED                 #
        BEGIN 
        C<19,4>CALLINVV = C<1,4>DISPLAYORD;  # INSERT NO OF REALMS     #
        C<0,5>CALLINVV = CURLABEL; # MOVE LABEL FROM DML STMT TO CALL  #
        CHARTEMP = C<0,SSLENG>SSNAME30[0];   # BLANK FILL SS NAME      #
        C<35,10>CALLINVV = C<0,10>CHARTEMP;  # FIRST 20 CHARS OF       #
        C<49,10>CALLINVV = C<10,10>CHARTEMP; # SUBSCHEMA NAME          #
  
        WDMLOUT(CALLINVV,70);      # WRITE CALL TO DMLOUT              #
        END 
  
  
                                   #----INSERT AND PRINT CHECKSUM------#
                                   #------AND REMAINDER OF NAME--------#
  
      IF DDLCOMP EQ F4             # FTN4 INVOKE                       #
      THEN
        BEGIN 
        IF VERSID EQ " "           # ORDINARY INVOKE                   #
        THEN
          BEGIN                    # INSERT REMAINDER OF SS NAME       #
          C<9,10>CALLIN4 = C<20,10>CHARTEMP;
                                   # INSERT CHECKSUM(CONVERTED)        #
          C<20,10>CALLIN4 = XCOD(SBCWSBCKSUM1[0]);
          C<30,10>CALLIN4 = XCOD(SBCWSBCKSUM2[0]);
          WDMLOUT(CALLIN4,50);
          END 
        ELSE                       # INVOKE WITH VERSION               #
          BEGIN                    # INSERT REMAINDER OF SS NAME       #
          C<9,10>CALLINVV4 = C<20,10>CHARTEMP;
                                   # INSERT CHECKSUM(CONVERTED)        #
          C<20,10>CALLINVV4 = XCOD(SBCWSBCKSUM1[0]);
          C<20,10>CALLINVV4 = XCOD(SBCWSBCKSUM2[0]);
          IF LITFLAG               # IF LITERAL                        #
          THEN
            BEGIN                  # INSERT COMMA AND PAREN IF THEY    #
            C<41,1>CALLINVV4=",";  # ARE OVERWRITTEN IN PREVIOUS CALLS #
            C<51,9>CALLINVV4=") ";
            C<42,1>CALLINVV4="""";    # INSERT QUOTE MARK IN SKELETON  #
            C<43,7>CALLINVV4=VERSID;  # MOVE VERSION LITERAL TO CALL   #
            C<50,1>CALLINVV4="""";    # INSERT QUOTE MARK IN SKELETON  #
            WDMLOUT(CALLINVV4,60);
            END 
          ELSE
            BEGIN 
            C<42,7>CALLINVV4 = VERSID;
            C<49,11>CALLINVV4 = ") "; 
            WDMLOUT(CALLINVV4,60);
            END 
          END 
        END 
  
      ELSE                         # FTN5 INVOKE                       #
        BEGIN 
        IF VERSID EQ " "           # ORDINARY INVOKE                   #
        THEN
          BEGIN                    # INSERT REMAINDER OF SS NAME       #
          C<9,10>CALLIN5 = C<20,10>CHARTEMP;
                                   # INSERT CHECKSUM(CONVERTED)        #
          C<22,10>CALLIN5 = XCOD(SBCWSBCKSUM1[0]);
          C<32,10>CALLIN5 = XCOD(SBCWSBCKSUM2[0]);
          WDMLOUT(CALLIN5,50);
          END 
        ELSE                       # INVOKE WITH VERSION               #
          BEGIN                    # INSERT REMAINDER OF SS NAME       #
          C<9,10>CALLINVV5 = C<20,10>CHARTEMP;
                                   # INSERT CHECKSUM(CONVERTED)        #
          C<22,10>CALLINVV5 = XCOD(SBCWSBCKSUM1[0]);
          C<32,10>CALLINVV5 = XCOD(SBCWSBCKSUM2[0]);
          IF LITFLAG               # IF VERSION IS LITERAL             #
          THEN
            BEGIN 
            C<44,1>CALLINVV5 = """";    # INSERT QUOTES IN SKELETON    #
            C<52,1>CALLINVV5 =""""; 
            C<45,7>CALLINVV5 = VERSID;  # MOVE VERSION LITERAL TO CALL #
            C<53,9>CALLINVV5 = ") ";    # INSERT PAREN                 #
            WDMLOUT(CALLINVV5,60);
            END 
          ELSE                     # FTN NAME                          #
            BEGIN 
            C<44,7>CALLINVV5 = VERSID;  # MOVE VERSION NAME TO CALL    #
            C<51,10>CALLINVV5 = ") "; 
            WDMLOUT(CALLINVV5,60);
            END 
          END 
        END 
        VERSID = " "; 
        LITFLAG = FALSE;
  
      STDYES;                                                           002110
                                                                        002120
VERSCALL: 
#**********************************************************************#
#                                                                      #
#           V E R S C A L L                                            #
#                                                                      #
#     THIS ROUTINE WRITES CALL TO DMLVERS ON DMLOUT.                   #
#                                                                      #
#     THE CALL STATEMENT IS:                                           #
#                                                                      #
#     CALL DMLVERS(VERSNAM,ERRRTN)                                     #
#                                                                      #
#**********************************************************************#
      C<0,5>CALLVERS = CURLABEL;   # MOVE LABEL FROM DML STMT TO CALL  #
      IF LITFLAG                   # VERSION NAME IS LITERAL           #
      THEN
        BEGIN 
        C<19,1>CALLVERS = """";    # INSERT QUOTES TO SKELETON         #
        C<27,1>CALLVERS = """"; 
        C<20,7>CALLVERS = VERSID;  # MOVE VERSION LITERAL TO SKELETON  #
        END 
      ELSE                         # FTN NAME                          #
        BEGIN 
        C<19,1>CALLVERS = " ";     # CLEAR QUOTE MARKS IN CASE IT IS   #
        C<27,1>CALLVERS = " ";     # THERE                             #
        C<20,7>CALLVERS = VERSID;  # MOVE FTN NAME TO SKELETON         #
        END 
      IF C<0,1>ERRSAVE EQ "*"      # IF ERRSAVE CONTAINS A VALID LABEL #
      THEN
        BEGIN 
        C<28,8>CALLVERS =",      )";  # INSERT COMMA AND RIGHT PAREN   #
        C<29,6>CALLVERS =ERRSAVE;     # STORE LABEL IN ERRRTN          #
        END 
      ELSE
        BEGIN 
        C<28,8>CALLVERS = ")       "; # OVERWRITE ERRRTN PARAMETER     #
        END 
      VERSID = " ";                # RESET VERSID                      #
      ERRSAVE = "NUTHIN";          # RESET ERRSAVE                     #
      LITFLAG = FALSE;             # RESET LITERAL FLAG                #
      WDMLOUT(CALLVERS,40); 
      STDYES; 
  
TERMCALL:                                                               002130
#**********************************************************************#002140
#                                                                      #002150
#                    T E R M C A L L                                   #002160
#                                                                      #002170
#     WRITES CALL TO DB$END ON DMLOUT.                                 #002180
#                                                                      #002190
#**********************************************************************#002200
                                                                        002210
                                 # MOVE LABEL FROM DML STMT TO CALL    #000680
      C<0,5>CALLEND = CURLABEL;                                         000690
      WDMLOUT(CALLEND,20);       # WRITE STATEMENT                     #002220
      STDYES;                                                           002230
                                                                        002240
                                                                        002250
                                                                        001140
LOCKCALL:                                                               001150
#**********************************************************************#001160
#                                                                      #001170
#                    L O C K C A L L                                   #001180
#                                                                      #001190
#     WRITES CALL TO DMLLCK OR DMLLCKP ON DMLOUT, BASED ON LOCK TYPE.  #
#                                                                      #
#     THE CALL STATEMENT IS:                                           #
#         " CALL DMLLCK (FIT,REALM ORDINAL,ERRRTN) "                   #
#      OR " CALL DMLLCKP(FIT,REALM NAME,LOCK TYPE,ERRRTN) "            #
#                                                                      #
#     IF AN *ON ERROR* ALTERNATE RETURN IS SPECIFIED ERRRTN WILL       #
#     HOLD THE LABEL SPECIFIED, ELSE IT WILL BE BLANKED OUT.           #
#     THE REALM ORDINAL IS CONVERTED INTO DISPLAY CODE AND STORED      #001220
#     IN THE CALL STATEMENT. THE STATEMENT IS WRITTEN TO DMLOUT AND    #001230
#     RETURN IS TO STDYES.                                             #001240
#                                                                      #001250
#**********************************************************************#001260
                                                                        001270
      I = REALMORDINAL;          # PICK UP REALM ORDINAL               #001280
      ORDCONVERT;                # CONVERT REALM ORDINAL TO DISPLAY    #
      IF TYPID EQ " " 
      THEN
      BEGIN 
      C<21,4>CALLLCK = C<1,4>DISPLAYORD;                                001040
      C<26,4>CALLLCK = C<1,4>DISPLAYORD;                                001050
                                 # MOVE LABEL FROM DML STMT TO CALL    #000710
      C<0,5>CALLLCK = CURLABEL;                                         000720
      IF C<0,1>ERRSAVE EQ "*"    # IF ERRSAVE CONTAINS A VALID LABEL   #
      THEN
        BEGIN 
        C<30,8>CALLLCK = ",      )";  # INSERT COMMA AND RIGHT PAREN   #
        C<31,6>CALLLCK = ERRSAVE;# STORE THE LABEL IN ERRRTRN          #
        END 
      ELSE                       #                 ELSE                #
        C<30,8>CALLLCK = ") ";   # OVERWRITE ERRRTRN PARAMETER         #
  
        END      # END EMPTY TYPE PARAMETER  #
      ELSE                         # TYPE PARAMETER EXISTS             #
      BEGIN 
      C<0,5>CALLCKP1 = CURLABEL; # MOVE LABEL FROM DML STATEMNT TO CALL#
      C<22,4>CALLCKP1 = C<1,4>DISPLAYORD;    # PUT ORDINAL IN STMT     #
      C<30,10>CALLCKP1 = C<0,10>CHARTEMP; 
      C<44,10>CALLCKP1 = C<10,10>CHARTEMP;   # MOVE REALM NAME         #
      C<9,10>CALLCKP2 = C<20,10>CHARTEMP;    # TO CALL STMT            #
  
      IF LITFLAG                   # TYPE PARAMETER IS A LITERAL       #
      THEN
        BEGIN 
        C<20,1>CALLCKP2 =  """";   # INSERT QUOTE MARKS IN CALL STMT   #
        C<31,1>CALLCKP2 = """"; 
        C<21,10>CALLCKP2 = TYPID;  # MOVE THE PARAM TO CALL STMT       #
        END 
      ELSE
        BEGIN 
        C<20,7>CALLCKP2 = TYPID;   # MOVE FTN TYPE NAME TO CALL STMT   #
        C<27,6>CALLCKP2 = " ";
        END 
        IF C<0,1>ERRSAVE EQ "*"    # ERROR LABEL EXISTS                #
        THEN
          BEGIN 
          C<32,8>CALLCKP2 = ",      )"; 
          C<33,6>CALLCKP2 = ERRSAVE;
          END 
        ELSE
          BEGIN 
          C<32,8>CALLCKP2 = ") "; 
          END 
        END 
      ERRSAVE = "NUTHIN";        # RESET ERRSAVE                       #
                                 # WRITE CALL STMT TO DMLOUT           #001350
                                   # WRITE CALL STMT TO DMLOUT         #
        IF TYPID EQ " " 
        THEN
          BEGIN 
          WDMLOUT(CALLLCK,45);
          END 
        ELSE
          BEGIN 
          WDMLOUT(CALLCKP1,60); 
          WDMLOUT(CALLCKP2,45); 
          END 
        TYPID = " ";
        LITFLAG = FALSE;
         STDYES;
  
COMMITCALL: 
#**********************************************************************#
#                                                                      #
#         C O M M I T C A L L                                          #
#                                                                      #
#     THIS ROUTINE WRITES CALL TO DMLCMT ON DMLOUT.                    #
#                                                                      #
#     THE CALL STATEMENT IS                                            #
#                                                                      #
#     CALL DMLCMT(ERRRTN)                                              #
#                                                                      #
#**********************************************************************#
  
      C<0,5>CALLCOMMIT = CURLABEL; # MOVE LABEL FROM DML STTMNT TO CALL#
      IF C<0,1>ERRSAVE EQ "*" 
      THEN
        BEGIN 
      C<18,6>CALLCOMMIT = ERRSAVE;   # MOVE ERROR LABEL TO STMT        #
        C<17,1>CALLCOMMIT = "(";   # INSERT PARENTHESIS                #
        C<24,1>CALLCOMMIT = ")";   # IN SKELETON                       #
        END 
      ELSE
        BEGIN 
        C<17,8>CALLCOMMIT = " ";
        END 
  
      WDMLOUT(CALLCOMMIT,30); 
      ERRSAVE = "NUTHIN";          #RESET ERRSAVE                      #
      STDYES; 
  
  
  
DROPCALL: 
#**********************************************************************#
#                                                                      #
#         D R O P C A L L                                              #
#                                                                      #
#     THIS ROUTINE WRITES CALL TO DMLDRP IN DMLOUT.                    #
#                                                                      #
#     THE CALL STATEMENT IS                                            #
#                                                                      #
#     CALL DMLDRP(ERRRTN)                                              #
#                                                                      #
#**********************************************************************#
  
        C<0,5>CALLDRP = CURLABEL;  # MOVE LABEL FROM DML STTMNT TO CALL#
        IF C<0,1>ERRSAVE EQ "*"    # ERRSAVE CONTAINS VALID LABEL      #
        THEN
          BEGIN 
          C<18,6>CALLDRP = ERRSAVE;   # INSERT ERROR LABEL IN CALL STMT#
          C<17,1>CALLDRP = "(";       # INSERT COMMA AND PAREN INTO    #
          C<24,1>CALLDRP = ")";       # THE CALL STMT                  #
          END 
        ELSE
          BEGIN 
          C<17,8>CALLDRP = " "; 
          END 
        WDMLOUT(CALLDRP,30);       # WRITE DROP CALL STMT TO DMLOUT    #
        ERRSAVE = "NUTHIN";        # RESET ERRSAVE                     #
        STDYES; 
  
  
                                                                        001370
      STDYES;                    # RETURN YES                          #001380
                                                                        001390
UNLOCKCALL:                                                             001400
#**********************************************************************#001410
#                                                                      #001420
#                    U N L O C K C A L L                               #001430
#                                                                      #001440
#     THIS ROUTINE WRITES CALL TO DMLUNL ON DMLOUT.                    #001450
#                                                                      #
#     THE CALL STATEMENT IS:                                           #
#     " CALL DMLUNL (FIT,REALM ORDINAL,ERRRTN) "                       #
#                                                                      #
#     IF AN *ON ERROR* ALTERNATE RETURN IS SPECIFIED ERRRTN WILL       #
#     HOLD THE LABEL SPECIFIED, ELSE IT WILL BE BLANKED OUT.           #
#     THE REALM ORDINAL IS CONVERTED INTO DISPLAY CODE AND STORED      #001470
#     IN THE CALL STATEMENT. THE STATEMENT IS WRITTEN TO DMLOUT AND    #001480
#     RETURN IS TO STDYES.                                             #001490
#                                                                      #001500
#**********************************************************************#001510
                                                                        001520
      I = REALMORDINAL;          # PICK UP REALM ORDINAL               #001530
                                 # CALL PROC TO CONVERT ORDINAL        #001540
                                 # TO DISPLAY CODE                     #001550
      ORDCONVERT;                                                       001560
                                 # PUT ORDINAL IN CALL STMT            #001570
      C<21,4>CALLUNL = C<1,4>DISPLAYORD;                                001090
      C<26,4>CALLUNL = C<1,4>DISPLAYORD;                                001100
                                 # MOVE LABEL FROM DML STMT TO CALL    #000740
      C<0,5>CALLUNL = CURLABEL;                                         000750
  
      IF C<0,1>ERRSAVE EQ "*"    # IF ERRSAVE CONTAINS A VALID LABEL   #
      THEN
        BEGIN 
        C<30,8>CALLUNL = ",      )";  # INSERT COMMA AND RIGHT PAREN   #
        C<31,6>CALLUNL = ERRSAVE;# STORE THE LABEL IN ERRRTRN          #
        END 
      ELSE                       #                 ELSE                #
        C<30,8>CALLUNL = ") ";   # OVERWRITE ERRRTRN PARAMETER         #
  
      ERRSAVE = "NUTHIN";        # RESET ERRSAVE                       #
                                 # WRITE CALL STMT TO DMLOUT           #001600
      WDMLOUT (CALLUNL,45); 
  
                                                                        001620
      STDYES;                    # RETURN YES                          #001630
                                                                        001640
PRIVACYCALL:                                                            001650
#**********************************************************************#001660
#                                                                      #001670
#                    P R I V A C Y C A L L                             #001680
#                                                                      #001690
#     THIS ROUTINE WRITES CALL TO DMLPRV ON DMLOUT.                    #001700
#     THE CALL STATEMENT IS:                                           #
#                                                                      #
#  "CALL DMLPRV(PRVFLAG,1,0,ORDINAL,MODE,PRIVACY1,PRIVACY2,PRIVACY3)"  #
#                                                                      #
#     IF NO PRIVACY PARAM WAS FOUND, ISSUES DIAG AND RETURNS YES.      #001720
#     THE REALM ORDINAL IS CONVERTED INTO DISPLAY                      #000160
#     CODE AND STORED IN THE CALL STATEMENT.                           #000170
#     THE MODE OPTION IS CONVERTED INTO AN OCTAL CODE AND STORED       #001730
#     IN THE CALL STATEMENT. THE PRIVACY PARAMETER(S) CONSIST OF ONE   #
#     ITEM VARIABLE OR A THREE WORD HOLLERITH LITERAL. THE EXISTANCE   #
#     OF A THREE WORD PRIVACY LITERAL IS FLAGGED IN PRVFLAG.           #
#     THE STATEMENT IS WRITTEN TO DMLOUT AND RETURN IS TO STDYES.      #
#                                                                      #001760
#**********************************************************************#001770
                                                                        001780
      IF PRIVPARCNT EQ 0         # IF PRIVACY PAR NOT FOUND,           #001790
      THEN                                                              001800
        BEGIN                                                           001810
          DIAGDL(125);           # ISSUE DIAG AND                      #001820
          STDYES;                # RETURN YES                          #001830
        END                                                             001840
                                                                        001850
      I = REALMORDINAL;          # PICK UP REALM ORDINAL               #000190
                                 # CALL PROC TO CONVERT ORDINAL        #000200
                                 # TO DISPLAY CODE                     #000210
      ORDCONVERT;                                                       000220
                                 # PUT ORDINAL IN CALL STMT            #000230
      C<24,4>CALLPRV = C<1,4>DISPLAYORD;
                                 # IF MODE PAR NOT FOUND, DEFAULT IS IO#001880
      IF MODEPARCNT EQ 0 THEN MODE = "IO";                              001890
                                                                        001950
                                 # MOVE LABEL FROM DML STMT TO CALL    #000770
      C<0,5>CALLPRV = CURLABEL;                                         000780
  
      IF DDLCOMP EQ F4             #--------IF FORTRAN VERSION 4-------#
      THEN
        BEGIN                      # CONVERT MODE TO AN OCTAL CODE AND #
        IF MODE EQ "IO"            # PUT IT IN CALL STATEMENT          #
                                   # NOTE : FTN4 OCTAL CODE IS PLACED  #
                                   #        OVER O""XX"" IN CALLPR1    #
        THEN
          C<6,5>CALLPR1 = "60B";   # IO BECOMES 60B                    #
        ELSE
          IF MODE EQ "I"
          THEN
            C<6,5>CALLPR1 = "40B"; # I BECOMES 40B                     #
          ELSE
            C<6,5>CALLPR1 = "20B"; # O BECOMES 20B                     #
        END 
      ELSE                         #-------ELSE, ASSUME FORTRAN 5------#
        BEGIN 
        IF MODE EQ "IO"            # CONVERT MODE TO AN OCTAL CODE AND #
        THEN                       # PUT IT IN CALL STATEMENT          #
          C<8,2>CALLPR1 = "60";    # IO BECOMES O"60"                  #
        ELSE
          IF MODE EQ "I"
          THEN
            C<8,2>CALLPR1 = "40";  # I BECOMES O"40"                   #
          ELSE
            C<8,2>CALLPR1 = "20";  # O BECOMES O"20"                   #
        END 
  
      IF LITFLAG                   # IF PRIVACY PARAMETER IS A LITERAL #
      THEN
        BEGIN 
        C<12,1>CALLPR1 = """";     # PUT QUOTES IN PRIVACY CALL STMT   #
        C<23,1>CALLPR1 = """";
        C<25,1>CALLPR1 = """";
        C<36,1>CALLPR1 = """";
        C<38,1>CALLPR1 = """";
        C<49,1>CALLPR1 = """";
  
        C<24,1>CALLPR1 = ",";      # INSERT COMMAS AND *)* IN CASE     #
        C<37,1>CALLPR1 = ",";      # IT WAS BLANKED BY PREVIOUS CALL   #
        C<50,1>CALLPR1 = ")"; 
  
        C<13,10>CALLPR1 = C<0,10>PRIVACY; # PUT PRIVACY LITERAL INTO   #
        C<26,10>CALLPR1 = C<10,10>PRIVACY;  # CALL STATEMENT           #
        C<39,10>CALLPR1 = C<20,10>PRIVACY;
  
        C<18,1>CALLPRV = "1";      # PRVFLAG-INDICATES 3 PRIVACY PARMS #
  
        END 
      ELSE                         # ELSE, ONE PRIVACY PARAMETER       #
        BEGIN 
          C<12,7>CALLPR1 = C<0,7>PRIVACY;  # PUT VARIABLE IN CALL      #
          C<19,33>CALLPR1 = ")";           # BLANK OUT REST OF STMT    #
  
          IF DDLCOMP EQ F5         # IF FORTRAN VERSION 5              #
          THEN
            BEGIN 
            C<18,1>CALLPRV = "2";  # PRVFLAG - FTN 5 PRIVACY VARIABLE  #
            END 
  
        END 
  
      WDMLOUT(CALLPRV,35);         # WRITE PRIVACY CALL STMT TO DMLOUT #
      WDMLOUT(CALLPR1,55);
                                                                        000320
      LITFLAG = FALSE;           # RESET LITERAL FLAG                  #000330
                                                                        001980
      STDYES;                    # RETURN YES                          #001990
                                                                        002000
SAVEMODE:                                                               002010
#**********************************************************************#002020
#                                                                      #002030
#                    S A V E M O D E                                   #002040
#                                                                      #002050
#     COUNTS MODE PARAMS ON STATEMENT. IF DUPLICATES - RETURNS NO.     #002060
#     SAVES MODE OPTION. RETURNS YES.                                  #002070
#                                                                      #002080
#**********************************************************************#002090
                                                                        002100
      MODEPARCNT = MODEPARCNT + 1;                                      002110
      IF MODEPARCNT GR 1 THEN STDNO;  # RETURN NO - DUPLICATE PARAM    #002120
                                                                        002130
      MODE = C<0,CURLENG>CURWRD30[0];                                   002140
      STDYES;                    # RETURN YES                          #002150
                                                                        002160
SETLIT:                                                                 000390
      LITFLAG = TRUE;                                                   000400
      STDYES;                                                           000410
SAVEPRIV:                                                               002170
#**********************************************************************#002180
#                                                                      #002190
#                    S A V E P R I V                                   #002200
#                                                                      #002210
#     COUNTS PRIVACY PARAMS ON STATEMENT. IF DUPLICATES - RETURNS NO.  #002220
#     IF PRIVACY OPTION IS TOO LONG, ISSUES DIAG AND RETURNS YES.      #002230
#     SAVES PRIVACY OPTION (NAME OR LITERAL). RETURNS YES.             #002240
#                                                                      #002250
#**********************************************************************#002260
                                                                        002270
      PRIVPARCNT = PRIVPARCNT + 1;                                      002280
      IF PRIVPARCNT GR 1 THEN STDNO;  # RETURN NO - DUPLICATE PARAM    #002290
                                                                        002300
      IF CURLENG GR 30           # IF OPTION TOO LONG (GT 30 CHARS)    #000130
      THEN                       # PLUS 2 QUOTES),                     #002320
        BEGIN                                                           002330
          DIAGDL(124);           # ISSUE DIAG AND                      #002340
          STDYES;                # RETURN YES                          #002350
        END                                                             002360
                                                                        002370
                                                                        000180
      PRIVACY = C<0,CURLENG>CURWRD30[0];                                002380
      STDYES;                    # RETURN YES                          #002390
                                                                        002400
      CONTROL EJECT;                                                    000630
PROC CHECKFL;                                                           000640
      BEGIN                                                             000650
#**********************************************************************#000660
#                                                                      #000670
#                    C H E C K F L                                     #000680
#                                                                      #000690
#     CHECKS IF THE WORKING STORAGE AREA (WORKAREA) HAS EXCEEDED THE   #000700
#     USERS FIELD LENGTH. IF SO, DIAGNOSTIC 126 IS ISSUED AND THE      #000710
#     PRE-PASS IS ABORTED.                                             #000720
#                                                                      #000730
#**********************************************************************#000740
      ITEM S;                                                           000750
                                 # FIRSTWORD IS 1ST AVAILABLE WORD     #000760
                                 # OF MEMORY, WORKPTR IS UPDATED AS    #000770
                                 # MEMORY IS USED.                     #000780
      S = FIRSTWORD + WORKPTR;                                          000790
      IF S + 25 GR DDLSU         # UPDATE STORAGE USED                 #000800
      THEN                                                              000810
        DDLSU = S + 25;                                                 000820
                                                                        000830
      IF S GR LASTWORD           # IS BEYOND CURRENT FIELD LENGTH      #000840
      THEN                                                              000850
        BEGIN                                                           000860
          S = ((S + 25 + 63) / 64) * 64; # IF GREATER THAN MAX FIELD   #000870
          IF S GQ MAXFL          # LENGTH ALLOWED                      #000880
          THEN                   # IN PREPASS, MAX FIELD LENGTH        #000890
            BEGIN                # ALLOWED IS THE USER REQUESTED       #000900
                                 # FIELD LENGTH. MAXFL = LASTWORD      #000910
              DIAGDL(126);       # ISSUE DIAGNOSTIC - INSUFFICIENT FL  #000920
              ABRT1;             # AND ABORT                           #
            END                                                         000940
                                                                        000950
          MEMORY (S);            # ELSE REQUEST MORE FIELD LENGTH      #000960
          LASTWORD = S - 25;                                            000970
        END                                                             000980
      RETURN;                                                           000990
      END                                                               001000
      CONTROL EJECT;                                                    012160
PROC ORDCONVERT;                                                        012170
      BEGIN                                                             012180
#**********************************************************************#012190
#                                                                      #012200
#                    O R D C O N V E R T                               #012210
#                                                                      #012220
#     THIS PROCEDURE IS CALLED TO CONVERT A NUMERIC ORDINAL            #012230
#     TO DISPLAY CODE. INPUT IS THE ORDINAL IN I. OUTPUT IS            #012240
#     THE ORDINAL IN DISPLAY CODE IN DISPLAYORD.                       #012250
#                                                                      #012260
#**********************************************************************#012270
                                                                        012272
      ITEM K;                    # TEMPORARY FIELD                     #000130
      ITEM J;                                                           000140
      ITEM M; 
  
      M = I;
      DIGITCOUNT = 0;                                                   012274
      DISPLAYORD = "00000";                                             012276
      FOR K = 24 STEP -6 WHILE M GR 0 DO
                                                                        012280
        BEGIN                                                           012290
          J = M / 10; 
          B<K,6>DISPLAYORD = M - J * 10 + O"33";
          M = J;
          DIGITCOUNT = DIGITCOUNT + 1;                                  012298
        END                                                             012300
                                                                        012302
      RETURN;                                                           012340
      END                                                               012350
      END                                                               012360
TERM                                                                    012370
