*DECK SET1
USETEXT CCTTEXT 
USETEXT DNTEXT
USETEXT PPTEXT
         PROC SET1; 
         CONTROL PACK;
         CONTROL PRESET;
         BEGIN
         XREF PROC LDPPSET; 
         XDEF PROC CSTPURGE;
          XDEF PROC CSTCHECK; 
*CALL DPPPDDATA 
*CALL PPCOMMON2 
*CALL RCT 
*CALL AUXTVALS
*CALL DNATVALS
*CALL PLTVALS 
         CONTROL EJECT; 
         #THESE DECLARATIONS ARE IN SET 1#
         $BEGIN 
         ARRAY PL [0:11]; 
           ITEM W C(0,0,10);
         DEF W1  #W[0]#;
         DEF W2  #W[1]#;
         DEF W3  #W[2]#;
         DEF W4  #W[3]#;
         DEF W5  #W[4]#;
         DEF W6  #W[5]#;
         DEF W7  #W[6]#;
         DEF W8  #W[7]#;
         DEF W9  #W[8]#;
         DEF W10  #W[9]#; 
         DEF W11  #W[10]#;
         DEF W12  #W[11]#;
         DEF SSP #1#; 
         DEF DSP #2#; 
         $END 
         ITEM DIAG478 B;
         ITEM DIAGCOLUMN; 
         ITEM DIAGLINE; 
         #SUBSCRIPTING DEFINITIONS# 
         DEF    CSTDATANAME  #1#; 
         DEF    CSTLITERAL   #2#; 
         DEF    CSTINDEXNAME #3#; 
         DEF    CSTCOMBO     #4#; 
         DEF    CSTDUMMY     #5#; 
         DEF CSTREL    #6#; 
  
         DEF    DSLENGTH     #50#;
PROC VERIFYIMP (P1);
         BEGIN
         ITEM P1; 
         ITEM I;
         ITEM J;
         XREF PROC GETPLST; 
         # P1 IS A PLT INDEX #
         ITEM L;
         ITEM C;
         I = GET(PL$LENGTH,PLT$,P1);
         L = GET(PL$LINE,PLT$,P1);
         C = GET(PL$COLUMN,PLT$,P1);
         IF LOGICALFILE EQ 0
         THEN BEGIN 
              RETURN; 
              END 
         IF I LQ 20 
         THEN BEGIN 
              GETPLST(P1,LOC(C2));
              END 
         ELSE BEGIN 
              ERROR(SEVERE,490,L,C);
              ERROR(SEVERE,180,LINE$,COLUMN$);
              RETURN; 
              END 
         IF (I EQ 08 AND C<00,08>C2 EQ "OUTPUT-C") OR 
            (I EQ 08 AND C<00,08>C2 EQ "TERMINAL") OR 
            (I EQ 10 AND C<00,10>C2 EQ "TERMINAL-C")
         THEN BEGIN 
              RETURN; 
              END 
         IF I GR 7 OR C<0>C2 LS "A" OR C<0>C2 GR "Z"
         THEN BEGIN 
              ERROR(SEVERE,180,LINE$,COLUMN$);
              ERROR(SEVERE,490,L,C);
              RETURN; 
              END 
         FOR J = 1 STEP 1 UNTIL I - 1 
         DO BEGIN 
            IF C<J,1>C2 LS "A" OR C<J,1>C2 GR "9" 
            THEN BEGIN
                 ERROR(SEVERE,180,LINE$,COLUMN$); 
                 ERROR(SEVERE,490,L,C); 
                 RETURN;
                 END
            END 
         END #VERIFYIMP#
PROC TRANSFER;
         BEGIN
         # TRANSFER IS USED TO TRANSFER THE GTEXT # 
         # FOR THE REFERENCE MODIFICATION START OR LENGTH # 
         # FROM FORMULA ( OR THE STACK ) BACK INTO THE STACK #
         # THERE ARE 3 POSSIBILITIES #
  
         # 1) THE ARITHMETIC EXPRESSION IS A SINGLE # 
         #    LITERAL OR DATA-NAME #
         #    IN THIS CASE, FL = -1, FORMULA IS EMPTY # 
         #    AND THE LITERAL OR DATA-NAME IS IN STACK(S) # 
         #    WHEN WE REMOVE(2) THE LITERAL OR DATA-NAME #
         #    WE REMOVE THE OPERAND, TEST IT, PUT IT #
         #    IN RMOPERAND1, AND FL REMAINS -1 #
  
         # 2) THE ARITHMETIC EXPRESSION IS A SINGLE # 
         #    SUBSCRIPTED IDENTIFIER #
         #    IN THIS CASE, FL = -1, FORMULA IS EMPTY # 
         #    AND THE IDENTIFIER IS IN THE STACK #
         #    WHEN WE REMOVE(2) THE IDENTIFIER, WE #
         #    REMOVE THE OPERAND, TEST IT, PUT IT IN #
         #    RMOPERAND1, BUT THE SUBSCRIPTS ARE #
         #    TRANSFERRED INTO FORMULA AND FL WILL #
         #    NO LONGER BE -1 # 
  
         # 3) THE ARITHMETIC EXPRESSION ACTUALLY DOES ARITHMETIC #
         #    IN THIS CASE, FL IS NOT = -1, FORMULA CONTAINS #
         #    ALL OF THE GTEXT FOR THE #
         #    EXPRESSION, AND THE FINAL RESULT TEMP IS IN STACK (S) # 
         #    WHEN WE REMOVE(0) THE TEMP, WE KNOW # 
         #    IT IS NUMERIC, SO NO ATTRIBUTE CHECK IS REQUIRED #
         #    REMOVE(0) MEANS WE KNOW THERE # 
         #    ARE NO SUBSCRIPTS ASSOCIATED WITH THE TEMP #
  
         # THE FINAL STEP IS TO TRANSFER THE CONTENTS OF FORMULA #
         # (IF ANY) FROM FORMULA TO STACK # 
         IF FL EQ -1
         THEN BEGIN 
              # SUBSCRIPTS (IF ANY) GO INTO FORMULA # 
              REG1 = REMOVE(2); 
              OPERANDTEST(REG1);
              RMOPERAND1 = STACK(REG1); 
              END 
         ELSE BEGIN 
              RMOPERAND1 = STACK(REMOVE(0));
              END 
         IF FL NQ -1
         THEN BEGIN 
              FOR FIX1 = 0 STEP 1 UNTIL FL
              DO BEGIN
                 S = S + 1; 
                 XSTACK(S,FORMULA(FIX1)); 
                 END
              FL = -1;
              END 
         END # TRANSFER # 
PROC SUBSCRIPTBUG;
         BEGIN
                   IF SUBSREQUIRED LQ 3 
                   THEN BEGIN 
                        # COMPUTE MESSAGE NUMBER #
                        FIX1 = 134 + SUBSREQUIRED;
                        ERROR(SEVERE,FIX1,TABLELINE,TABLECOLUMN); 
                        END 
                   ELSE BEGIN 
                        # THE WRONG NUMBER OF SUBSCRIPTS #
                        # HAS BEEN SPECIFIED #
                        ERROR(SEVERE,473,TABLELINE,TABLECOLUMN);
                        END 
         END
         ITEM SKIPPURGE B=FALSE;
FUNC AUXVALUE (P1); 
         ITEM I;
         ITEM P1; 
         BEGIN
         FOR I = GET(DN$AUXREF,DNAT$,TABLENAME) 
         WHILE GET(AX$TTYPE,AUX$,I) NQ MAXOCCUR  OR 
              GET(AX$SUBSLVL,AUX$,I) NQ P1  DO
              I = GET(AX$TNEXTPTR,AUX$,I);
         AUXVALUE = I;
         RETURN;
         END
FUNC MAXVALUE (P1); 
         BEGIN
         ITEM P1; 
         ITEM I;
         FOR I = GET(DN$AUXREF,DNAT$,TABLENAME) 
         WHILE GET(AX$TTYPE,AUX$,I) NQ MAXOCCUR OR
               GET(AX$SUBSLVL,AUX$,I) NQ P1 
         DO BEGIN 
            I = GET(AX$TNEXTPTR,AUX$,I);
            END 
         MAXVALUE = GET(AX$MAXOCCNO,AUX$,I);
         END
PROC RANGECHECK (P1,P2);
         BEGIN
         # P1 SUBSCRIPT LEVEL # 
         # P2 SUBSCRIPT MNEMONIC NUMBER # 
         ITEM P1, P2; 
         S = S + 1; 
         XSTACK(S,$RANGE);
         S = S + 1; 
         XSTACK(S,GTX(GSUBVERB,AUXVALUE(P1),P2)); 
         END
FUNC STORAGE(DP); 
         #GIVEN A DATA ITEM, THIS ROUTINE RETURNS THE TOTAL#
         #AMOUNT OF STORAGE ALLOCATED TO IT. THE CALCULATION# 
         #IS COMPLEX ONLY FOR OCCURRING ITEMS.# 
         ITEM  DP            U; 
         ITEM  DEPTH         U; 
         ITEM  L             U; 
         ITEM  REG1          U; 
         ITEM  REG2          U; 
         BEGIN
         L = GET(DN$ITMLEN,DNAT$,DP); 
         #DO WE HAVE AN ARRAY#
         DEPTH = GET(DN$SDEPTH,DNAT$,DP); 
         IF DEPTH NQ 0
         THEN BEGIN 
              #CYCLE THROUGH EACH LEVEL OF SUBSCRIPTS#
              FOR REG1 = 1
              STEP 1
              UNTIL DEPTH 
              DO BEGIN
                 #ACCESS AUX CHAIN# 
                 REG2 = GET(DN$AUXREF,DNAT$,DP);
SR1:  
                 #TEST FOR END OF CHAIN#
                 IF REG2 EQ 0 THEN GOTO SR2;
                 #TEST FOR RIGHT ENTRY AT RIGHT DEPTH#
                 IF GET(AX$TTYPE,AUX$,REG2) NQ MAXOCCUR 
                 OR GET(AX$SUBSLVL,AUX$,REG2) NQ REG1 
                 THEN BEGIN 
                      REG2 = GET(AX$TNEXTPTR,AUX$,REG2);
                      GOTO SR1; 
                      END 
                 #ADD ON LENGTH OF THIS DIMENSION OF ARRAY# 
                 L = L + GET(AX$OCCLEN,AUX$,REG2) 
                 *(GET(AX$MAXOCCNO,AUX$,REG2) - 1); 
SR2:  
                 END
              END 
         STORAGE = L; 
         RETURN;
         END #OF STORAGE# 
FUNC STOROVERLAP(DNAT1,DNAT2);
         #GIVEN TWO DATA ITEMS, THIS ROUTINE RETURNS 1 IF#
         #THEIR STORAGE AREAS IN MEMORY OVERLAP AND RETURNS#
         #0 OTHERWISE.# 
         ITEM  DNAT1         U; 
         ITEM  DNAT2         U; 
         ITEM  MSEC1         U; 
         ITEM  MSEC2         U; 
         ITEM  START1        U; 
         ITEM  START2        U; 
         ITEM  END1          U; 
         ITEM  END2          U; 
  
         BEGIN
         #CHECK MEMORY AREAS FOR OVERLAP# 
         MSEC1 = GET(DN$MAJMSEC,DNAT$,DNAT1); 
         MSEC2 = GET(DN$MAJMSEC,DNAT$,DNAT2); 
         IF MSEC1 EQ MSEC2
         THEN BEGIN 
              #TEST FOR SPECIAL CASES#
              IF MSEC1 EQ FDMSEC OR MSEC1 EQ LINKMSEC 
              THEN BEGIN
                   #IF ONE IS FD OR LINKAGE THE OTHER IS ALSO#
                   #BECAUSE OF ABOVE TEST ON MAJOR MSEC#
                   IF GET(DN$SUBMSEC,DNAT$,DNAT1) 
                   NQ 
                   GET(DN$SUBMSEC,DNAT$,DNAT2)
                     THEN BEGIN 
                          STOROVERLAP = 0;
                          RETURN; 
                          END 
                   #IF SUB$ MSECS ARE THE SAME WE CAN HAVE OVERLAP# 
                   START1 = GET(DN$BYTEOFFS,DNAT$,DNAT1); 
                   START2 = GET(DN$BYTEOFFS,DNAT$,DNAT2); 
                   END
              ELSE BEGIN
                   START1 = GET(DN$LONGOFF,DNAT$,DNAT1);
                   START2 = GET(DN$LONGOFF,DNAT$,DNAT2);
                   END
              END2 = START2 + STORAGE(DNAT2) - 1; 
              IF START1 LQ END2 
              THEN BEGIN
                   END1 = START1 + STORAGE(DNAT1) - 1;
                   IF END1 GQ START2
                     THEN BEGIN 
                          STOROVERLAP = 1;
                          RETURN; 
                          END 
                   END
              END 
         STOROVERLAP = 0; 
         RETURN;
         END   #STOROVERLAP#
     PROC PROTECT (P1); 
         BEGIN
         # P1 IS A STACK INDEX #
         ITEM P1; 
         # PROTECT DETERMINES IF THE DIVISOR OR DIVIDEND IN A # 
         # DIVIDE REMAINDER STATEMENT OVERLAPS THE QUOTIENT # 
         # IF IT DOES, THE OVERLAPPING OPERAND IS MOVED TO A TEMP # 
         # THIS IS DONE TO MAKE THE REMAINDER CALCULATION COME #
         # OUT WITH THE CORRECT ANSWER #
         IF TCODE (P1) EQ GLITREF 
         THEN RETURN; 
         IF STOROVERLAP(TPOINTER(P1),TPOINTER(6)) EQ 1
         THEN BEGIN 
              DNATLENGTH = DNATLENGTH + 1;
              COPYD4(TPOINTER(P1),DNATLENGTH);
              GLOBALTEMP(DNATLENGTH); 
              NGMOVE; 
              NGSTACK(P1);
              XSTACK(P1,GTX(GDATAREF,DNATLENGTH,0));
              NGSTACK(P1);
              END 
         END #PROTECT#
$BEGIN
PROC CSTDUMP; 
         #THIS ROUTINE DUMPS SUBSCRIPT OPTIMIZATION VITAL INFORMATION#
         BEGIN
         W1 = "DUMP OF PO"; 
         W2 = "INTERS, LI"; 
         W3 = "NKS, AND C"; 
         W4 = "ST"; 
         CBLIST(DSP,PL,40); 
         W1 = "POINTERS"; 
         W2 = " ";
         CSTPTRDMP; 
         CSTLINKDMP;
         CSTTBLDMP; 
         END #CSTDUMP#
PROC CSTPTRDMP; 
         #THIS ROUTINE DUMPS SUBSCRIPT OPTIMIZATION VITAL POINTERS# 
         BEGIN
         W3 = "USEDPTR";
         W4 = DEC(CSTUSEDPTR);
         W5 = "UNUSEDPTR";
         W6 = DEC(CSTUNUSEDPTR);
         W7 = "LSTUNUSED";
         W8 = DEC(CSTLSTUNUSED);
         W9 = "UNUSEDLEN";
         W10 = DEC(CSTUNUSEDLEN); 
         W11 = "CURRENTPTR";
         W12 = DEC(CSTCURRENT); 
         CBLIST(SSP,PL,120);
         END #CSTPTRDMP#
PROC CSTLINKDMP;
         #THIS ROUTINE DUMPS ACTIVE AND INACTIVE CST ENTRY CHAINS#
         BEGIN
         ITEM  I             I; 
         ITEM  J             I; 
         #PRINT CHAIN OF USED CST ENTRIES#
         W1 = "USEDCHAIN";
         J = 0; 
         I = CSTUSEDPTR;
         FOR $DUMMY$ = 0
         WHILE I NQ 0 
         DO BEGIN 
            IF J NQ 0 
            THEN BEGIN
                 W1 = " ";
                 END
            FOR J = 1 STEP 1 WHILE (I NQ 0 AND J LS 11) 
            DO BEGIN
               W[J] = DEC(I); 
               I = CSTLINK[I];
               END
            CBLIST(SSP,PL,J * 10);
            END 
         #PRINT CHAIN OF UNUSED CST ENTRIES#
         W1 = "UNUSEDCHN";
         I = CSTUNUSEDPTR;
         J = 0; 
         FOR $DUMMY$ = 0
         WHILE I NQ 0 
         DO BEGIN 
            IF J NQ 0 
            THEN BEGIN
                 W1 = " ";
                 END
            FOR J = 1 STEP 1 WHILE (I NQ 0 AND J LS 11) 
            DO BEGIN
               W[J] = DEC(I); 
               I = CSTLINK[I];
               END
            CBLIST(SSP,PL,J * 10);
            END 
         END #CSTLINKDMP# 
PROC CSTTBLDMP; 
         #THIS ROUTINE DUMPS THE ENTIRE CST IN FORMATTED FORM#
         BEGIN
         ITEM  I             I; 
         W1 = "C S T";
         CBLIST(DSP,PL,10); 
         W1 = "ENTRY";
         W2 = "LINK"; 
         W3 = "TYPE"; 
         W4 = "VAR/MN1";
         W5 = "OCCLEN/MN2"; 
         W6 = "CALCDEPTH";
         W7 = "DELDEPTH"; 
         W8 = "REFCTPTR"; 
         W9  = "REFCTVAL1"; 
         W10 = "REFCTVAL2"; 
         CBLIST(DSP,PL,100);
         FOR I = 1 STEP 1 UNTIL CSTLENGTH 
         DO BEGIN 
            CSTENTRYDMP(I); 
            END 
         END #CSTTBLDMP#
PROC CSTENTRYDMP(I);
         #THIS ROUTINE DUMPS AN INDIVIDUAL CST ENTRY IN FORMATTED FORM# 
         BEGIN
         ITEM  I             I; 
         W1 = DEC(I); 
         W2 = DEC(CSTLINK[I]);
         W3 = DEC(CSTTYPE[I]);
         W4 = DEC(CSTVARIABLE[I]);
         W5 = DEC(CSTOCCLEN[I]);
         W6 = DEC(CSTCALCDEPTH[I]); 
         W7 = DEC(CSTDELDEPTH[I]);
         W8 = DEC(CSTREFCTPTR[I]);
         IF CSTREFCTPTR[I] EQ 0 
         THEN BEGIN 
         W9 = " ";
         W10 = " "; 
         END
         ELSE 
         BEGIN
         W9 = DEC(GET(RCT$ENTRY,RCT$,CSTREFCTPTR[I]));
         W10 = DEC(GET(RCT$ENTRY,RCT$,CSTREFCTPTR[I]+1)); 
         END
         CBLIST(SSP,PL,100);
         END #CSTENTRYDMP#
$END
PROC CSTDELENTRY; 
         #THIS ROUTINE DELETES A SPECIFIED ENTRY FROM THE CST.# 
         #CSTCURRENT POINTS TO THE ENTRY OR BE DELETED WHILE# 
         #CSTPREVIOUS REFERENCES ITS PREDECESSOR IN THE CHAIN#
         #OF ACTIVE ENTRIES.# 
         ITEM  CURRENTLINK   U; 
         BEGIN
         $BEGIN 
         IF CSTDEBUGSW EQ 1 
         THEN BEGIN 
              W1 = "CST DELETE";
              W2 = "ENTRY"; 
              CSTPTRDMP;
              CSTENTRYDMP(CSTCURRENT);
              END 
         $END 
         #SET CONDITIONALITY DEPENDING ON WHETHER THE ENTRY#
         #TO BE DELETED WAS CONDITIONALLY ADDED AT THIS LEVEL.# 
         IF CSTCALCDEPTH[CSTCURRENT] EQ CONDDEPTH 
         THEN CSTDELDEPTH[CSTCURRENT] = 0;
         ELSE CSTDELDEPTH[CSTCURRENT] = CONDDEPTH;
         #REMOVE ENTRY FROM ACTIVE CHAIN# 
         CURRENTLINK = CSTLINK[CSTCURRENT]; 
         CSTLINK[CSTPREVIOUS] = CURRENTLINK;
         #ADD ENTRY TO END OF UNUSED CHAIN# 
         IF CSTUNUSEDPTR EQ 0 
         THEN CSTUNUSEDPTR = CSTCURRENT;
         ELSE CSTLINK[CSTLSTUNUSED] = CSTCURRENT; 
         CSTLINK[CSTCURRENT] = 0; 
         CSTLSTUNUSED = CSTCURRENT; 
         #UPDATE USED CHAIN IF DELETING HEAD ENTRY# 
         IF CSTCURRENT EQ CSTUSEDPTR
         THEN CSTUSEDPTR = CURRENTLINK; 
         #UPDATE CURRENT ENTRY INDEX# 
         CSTCURRENT = CSTPREVIOUS;
         #INCREMENT UNUSED ENTRY COUNTER# 
         CSTUNUSEDLEN = CSTUNUSEDLEN + 1; 
         END   #CSTDELENTRY#
PROC CSTDELETE; 
         #THIS ROUTINE DELETES A SUBSCRIPT CALCULATION AND# 
         #ALL ITS DEPENDENT CALCULATIONS FROM THE CALCULATED# 
         #SUBSCRIPT TABLE.# 
         ITEM  CSTINDEX      U; 
         ITEM  CSTSVDLST     U; 
         BEGIN
         $BEGIN 
         IF CSTDEBUGSW EQ 1 
         THEN BEGIN 
              W1 = "CST DELETE";
              W2 = " "; 
              CSTPTRDMP;
              END 
         $END 
         #SAVE PRIMARY ENTRY# 
         CSTINDEX = CSTCURRENT; 
         #SAVE LASTUNUSED POINTER SO THAT DELETED#
         #ENTRIES ADDED TO THE END OF THE UNUSED #
         #CHAIN BY DELENTRY CAN LATER BE MOVED TO#
         #THE FRONT OF THE UNUSED CHAIN.         #
         CSTSVDLST = CSTLSTUNUSED;
         #KILL PRIMARY CALCULATION# 
         CSTDELENTRY; 
         #SCAN THRU RECENTLY DELETED ENTRIES FOR THEIR DEPENDENTS#
         #LOOP UNTIL END OF UNUSED CHAIN IS ENCOUNTERED#
         #ANY DEPENDENCIES WILL BE ADDED TO END OF UNUSED CHAIN#
         #TO BE PROCESSED IN THEIR TURN FOR FURTHER DEPENDENCIES# 
         FOR $DUMMY$ = 0
         WHILE CSTINDEX NQ 0
         DO   BEGIN 
              CSTPREVIOUS = 0;
              CSTCURRENT = CSTUSEDPTR;
              #CHECK FOR DEPENDENCIES IN THE USED CHAIN#
              FOR $DUMMY$ = 0 
              WHILE CSTCURRENT NQ 0 
              DO   BEGIN
                   IF CSTTYPE[CSTCURRENT] EQ CSTCOMBO 
                   THEN BEGIN 
                        IF CSTINDEX EQ CSTMNEMONIC1[CSTCURRENT] 
                        OR CSTINDEX EQ CSTMNEMONIC2[CSTCURRENT] 
                        THEN  CSTDELENTRY;
                        END 
                   #UPDATE LOOP CONTROL INDICIES# 
                   CSTPREVIOUS = CSTCURRENT;
                   CSTCURRENT = CSTLINK[CSTCURRENT];
                   END
              #UPDATE INDEX TO NEXT RECENTLY DELETED CALCULATION# 
              CSTINDEX = CSTLINK[CSTINDEX]; 
              END 
         #MOVE THE JUST-DELETED ENTRIES TO# 
         #THE FRONT OF THE UNUSED CHAIN.  # 
         CSTLINK[CSTLSTUNUSED] = CSTUNUSEDPTR;
         CSTUNUSEDPTR = CSTLINK[CSTSVDLST]; 
         CSTLINK[CSTSVDLST] = 0;
         CSTLSTUNUSED = CSTSVDLST;
         # MAKE CSTSEARCH START OVER AGAIN #
         CSTPREVIOUS = 0; 
         CSTCURRENT = CSTUSEDPTR; 
         END #CSTDELETE#
  
PROC CSTCHECK;
          BEGIN 
          IF CSTLENGTH GR 400 AND CSTUNUSEDLEN LS 100 THEN
                CSTPURGE; 
          END 
PROC CSTPURGE;
         #THIS ROUTINE KILLS ALL CURRENTLY ACTIVE SUBSCRIPTS.#
         #IT IS TYPICALLY CALLED AT FLOW BLOCK BOUNDARIES.# 
         #LINK ALL UNUSED ENTRIES TOGETHER# 
         BEGIN
         $BEGIN 
         IF CSTDEBUGSW EQ 1 
         THEN BEGIN 
              W1 = "CST PURGE"; 
              W2 = " "; 
              CSTPTRDMP;
              END 
         $END 
         IF SKIPPURGE 
         THEN RETURN; 
         SKIPPURGE = TRUE;
         FOR CSTCURRENT = 1 
         STEP 1  UNTIL CSTLENGTH
         DO   BEGIN 
              #ZERO OUT BOTH WORDS OF CST ENTRY#
              CSTVITALINFO[CSTCURRENT] = 0; 
              #ZERO SECOND WORD AND SET UP LINK#
              CSTMOREINFO[CSTCURRENT] = CSTCURRENT + 1; 
              END 
         #SET UP LINK FIELD OF LAST CST ENTRY#
         CSTLINK[CSTLENGTH] = 0;
         #SET UP CHAIN TO FIRST UNUSED ENTRY# 
         CSTUNUSEDPTR = 1;
         #SET POINTER TO LAST UNUSED ENTRY# 
         CSTLSTUNUSED = CSTLENGTH;
         #INITIALIZE UNUSED ENTRY COUNTER#
         CSTUNUSEDLEN = CSTLENGTH;
         #SET UP CHAIN TO LAST USED ENTRY#
         CSTUSEDPTR = 0;
         $BEGIN 
         IF CSTDEBUGSW EQ 1 
         THEN BEGIN 
              CSTDUMP;
              END 
         $END 
         END   #CSTPURGE# 
PROC CSTELBOWRM;
         #THIS ROUTINE IS CALLED BEFORE EACH SUBSCRIPTED  # 
         #IDENTIFIER IS PROCESSED. IT ENSURES THERE WILL  # 
         #BE ROOM ENOUGH IN THE CST TO HOLD THE WORST CASE# 
         #NUMBER OF NEW CST ENTRIES FOR THE IDENTIFIER. THE#
         #WORST CASE NUMBER IS 3, 7, OR 11.#
         ITEM WORSTCASE      I; 
         BEGIN
         #CALCULATE MAX NUMBER OF CST ENTRIES NEEDED# 
         WORSTCASE = (4 * SUBSREQUIRED) - 1;
         $BEGIN 
         IF CSTDEBUGSW EQ 1 
         THEN BEGIN 
              W1 = "CST ELBOW"; 
              W2 = "ROOM";
              W3 = "WORSTCASE"; 
              W4 = DEC(WORSTCASE);
              W5 = "UNUSEDLEN"; 
              W6 = DEC(CSTUNUSEDLEN); 
              CBLIST(SSP,PL,60);
              END 
         $END 
         IF CSTUNUSEDLEN LS WORSTCASE 
         THEN BEGIN 
              CMM$GLV(CST,2*WORSTCASE+40);
              CSTUNUSEDLEN = CSTUNUSEDLEN + WORSTCASE + 20; 
              FOR FIX1 = CSTLENGTH + 1 STEP 1 UNTIL 
                   CSTLENGTH + WORSTCASE + 20 
                   DO BEGIN 
                   CSTVITALINFO[FIX1] = 0;
                   CSTMOREINFO[FIX1] = FIX1 + 1;
                   END
              CSTLINK[CSTLSTUNUSED] = CSTLENGTH + 1;
                CSTLENGTH = CSTLENGTH + WORSTCASE + 20; 
              CSTLSTUNUSED = CSTLENGTH; 
              CSTLINK[CSTLSTUNUSED ] = 0; 
              END 
         END #CSTELBOWRM# 
PROC CSTADD(P00,P01,P02); 
         #THIS ROUTINE ADDS A NEW SUBSCRIPT CALCULATION ENTRY#
         #TO THE CST. IT DOES SO BY OBTAINING A FREE ENTRY# 
         #FROM THE UNUSED CHAIN, UPDATING IT WITH NEW DATA# 
         #AND ADDING IT TO THE CHAIN OF ACTIVE ENTRIES. THE#
         #CSTELBOWRM WILL HAVE PREVIOUSLY ENSURED THAT SUFFICIENT#
         #CST ENTRIES WILL BE AVAILABLE FOR CURRENT IDENTIFIER# 
         ITEM  P00           U; 
         ITEM  P01           U; 
         ITEM  P02           I; 
         BEGIN
         $BEGIN 
         IF CSTDEBUGSW EQ 1 
         THEN BEGIN 
              W1 = "CST ADD"; 
              W2 = "BEFORE";
              CSTPTRDMP;
              END 
         $END 
         SKIPPURGE = FALSE; 
         #DECREMENT CST UNUSED ENTRY COUNTER# 
         CSTUNUSEDLEN = CSTUNUSEDLEN - 1; 
         #AVAILABLE ENTRY SPECIFIED BY CSTUNUSEDPTR#
         #REMOVE ENTRY FROM CHAIN OF UNUSED ENTRIES#
         CSTCURRENT = CSTUNUSEDPTR; 
         CSTUNUSEDPTR = CSTLINK[CSTCURRENT];
         #KEEP LAST UNUSED IN LINE WITH UNUSED CHAIN# 
         IF CSTUNUSEDPTR EQ 0 
         THEN CSTLSTUNUSED = 0; 
         #ADD ENTRY TO FRONT OF ACTIVE ENTRY CHAIN# 
         CSTLINK[CSTCURRENT] = CSTUSEDPTR;
         CSTUSEDPTR = CSTCURRENT; 
         #IF WE HAVE A SUBSCRIPT WHICH MAY NOT BE EVALUATED#
         #ADD IT TO TABLE WITH A DUMMY TYPE SO THAT IT WILL#
         #NEVER BE FOUND WHEN SEARCHED FOR.#
         #THAT IS, IF IN A CONDITION OR IDENTIFIER-2 WAS USED#
         IF CSUBSFLAG EQ 1 OR 
            IDENTIFIER2 EQ 1 OR 
            REFMOD EQ 1 
         THEN P00 = CSTDUMMY; 
         #FILL IN ENTRY WITH APPROPRIATE DATA#
         CSTTYPE[CSTCURRENT] = P00; 
         CSTVARIABLE[CSTCURRENT] = P01; 
         CSTOCCLEN[CSTCURRENT] = P02; 
         #SET CONDITIONALITY OF COMPUTATION#
         CSTCALCDEPTH[CSTCURRENT] = CONDDEPTH;
         CSTDELDEPTH[CSTCURRENT] = 0; 
         #SET UP REF COUNT ENTRY POINTER - NEXT PAIR IN TABLE#
         CSTREFCTPTR[CSTCURRENT] = RFTLENGTH + 2; 
         #TEST AND UPDATE HIGH WATER MARK IF NECESSARY# 
         IF CSTCURRENT GR CSTMAXNUM 
         THEN CSTMAXNUM = CSTCURRENT; 
         $BEGIN 
         IF CSTDEBUGSW EQ 1 
         THEN BEGIN 
              W1 = "CST ADD"; 
              W2 = "AFTER"; 
              CSTPTRDMP;
              CSTENTRYDMP(CSTCURRENT);
              END 
         $END 
         END   #CSTADD# 
PROC CSTHIT;
         #THIS ROUTINE UPDATES THE CST WHEN A RECURRING#
         #CALCULATION IS DISCOVERED. THE REFERENCE COUNT TABLE# 
         #IS UPDATED IN THE SYNTAX TABLE SUBROUTINES# 
         #MOVE ENTRY TO HEAD OF USED CHAIN UNLESS ALREADY THERE#
         BEGIN
         IF CSTCURRENT NQ CSTUSEDPTR
         THEN BEGIN 
              #REMOVE FROM PLACE IN USED CHAIN# 
              CSTLINK[CSTPREVIOUS] = CSTLINK[CSTCURRENT]; 
              #MOVE ENTRY TO HEAD OF USED CHAIN#
              CSTLINK[CSTCURRENT] = CSTUSEDPTR; 
              CSTUSEDPTR = CSTCURRENT;
         $BEGIN 
         IF CSTDEBUGSW EQ 1 
         THEN BEGIN 
              W1 = "CST HIT"; 
              W2 = " "; 
              CSTPTRDMP;
              END 
         $END 
              END 
         END   #CSTHIT# 
FUNC CSTFIND(P00,P01,P02);
         #THIS ROUTINE,GIVEN CST ENTRY INFORMATION,DETERMINES#
         #IF AN IDENTICAL CALCULATION IS STILL ACTIVE. IF SO# 
         #THE APPROPRIATE CST ENTRY INDEX IS RETURNED OTHERWISE#
         #ZERO IS RETURNED.#
         ITEM  P00           U; 
         ITEM  P01           U; 
         ITEM  P02           I; 
         ARRAY LOCALCST [0] S(1); 
               BEGIN ITEM 
               LOCALP00      U(0,42,18),
               LOCALP01      U(0,0,18), 
               LOCALP02      U(0,18,24),
               VITALINFO     U(0,0,60); 
               END
         #SET UP VITAL INFORMATION# 
         BEGIN
         LOCALP00 = P00;
         LOCALP01 = P01;
         LOCALP02 = P02;
         #LOOP THRU ACTIVE ENTRY CHAIN# 
         CSTPREVIOUS = 0; 
         CSTCURRENT = CSTUSEDPTR; 
         FOR $DUMMY$ = 0
         WHILE CSTCURRENT NQ 0
         DO   BEGIN 
              #CHECK FOR CORRECT ENTRY TYPE#
              IF CSTVITALINFO[CSTCURRENT] EQ VITALINFO
              THEN GOTO CSTFIND1; 
              #UPDATE LOOP CONTROL INDICES# 
              CSTPREVIOUS = CSTCURRENT; 
              CSTCURRENT = CSTLINK[CSTCURRENT]; 
              END 
CSTFIND1: 
         #NOW CSTCURRENT IS A 0 OR INDICATES A HIT# 
         $BEGIN 
         IF CSTDEBUGSW EQ 1 
         THEN BEGIN 
              W1 = "CST FIND";
              W2 = " P00 =";
              W3 = DEC(P00);
              W4 = "P01 ="; 
              W5 = DEC(P01);
              W6 = "P02 ="; 
              W7 = DEC(P02);
              IF CSTCURRENT EQ 0
              THEN W8 = "NO"; 
              ELSE W8 = "YES";
              CBLIST(SSP,PL,80);
              IF CSTCURRENT NQ 0
              THEN CSTENTRYDMP(CSTCURRENT); 
              END 
         $END 
         CSTFIND = CSTCURRENT;
         RETURN;
         END   #CSTFIND#
PROC CSTSEARCH (DNATINDEX); 
         #THIS ROUTINE, GIVEN THE DNAT INDEX OF AN IDENTIFIER#
         #WHICH MAY BE ALTERED AT OBJECT TIME, DELETES ALL# 
         #SUBSCRIPT CALCULATIONS WHICH DEPEND ON THE SPECIFIED# 
         #IDENTIFIER"S STORAGE AREA.# 
         ITEM DNATINDEX           U;
         BEGIN
         $BEGIN 
         IF CSTDEBUGSW EQ 1 
         THEN BEGIN 
              W1 = "CST SEARCH";
              W2 = "  DNAT =";
              W3 = DEC(DNATINDEX);
              CBLIST(SSP,PL,30);
              END 
         $END 
         #SCAN DOWN THRU ACTIVE SUBSCRIPT CHAIN#
         CSTPREVIOUS = 0; 
         CSTCURRENT = CSTUSEDPTR; 
         FOR $DUMMY$ = 0
         WHILE CSTCURRENT NQ 0
         DO   BEGIN 
              #ONLY CHECK DATA NAMES AND INDEX NAMES# 
              #ON OVERLAP DELETE OFFENDING ENTRY AND DEPENDENTS#
               IF CSTTYPE[CSTCURRENT] EQ CSTDATANAME THEN 
                   BEGIN  #DATA NAME SUBSCRIPT# 
                        IF STOROVERLAP(CSTVARIABLE[CSTCURRENT], 
                        DNATINDEX) EQ 1 
                        THEN
                              BEGIN 
                              CSTDELETE;  # DELETE ENTRY #
                              TEST;  # NEXT ONE (DELETE ADJUSTED PTRS # 
                              END 
                        END 
               ELSE IF CSTTYPE[CSTCURRENT] EQ CSTINDEXNAME THEN 
                   BEGIN   #INDEX NAME# 
                        #ONLY NEED TO CHECK EQUALITY# 
                        #OF DNATS FOR OVERLAP#
                        IF DNATINDEX EQ CSTVARIABLE[CSTCURRENT] 
                        THEN
                              BEGIN 
                              CSTDELETE;  # DELETE ENTRY #
                              TEST;  # NEXT ONE (DELETE ADJUSTED PTRS # 
                              END 
                        END 
              #INCREMENT LOOP CONTROL INDICIES# 
              CSTPREVIOUS = CSTCURRENT; 
              CSTCURRENT = CSTLINK[CSTCURRENT]; 
              END 
         END   #CSTSEARCH#
PROC CSTCONDPRO;
         #THIS PROCEDURE IS INVOKED AT THE INITIATION OF# 
         #CONDITIONALLY EXECUTED SECTIONS OF CODE TO MARK#
         #ALL DELETED CALCULATIONS AT THE CURRENT LEVEL#
         #AS UN-RESTORABLE.#
         BEGIN
         $BEGIN 
         IF CSTDEBUGSW EQ 1 
         THEN BEGIN 
              W1 = "CST CNDPR0";
              W2 = "  DEPTH ="; 
              W3 = DEC(CONDDEPTH);
              CBLIST(SSP,PL,30);
              CSTDUMP;
              END 
         $END 
         #SCAN THRU UNUSED CHAIN# 
         CSTPREVIOUS = 0; 
         CSTCURRENT = CSTUNUSEDPTR; 
         FOR $DUMMY$ = 0
         WHILE CSTCURRENT NQ 0
         DO   BEGIN 
              #HAS THIS CALCULATION BEEN DELETED AT THIS LEVEL# 
              IF CSTDELDEPTH[CSTCURRENT] EQ CONDDEPTH 
              THEN CSTDELDEPTH[CSTCURRENT] = 0; 
              #INCREMENT LOOP CONTROL INDICIES# 
              CSTPREVIOUS = CSTCURRENT; 
              CSTCURRENT = CSTLINK[CSTCURRENT]; 
              END 
         $BEGIN 
         IF CSTDEBUGSW EQ 1 
         THEN BEGIN 
              CSTDUMP;
              END 
         $END 
         END   #CSTCONDPRO# 
PROC CSTCONDEPI;
         #THIS ROUTINE IS INVOKED AT THE TERMINATION OF#
         #CONDITIONALLY EXECUTED SECTIONS OF CODE TO BOTH#
         #DELETE AND RESTORE CONDITIONAL SUBSCRIPT# 
         #CALCULATIONS.#
         ITEM  CURRENTLINK   U; 
         ITEM  CSTSVDLST     U; 
         BEGIN
         $BEGIN 
         IF CSTDEBUGSW EQ 1 
         THEN BEGIN 
              W1 = "CST CNDEPI";
              W2 = "  DEPTH ="; 
              W3 = DEC(CONDDEPTH);
              W4 = "OLDPARSTAT";
              W5 = DEC(OLDPARSTATUS); 
              CBLIST(SSP,PL,50);
              CSTDUMP;
              END 
         $END 
         #LOOP THRU USED CHAIN DELETING ADDED CALCULATIONS# 
         CSTPREVIOUS = 0; 
         CSTCURRENT = CSTUSEDPTR; 
         #SAVE LASTUNUSED POINTER SO THAT DELETED#
         #ENTRIES ADDED TO THE END OF THE UNUSED #
         #CHAIN BY DELENTRY CAN LATER BE MOVED TO#
         #THE FRONT OF THE UNUSED CHAIN.         #
         CSTSVDLST = CSTLSTUNUSED;
         FOR $DUMMY$ = 0
         WHILE CSTCURRENT NQ 0
         DO   BEGIN 
              #WAS THIS CALCULATION MADE AT THIS DEPTH&#
              IF CSTCALCDEPTH[CSTCURRENT] EQ CONDDEPTH
              THEN BEGIN
                   #DELETE SPECIFIED ENTRY# 
                   CSTDELENTRY; 
                   END
              #BUMP LOOP INDICIES#
              CSTPREVIOUS = CSTCURRENT; 
              CSTCURRENT = CSTLINK[CSTCURRENT]; 
              END 
         #MOVE THE JUST-DELETED ENTRIES TO# 
         #THE FRONT OF THE UNUSED CHAIN.  # 
         CSTLINK[CSTLSTUNUSED] = CSTUNUSEDPTR;
         CSTUNUSEDPTR = CSTLINK[CSTSVDLST]; 
         CSTLINK[CSTSVDLST] = 0;
         CSTLSTUNUSED = CSTSVDLST;
         #IF CODE SECTION ENDS IN AN UNCONDITIONAL BRANCH#
         #RESTORE ANY CONDITIONALLY DELETED CALCULATIONS# 
         IF OLDPARSTATUS EQ 6 OR OLDPARSTATUS EQ 7
         OR (OLDPARSTATUS EQ 8 AND CCTSUBPROGR) 
         THEN BEGIN 
              #SCAN THRU UNUSED CHAIN#
              CSTPREVIOUS = 0;
              CSTCURRENT = CSTUNUSEDPTR;
              FOR $DUMMY$ = 0 
              WHILE CSTCURRENT NQ 0 
              DO   BEGIN
                   CURRENTLINK = CSTLINK [CSTCURRENT];
                   #WAS THIS ENTRY DELETED AT THIS DEPTH&#
                   IF CSTDELDEPTH[CSTCURRENT] EQ CONDDEPTH
                   THEN BEGIN 
                        #REMOVE ENTRY FROM UNUSED CHAIN#
                        CSTLINK[CSTPREVIOUS] = CURRENTLINK; 
                        #UPDATE CHAIN POINTER IF NECESSARY# 
                        IF CSTCURRENT EQ CSTUNUSEDPTR 
                        THEN CSTUNUSEDPTR = CURRENTLINK;
                        #ADD ENTRY TO USED CHAIN# 
                        CSTLINK[CSTCURRENT] = CSTUSEDPTR; 
                        CSTUSEDPTR = CSTCURRENT;
                        END 
                   ELSE BEGIN 
                        CSTPREVIOUS = CSTCURRENT; 
                        END 
                   CSTCURRENT = CURRENTLINK;
                   END
              END 
         $BEGIN 
         IF CSTDEBUGSW EQ 1 
         THEN BEGIN 
              CSTDUMP;
              END 
         $END 
         END   #CSTCONDEPI# 
    FUNC LITERALVALUE(PLTPOINTER);
          # THIS FUNCTION CALCULATES THE VALUE OF A LITERAL # 
          # PLTPOINTER POINTS TO THE PLT ENTRY FOR THIS LITERAL # 
          BEGIN 
          ITEM PLTPOINTER        I; 
          ITEM LVALUE            I; 
          LVALUE = 0; 
          FOR REG1=1 STEP 1 UNTIL GET(PL$LENGTH,PLT$,PLTPOINTER)
          DO
            LVALUE = 10 * LVALUE + PLTCHARACTER(PLTPOINTER,REG1)
                           - "0"; 
          LITERALVALUE = LVALUE;
          RETURN; 
          END   #LITERALVALUE#
  
PROC STDEBUGELEM; 
         BEGIN
         SUB$ = 9;
         LDPPSET(7);
         END
         #***** MAIN ENTRY POINT *****# 
         SWITCH SUB    #SUB0#,
         SUB1 , SUB2 , SUB3 , SUB4 , SUB5 , 
         SUB6 , SUB7 , SUB8 , SUB9 , SUB10, 
         SUB11, SUB12, SUB13, SUB14, SUB15, 
         SUB16, SUB17, SUB18, SUB19, SUB20, 
         SUB21, SUB22, SUB23, SUB24, SUB25, 
         SUB26, SUB27, SUB28, SUB29, SUB30, 
         SUB31, SUB32, SUB33, SUB34, SUB35, 
         SUB36, SUB37, SUB38, SUB39, SUB40, 
         SUB41, SUB42, SUB43, SUB44, SUB45, 
         SUB46, SUB47, SUB48, SUB49, SUB50, 
         SUB51, SUB52, SUB53, SUB54, SUB55, 
         SUB56, SUB57, SUB58; 
         GOTO SUB[SUB$];
SUB1: 
#LOCAL INITIALIZATION#
         # LOAD AND EXECUTE LOCAL INITIALIZATION OVERLAY #
         # THIS INCLUDES THE SPBT PROCESSOR              #
         XREF PROC INITMGR; 
         INITMGR; 
         LDPPSET(1);
         RETURN;
SUB9: 
#UPDATE CCT ROUTINE#
         # LOAD AND EXECUTE UPDATE CCT OVERLAY #
         # THIS INCLUDES PNAT ANALYSIS         #
         LDPPSET(2);
         XREF PROC KILLMGR; 
         KILLMGR; 
         RETURN;
SUB17:  
#REAL LIVE LITERAL# 
         LATTEMP = VALUE$;
         #FALL THROUGH# 
SUB15:  
#LITERAL ROUTINE# 
         S = S+1; 
         S$ = S$ + 1; 
         XSTACK(S,GTX(GLITREF,(NEXTLAT),0));
         XCOLUMN(S,COLUMN$);
         XLINE(S,LINE$);
         RETURN;
SUB45:  
#ALL LITERAL ROUTINE# 
         REG1 = GET(PL$6BITTYPE,PLT$,LATTEMP);
         IF REG1 EQ PLTQUOTEDLIT OR REG1 EQ PLTFGCONZERO
         OR REG1 EQ PLTBOOLLIT
         THEN SET(L$ALL,LAT$,LATLENGTH,1);
         ELSE ERROR(SEVERE,59,LINE(S),COLUMN(S)); 
         RETURN;
SUB46:  
#NON ALL LITERAL ROUTINE# 
         IF TCODE(S) EQ GLITREF 
         THEN BEGIN 
              REG1 = LATLENGTH; 
              IF GET(L$ALL,LAT$,REG1) EQ 1
              THEN BEGIN
                   SET(L$ALL,LAT$,REG1,0);
                   ERROR(TRIVIAL,163,LINE$,COLUMN$);
                   END
              END 
         RETURN;
SUB3: 
#ACCEPT GTEXT#
         IF FREEZEFLAG EQ 0 
         THEN BEGIN 
SUB5: 
#DELETE GTEXT#
              FREEZEFLAG = 1; 
              IF OPTIMIZATION EQ 1
              THEN BEGIN
                   CSTPURGE;
                   #RESET CONDITION BLOCK DEPTH TO AVOID PROBLEMS#
                   CONDDEPTH = 1; 
                   END
              IF G EQ FROZENGTEXT THEN GOTO SETPTR; 
              #CHANGE CURRENT VERB DESCRIPTION PACKET TO ABORT# 
              G = FROZENGTEXT;
              FIX1 = GETGT(G+1);
              B<51,9> FIX1 = GABORT;
              NG(FIX1); 
              #KEEP THE LINE AND COLUMN SUBVERB#
              G = G + 1;
              END 
         FROZENGTEXT = G; 
         CCTGTEXTLEN = FROZENGTEXT;   #********** TEMPORARY#
         SETPTR:  
         #RESET TEMP MSEC OFFSET# 
         CURRNTOFFSET = BASEOFFSET; 
         IF OPTIMIZATION EQ 0 
         THEN BEGIN 
              IF SUBSCRIPT$ GR CSTMAXNUM
              THEN CSTMAXNUM = SUBSCRIPT$;
              SUBSCRIPT$ = 0; 
              END 
         S$ = 0;
         S = 0; 
         DS = 0;
         RETURN;
SUB14:  
#MASTER DELETE GTEXT ROUTINE# 
         FREEZEFLAG = 0;
         RETURN;
SUB2: 
#SN TEST# 
         IF CCTSECTION[0] OR F21 EQ 1 
         THEN TRUEFALSE = 0;
         ELSE TRUEFALSE = 1;
         RETURN;
SUB6: 
#PNDEF ROUTINE# 
         IF OPTIMIZATION EQ 1 
         THEN BEGIN 
              #KILL ALL SUBSCRIPTS# 
              #IF PARAGRAPH STATUS = 0 THEY ARE ALREADY DEAD# 
              IF PARSTATUS NQ 0 
              THEN CSTPURGE;
              END 
         PARSTATUS = 1; 
         LASTPNDEF = VALUE$;
         NGGTX(GVERB,VALUE$,GPROC); 
          GOTO SAVELINE;
SUB7: 
#SNDEF ROUTINE# 
         SEGMENT = GET(PN$SEGMENTNO,PNAT$,VALUE$);
         IF SEGMENT GQ CCTSEGLIMIT
         THEN 
             BEGIN
             CCTSEGMENTS[0] = TRUE; 
             IF CCTIDBUG[0] THEN
                 ERROR(ADVISORY,495,LINE$,COLUMN$); 
             CCTIDBUG[0] = FALSE;   # INSURE CID TABLES NOT GENERATED  #
             END
         IF SEGMENT GR 0
         THEN BEGIN 
              IF SEGMENT GR 49 OR SEGMENT LS CCTSEGLIMIT
              THEN BEGIN
                   IF CCTFIPSLEVEL LS 2 
                   THEN BEGIN 
                        #FIPS=2 SUPPORTS FIXED PERMANENT SEGMENTS#
                        #AND INDEPENDENT SEGMENTS # 
                        ERROR(TRIVIAL,823,LINE$,COLUMN$); 
                        END 
                   END
              ELSE BEGIN
                   IF CCTFIPSLEVEL LS 4 
                   THEN BEGIN 
                        #FIPS=4 SUPPORTS FIXED OVERLAYABLE SEGMENTS # 
                        ERROR(TRIVIAL,824,LINE$,COLUMN$); 
                        END 
                   END
              END 
         IF DPROCEND NQ 0 
         THEN BEGIN 
              NGLABELDEF(DPROCEND); 
              DPROCEND = 0; 
              END 
         IF OPTIMIZATION EQ 1 
         THEN BEGIN 
              #KILL ALL SUBSCRIPTS UNLESS FIRST SECTION#
              IF PARSTATUS NQ 0 
              THEN CSTPURGE;
              END 
         PARSTATUS = 0; 
         LASTSDEF = VALUE$; 
         LASTPNDEF = VALUE$;
         SET(PN$PROCKIND,PNAT$,VALUE$,1); 
         IF F21 EQ 1
         THEN BEGIN 
              #WE ARE IN THE DECLARATIVES#
              #SET PERFORM FIRST BIT# 
              #SET PERFORM LAST BIT#
              SET(PN$PERFLAST,PNAT$,VALUE$,1);
              END 
         NGGTX(GVERB,VALUE$,GPROC); 
          #CREATE AN AUX-TABLE ENTRY WITH TYPE AUXGTEXT#
          #CONTAINING A POINTER TO THE BEGINNING OF GTEXT#
          #FOR THAT SECTION.# 
          AUXTLENGTH = AUXTLENGTH + 1;
          SET(AX$TTYPE,AUX$,AUXTLENGTH,AUXGTEXT); 
          SET(AX$GTEXTPTR,AUX$,AUXTLENGTH,G); 
         REG1 = GET(PN$AUXREF,PNAT$,VALUE$);
         SET(PN$AUXREF,PNAT$,VALUE$,AUXTLENGTH);
         SET(AX$TNEXTPTR,AUX$,AUXTLENGTH,REG1); 
  SAVELINE: 
          IF PARAGLINE  LS  VERBLINE
          THEN PREVIOUSLINE = VERBLINE; 
          ELSE PREVIOUSLINE = PARAGLINE;
          PARAGLINE = LINE$;
         RETURN;
SUB53:  
#REF ROUTINE# 
         IF GET(DN$TYPE,DNAT$,VALUE$) EQ ERRTYPE
         THEN BEGIN 
              IF VALUE$ NQ 0
              THEN ERROR(PROPAGATED,180,LINE$,COLUMN$); 
              RETURN; 
              END 
         IF F16 EQ 1
         THEN BEGIN 
              FOR REG1 = GET(DN$AUXREF,DNAT$,VALUE$)
              WHILE REG1 NQ 0 
              DO BEGIN
                 IF GET(AX$TTYPE,AUX$,REG1) EQ KEYNAME
                    AND 
                    GET(AX$KEYNAM,AUX$,REG1) EQ SRTEMP
                 THEN BEGIN 
                      REG1 = 0; 
                      #DIAG 517 - THE OBJECT OF A CONDITION IN A #
                      #SEARCH ALL STATEMENT MUST NOT CONTAIN ANY #
                      #OF THE KEYS NOR THE FIRST INDEX-NAME THAT #
                      #IS ASSOCIATED WITH THE TABLE THAT IS TO BE#
                      #SEARCHED#
                      ERROR(SEVERE,517,LINE$,COLUMN$);
                      END 
                 ELSE REG1 = GET(AX$TNEXTPTR,AUX$,REG1);
                 END #OF THE DO#
              END 
         #TEST FOR REFERENCES TO CONTROL DATA ITEMS#
         #IS THIS A VALID USE BEFORE REPORTING DECLARATIVE# 
         IF F26 EQ 1
            AND UBR$RD$DNAT NQ 0
            AND UBRTYPE NQ 0
         THEN BEGIN 
              FIX1 = GET(DN$AUXREF,DNAT$,UBR$RD$DNAT);
              FIX1 = FINDAUX(AUXCDI,FIX1);
              FOR $DUMMY$ = 0 WHILE FIX1 NQ 0 
              DO  BEGIN 
                  IF STOROVERLAP(GET(AX$CDIDNAT,AUX$,FIX1), 
                                   VALUE$) EQ 1 
                  THEN BEGIN
                       IF UBRTYPE EQ 2
                          AND 
                          VALUE$ EQ GET(AX$CDIDNAT,AUX$,FIX1) 
                       THEN BEGIN 
                            VALUE$ = GET(AX$PVCDIDNAT,AUX$,FIX1); 
                             GOTO SUB12;
                            END 
                       ELSE BEGIN 
                             ERROR(JOD, 292, LINE$, COLUMN$); 
                            GOTO SUB12; 
                            END 
                       END  # OF IF # 
                  FIX1 = FINDAUX(AUXCDI,
                                GET(AX$TNEXTPTR,AUX$,FIX1));
                  END  # OF DO #
              END 
         # FALL THROUGH # 
SUB12:  
#STACK DEBUG ELEMENT# 
         # IF THE PROGRAM IS IN DEBUGGING MODE AND DEBUGGING MUST BE  # 
         # DONE FOR THE ENCOUNTERED DATA-NAME, CALL STDEBUGELEM TO    # 
         # STACK THE DATA-NAME IN THE DEBUG STACK.                    # 
         IF DEBUGFLAG EQ 1 AND GET(DN$DEBUG,DNAT$,VALUE$) EQ 1
         THEN BEGIN 
              PASSDA = VALUE$;
              PASSMODE = 0; 
              STDEBUGELEM;
              END 
         RETURN;
SUB11:  
#DATA NAME ROUTINE# 
         S = S + 1; 
         S$ = S$ + 1; 
         XSTACK(S,GTX(GDATAREF,VALUE$,0));
         XLINE(S,LINE$);
         XCOLUMN(S,COLUMN$);
         TABLENAME = VALUE$;
         TABLELINE = LINE$; 
         TABLECOLUMN = COLUMN$; 
         IF CCTFIPSLEVEL LS 3 
         THEN BEGIN 
              IF GET(DN$LEVEL,DNAT$,VALUE$) EQ 66 
              THEN BEGIN
                   # FIPS=3 SUPPORTS REFERENCES TO LEVEL 66 ITEMS # 
                   ERROR(TRIVIAL,812,LINE$,COLUMN$);
                   END
              END 
         RETURN;
SUB13:  
# NO SUBSCRIPTS ROUTINE # 
         REFCOUNTINDX = 0;
         INITSNUMBER = 0; 
         SUBSREQUIRED = GET(DN$SDEPTH,DNAT$,TABLENAME); 
         IF SUBSREQUIRED NQ 0 
         THEN BEGIN 
              SUBSCRIPTBUG; 
              END 
         RETURN;
SUB30:  
#SUBSCRIPT PROLOGUE#
         REFCOUNTINDX = 0;
         INITSNUMBER = 0; 
         SUBSREQUIRED = GET(DN$SDEPTH,DNAT$,TABLENAME); 
         IF SUBSREQUIRED EQ 0 
         THEN BEGIN 
              TRUEFALSE = 0;
              RETURN; 
              END 
         ELSE BEGIN 
              TRUEFALSE = 1;
              END 
         MNUMBER = MNUMBER + 1; 
         MODIFIER [MD] = MNUMBER; 
         IF MNUMBER GR CCTMAXMNUM 
         THEN BEGIN 
              CCTMAXMNUM = MNUMBER; 
              END 
         XTSUBCODE(S,MODIFIER[MD]); 
         #ENSURE THERE IS ENOUGH ROOM IN THE CST# 
         IF OPTIMIZATION EQ 1 
         THEN CSTELBOWRM; 
         SUBSSOFAR = 0; 
         SUBSCRIPTFLG = 0;
         INDEXFLAG = 0; 
         PREVCALCSS$ = 0; 
         JUSTCALCSS$ = 0; 
         #INITIALIZE REFERENCE COUNT TABLE INDEX FOR SUBSCRIPT# 
         RETURN;
SUB35:  
#DATA NAME SUBSCRIPT ROUTINE# 
         SUBSSOFAR = SUBSSOFAR + 1; 
         SSTYPE = CSTDATANAME;
         RELINDEXFLAG = 0;
         SUBSCRIPTFLG = 1;
         #CHECK VALIDITY OF SUBSCRIPTING OPERATION# 
         #NO FURTHER DIAGNOSTICS IF ERRONEOUS#
         REG1 = GET(DN$TYPE,DNAT$,VALUE$);
         IF REG1 NQ ERRTYPE 
         THEN BEGIN 
              #A SUBSCRIPT MUST BE A NUMERIC INTEGER# 
               IF (REG1 NQ NUMERIC AND
                  REG1 NQ COMP4 AND 
                  REG1 NQ BINARY) OR
                  GET(DN$POINT,DNAT$,VALUE$) GR 0 
              THEN ERROR(SEVERE,92,LINE$,COLUMN$);
              #A SUBSCRIPT MAY NOT BE SUBSCRIPTED#
              ELSE IF GET(DN$SDEPTH,DNAT$,VALUE$) NQ 0
                   THEN ERROR(SEVERE,55,LINE$,COLUMN$); 
              END 
         IF SUBSSOFAR GR SUBSREQUIRED 
         THEN RETURN; 
         GOTO SCRGTEXT; 
SUB33:  
#LITERAL SUBSCRIPT ROUTINE# 
         SUBSSOFAR = SUBSSOFAR + 1; 
         IF SUBSSOFAR GR SUBSREQUIRED THEN RETURN;
         RELINDEXFLAG = 0;
         GOTO LITRELINDX; 
SUB34:  
#TEST FOR INDEX NAME# 
         IF GET(DN$TYPE,DNAT$,VALUE$) EQ INDXNAME 
         THEN TRUEFALSE = 1;
         ELSE TRUEFALSE = 0;
         RETURN;
SUB36:  
#INDEX NAME ROUTINE#
         SUBSSOFAR = SUBSSOFAR + 1; 
         IF SUBSSOFAR GR SUBSREQUIRED THEN RETURN;
         INDEXFLAG = 1; 
         SSTYPE = CSTINDEXNAME; 
         RELINDEXFLAG = 0;
         #CHECK FOR INDEXING ERRORS UNLESS TABLE ERRONEOUS# 
         IF GET(DN$TYPE,DNAT$,TABLENAME) NQ ERRTYPE 
         THEN BEGIN 
              #IS A CERTAIN INDEX USED IN A SEARCH ALL OBJECT#
              IF F16 EQ 1 AND VALUE$ EQ SRTEMP + 1
              THEN ERROR(SEVERE,517,LINE$,COLUMN$); 
              #CAN THIS INDEX NAME BE USED WITH THIS DATA NAME# 
              IF GET(DN$FIRIDX,DNAT$,VALUE$) GR TABLENAME OR
                 GET(DN$LASIDX,DNAT$,VALUE$) LS TABLENAME 
              THEN ERROR(SEVERE,52,LINE$,COLUMN$);
              ELSE BEGIN
                   #IS THIS INDEX NAME IN CORRECT POSITION# 
                   REG1 = GET(DN$IDXDEP,DNAT$,VALUE$);
                   IF REG1 NQ SUBSSOFAR 
                   THEN BEGIN 
                        IF REG1 LQ 3
                        THEN BEGIN
                             # COMPUTE MESSAGE NUMBER # 
                             FIX1 = 103 + REG1; 
                             ERROR(SEVERE,FIX1,LINE$,COLUMN$);
                             END
                        ELSE BEGIN
                             # THIS INDEX-NAME CANNOT APPEAR IN THIS #
                             # POSITION # 
                             ERROR(SEVERE,472,LINE$,COLUMN$); 
                             END
                        END 
                   END
              END 
         GOTO SCRGTEXT; 
SUB37:  
#MINUS RELATIVE INDEX#
         RELINDEXFLAG = 1;
         GOTO LITRELINDX; 
SUB38:  
#PLUS RELATIVE INDEX# 
         RELINDEXFLAG = 2;
         #FALL THROUGH# 
LITRELINDX: 
         SSTYPE = CSTLITERAL; 
         #CACULATE VALUE OF THE INTEGER LITERAL#
          LITVALUE = LITERALVALUE(VALUE$);
         #GENERATE LAT ENTRY FOR THIS LITERAL#
         LATTEMP = VALUE$;
          $DUMMY$ = NEXTLAT;
         #CHECK VALIDITY OF LITERAL DEPENDING ON RELINDEXFLAG#
         IF RELINDEXFLAG EQ 0 
         THEN BEGIN 
              #LITERAL SUBSCRIPT - CHECK FOR NEGATIVE OR ZERO#
              IF GET(PL$SIGNFLAG,PLT$,VALUE$) EQ 0 OR 
                 LITVALUE EQ 0
              THEN ERROR(SEVERE,51,LINE$,COLUMN$);
              IF LITVALUE GR MAXVALUE(SUBSSOFAR)
              THEN BEGIN
                   # A CONSTANT SUBSCRIPT CANNOT EXCEED # 
                   # THE MAXIMUM NUMBER OF OCCURRENCES #
                   # SPECIFIED IN THE OCCURS CLAUSE # 
                   ERROR(SEVERE,47,LINE$,COLUMN$);
                   END
              END 
         ELSE BEGIN 
              #RELATIVE INDEX INCREMENT - CHECK FOR SIGN# 
              IF GET(PL$SIGNEDFLG,PLT$,VALUE$) EQ 1 
              THEN ERROR(SEVERE,24,LINE$,COLUMN$);
              #FIX UP LITERAL SIGN IF MINUS INCREMENT#
              IF RELINDEXFLAG EQ 1
              THEN BEGIN
                   SET(PL$SIGNEDFLG,PLT$,VALUE$,1); 
                   SET(PL$SIGNFLAG,PLT$,VALUE$,0);
                   LITVALUE = - LITVALUE; 
                   END
              END 
         IF SUBSSOFAR GR SUBSREQUIRED THEN RETURN;
         #FIX UP CGL DNAT ENTRY#
         REG2 = DNATLENGTH; 
         SET(DN$TYPE,DNAT$,REG2,INDXNAME);
         FIX1 = GET(DN$AUXREF,DNAT$,TABLENAME); 
         SET(DN$AUXREF,DNAT$,REG2,FIX1);
         SET(DN$IDXDEP,DNAT$,REG2,SUBSSOFAR); 
         #FALL THROUGH# 
SCRGTEXT: 
  
         # IF THE PROGRAM IS IN DEBUGGING MODE AND DEBUGGING MUST BE  # 
         # DONE FOR THE SUBSCRIPTED DATA-NAME ENCOUNTERED, CALL       # 
         # STDEBUGELEM TO STORE THE SUBSCRIPT AND ALL REQUIRED INFO.  # 
         IF DEBUGFLAG EQ 1 AND
             GET(DN$DEBUG,DNAT$,TABLENAME) EQ 1 
         THEN BEGIN 
              PASSDA = VALUE$;
              PASSMODE = 2; 
              STDEBUGELEM;
              END 
  
         #INITIALIZE SWITCH FOR SUBSCRIPT GTEXT GENERATION# 
         SSSWITCH = 1;
         #IS OPTIMIZATION IN EFFECT#
         IF OPTIMIZATION EQ 1 
         THEN BEGIN 
              P00 = SSTYPE; 
              #ACCESS SUBSCRIPT VARIABLE# 
              IF P00 NQ CSTLITERAL
              THEN P01 = VALUE$;
              ELSE P01 = LITVALUE;
              #ACCESS OCCURRENCE LENGTH#
              IF P00 NQ CSTINDEXNAME
              THEN BEGIN
                   REG1 = GET(DN$AUXREF,DNAT$,TABLENAME); 
                   REG2 = SUBSSOFAR;
                   SG1: 
                   IF REG1 EQ 0 THEN GOTO SG2;
                   IF GET(AX$TTYPE,AUX$,REG1) NQ MAXOCCUR OR
                      GET(AX$SUBSLVL,AUX$,REG1) NQ REG2 
                   THEN BEGIN 
                        REG1 = GET(AX$TNEXTPTR,AUX$,REG1);
                        GOTO SG1; 
                        END 
                   SG2: 
                   P02 = GET(AX$OCCLEN,AUX$,REG1);
                   END
              ELSE P02 = 0; 
              #IS THIS CALCULATION ACTIVE#
              IF CSTFIND(P00,P01,P02) NQ 0
              THEN BEGIN
                   #PREVIOUS RESULT AVAILABLE#
                   SSSWITCH = 0;
                   CSTHIT;
                   END
              ELSE CSTADD(P00,P01,P02); 
              SUBSCRIPT$ = CSTCURRENT;
              END 
         ELSE SUBSCRIPT$ = SUBSCRIPT$ + 1;
         #DO WE NEED SUBSCRIPT CALCULATION GTEXT# 
         IF SSSWITCH EQ 1 
         THEN BEGIN 
              #SET UP REFERENCE COUNT TABLE ENTRIES#
              RFTLENGTH = RFTLENGTH + 2;
              SET(RCT$ENTRY,RCT$,RFTLENGTH,0);
              SET(RCT$ENTRY,RCT$,RFTLENGTH+1,0);
              #PUT GTEXT INTO STACK BASED ON TYPE#
              SWITCH SGSWITCH ,X1,X2,X3;
              GOTO SGSWITCH[SSTYPE];
              X1: #DATA NAME SUBSCRIPT# 
                  BEGIN 
                  S = S + 1;
                  XSTACK(S,GTX(GVERB,SUBSCRIPT$,GSUBSCAL)); 
                  S = S + 1;
                  XSTACK(S,GTX(GDATAREF,TABLENAME,0));
                  S = S + 1;
                  XSTACK(S,GTX(GDATAREF,VALUE$,0)); 
                  S = S + 1;
                  XSTACK(S,GTX(GSUBVERB,RFTLENGTH,SUBSSOFAR));
                  GOTO X4;
                  END 
              X2: #LITERAL SUBSCRIPT OR RELATIVE INDEX# 
                  BEGIN 
                   S = S + 1; 
                   XSTACK(S,GTX(GVERB,SUBSCRIPT$,GSUBLIT)); 
                   S = S + 1; 
                   XSTACK(S,GTX(GLITREF,LATLENGTH,0));
                   S = S + 1; 
                   XSTACK(S,GTX(GSUBVERB,AUXVALUE(SUBSSOFAR),0)); 
                  GOTO X4;
                  END 
              X3: #INDEX NAME#
                  BEGIN 
                  S = S + 1;
                  XSTACK(S,GTX(GVERB,SUBSCRIPT$,GSUBSFET)); 
                  S = S + 1;
                  XSTACK(S,GTX(GDATAREF,VALUE$,0)); 
                  NEWINDEX [SUBSSOFAR] = SUBSCRIPT$;
                  END 
              X4: 
              #SAVE INFORMATION FOR USE IN SUBSCRIPT EPILOGUE#
              IF RELINDEXFLAG NQ 0 THEN GOTO FORCEINDXSUM;
              LASTCALC = 0; 
              JUSTCALCSS$ = JUSTCALCSS$ + 1;
              JUSTCALCSS[JUSTCALCSS$] = SUBSCRIPT$; 
              JUSTCALCREFC[JUSTCALCSS$] = RFTLENGTH;
              IF CCTSUBSCHECK AND SSTYPE EQ CSTDATANAME 
              THEN BEGIN
                   # IF RANGE CHECK IS REPEATED FOR A # 
                   # DATA NAME SUBCRIPT, THE RCT MUST REFLECT # 
                   # THIS REFERENCE EVEN THOUGH THE CALCULATION # 
                   # HAS BEEN OPTIMIZED # 
                   FIX2 = CSTREFCTPTR [SUBSCRIPT$]; 
                   FIX1 = GET(RCT$ENTRY,RCT$,FIX2) + 1; 
                   SET(RCT$ENTRY,RCT$,FIX2,FIX1); 
                   END
              END 
         ELSE BEGIN 
              IF RELINDEXFLAG NQ 0 THEN GOTO FORCEINDXSUM;
              LASTCALC = 1; 
              #SAVE INFO FOR USE IN SUBSCRIPT EPILOGUE# 
              PREVCALCSS$ = PREVCALCSS$ + 1;
              PREVCALCSS[PREVCALCSS$] = SUBSCRIPT$; 
              END 
         IF CCTSUBSCHECK AND SSTYPE EQ CSTDATANAME
         THEN BEGIN 
              # RANGE CHECKING GTEXT FOR OLD/NEW DATA-NAME SUBSCRIPTS # 
              RANGECHECK(SUBSSOFAR,SUBSCRIPT$); 
              END 
         RETURN;
FORCEINDXSUM: 
         NEWINDEX [SUBSSOFAR] = 0;
         P00 = CSTREL;
         P02 = SUBSCRIPT$;
         IF LASTCALC EQ 0 
         THEN BEGIN 
              # INDEX-NAME IS IN JUSTCALCSS # 
              # NO CHANCE FOR OPTIMIZATION #
              P01 = JUSTCALCSS [JUSTCALCSS$]; 
              END 
         ELSE BEGIN 
              # INDEX-NAME IS IN PREVCALCSS # 
              # POSSIBILITY FOR OPTIMIZATION #
              P01 = PREVCALCSS [PREVCALCSS$]; 
              JUSTCALCSS$ = JUSTCALCSS$ + 1;
              PREVCALCSS$ = PREVCALCSS$ - 1;
              END 
         IF OPTIMIZATION EQ 1 
         THEN BEGIN 
              IF P01 GR P02 
              THEN  CSTADD(P00,P02,P01);
              ELSE CSTADD(P00,P01,P02); 
              SUBSCRIPT$ = CSTCURRENT;
              END 
         ELSE BEGIN 
              SUBSCRIPT$ = SUBSCRIPT$ + 1;
              END 
         FIX2 = CSTREFCTPTR[P01] + 1; 
         FIX1 = GET(RCT$ENTRY,RCT$,FIX2) + 1; 
         SET(RCT$ENTRY,RCT$,FIX2,FIX1); 
         FIX2 = CSTREFCTPTR[P02] + 1; 
         FIX1 = GET(RCT$ENTRY,RCT$,FIX2) + 1; 
         SET(RCT$ENTRY,RCT$,FIX2,FIX1); 
         # ESTABLISH NEW RCT ENTRY FOR THE SUM #
         RFTLENGTH = RFTLENGTH + 2; 
         # CREATE GTEXT FOR THE SUM # 
         S = S+1; 
         XSTACK(S,GTX(GVERB,RFTLENGTH,GRELSUB));
         S = S+1; 
         XSTACK(S,GTX(GSUBATOM,P01,SUBSCRIPT$));
         S = S+1; 
         XSTACK(S,GTX(GSUBATOM,P02,0)); 
         IF CCTSUBSCHECK THEN 
         # RANGE CHECK THE RELATIVE INDEX # 
         RANGECHECK(SUBSSOFAR,SUBSCRIPT$);
         JUSTCALCSS[JUSTCALCSS$] = SUBSCRIPT$;
         JUSTCALCREFC[JUSTCALCSS$] = RFTLENGTH; 
         RETURN;
SUB32:  
#SUBSCRIPT EPILOGUE#
         IF CCTSUBSCHECK
         THEN BEGIN 
              FOR I = 1 
              STEP 1
              UNTIL SUBSSOFAR 
              DO BEGIN
                 IF NEWINDEX [I] NQ 0 
                 THEN BEGIN 
                      RANGECHECK(I,NEWINDEX[I]);
                      NEWINDEX[I] = 0;
                      END 
                 END
              END 
         #CHECK FOR CORRECT NUMBER OF SUBSCRIPTS# 
         IF SUBSSOFAR NQ SUBSREQUIRED 
         THEN BEGIN 
              SUBSCRIPTBUG; 
              END 
         #QUIT IF NO SUBSCRIPTS ARE NEEDED# 
         IF SUBSREQUIRED EQ 0 THEN RETURN;
         #CHECK FOR MIXING OF SUBSCRIPTS AND INDEX NAMES# 
         IF SUBSCRIPTFLG EQ 1 AND INDEXFLAG EQ 1
         THEN ERROR(TRIVIAL,53,TABLELINE,TABLECOLUMN);
         #GENERATE GTEXT FOR COMBINATIONS OF SUBSCRIPTS#
         #IS OPTIMIZATION IN EFFECT#
         IF OPTIMIZATION EQ 1 
         THEN BEGIN 
              #OPTIMIZATION IN EFFECT#
              #PASS OVER PREVIOUS RESULTS LOOKING FOR COMBOS# 
              P00 = CSTCOMBO; 
              FOR REG1 = 1
              STEP 1
              UNTIL PREVCALCSS$ 
              DO BEGIN
                 FOR REG2 = REG1 + 1
                 STEP 1 
                 UNTIL PREVCALCSS$
                 DO BEGIN 
                    P01 = PREVCALCSS[REG1]; 
                    P02 = PREVCALCSS[REG2]; 
                    #ORDER MNEMONIC NUMBERS TO SIMPLIFY SEARCH# 
                    IF P01 GR P02 
                    THEN P01 == P02;
                    #SEARCH FOR PREVIOUSLY CALCULATED COMBO#
                    IF CSTFIND(P00,P01,P02) NQ 0
                    THEN BEGIN
                         #RECURRING CALCULATION#
                         CSTHIT;
                         #MOVE COMBO TO PREVIOUS RESULTS# 
                         PREVCALCSS[REG2] = CSTCURRENT; 
                         #EXIT FROM LOOP FOR THIS CALCULATION#
                         GOTO COMBOFOUND; 
                         END
                    END #OF THE INNER DO# 
                 #NO COMBINATIONS INVOLVING (REG1)# 
                 JUSTCALCSS$ = JUSTCALCSS$ + 1; 
                 REG3 = PREVCALCSS[REG1]; 
                 JUSTCALCSS[JUSTCALCSS$] = REG3;
                 JUSTCALCREFC[JUSTCALCSS$] = CSTREFCTPTR[REG3]; 
                 COMBOFOUND:  
                 END #OF THE OUTER DO#
              END #OF THE IF STATEMENT# 
         #MAKE PASS TO COMBINE JUST CALCULATED SUBSCRIPTS#
         #INITIALIZE PREVIOUS RESULT AS FIRST SUBSCRIPT#
         PREVMNUM = JUSTCALCSS[1];
         PREVREFINDEX = JUSTCALCREFC[1];
         #LOOP THROUGH JUST CALCULATED SUBSCRIPTS#
         FOR REG1 = 2 
         STEP 1 
         UNTIL JUSTCALCSS$
         DO BEGIN 
            #ACCESS CURRENT SUBSCRIPT#
            MNUM = JUSTCALCSS[REG1];
            REFINDEX = JUSTCALCREFC[REG1];
            #GENERATE COMBO OF CURRENT AND PREVIOUS#
            #CHECK FOR OPTIMIZING TO FIND WHICH MNUM TO USE#
            IF OPTIMIZATION EQ 0
            THEN SUBSCRIPT$ = SUBSCRIPT$ + 1; 
            ELSE BEGIN
                 P00 = CSTCOMBO;
                 P01 = MNUM;
                 P02 = PREVMNUM;
                 #ORDER MNEMONICS TO SIMPLIFY FUTURE SEARCHES#
                 IF P01 GR P02
                 THEN P01 == P02; 
                CSTADD(P00,P01,P02);
                SUBSCRIPT$ = CSTCURRENT;
                END 
            #UPDATE COMBINATION REFERENCE COUNTS FOR CONSTITUENTS#
         FIX2 = REFINDEX+1; 
         FIX1 = GET(RCT$ENTRY,RCT$,FIX2) + 1; 
         SET(RCT$ENTRY,RCT$,FIX2,FIX1); 
         FIX2 = PREVREFINDEX+1; 
         FIX1 = GET(RCT$ENTRY,RCT$,FIX2)+1; 
         SET(RCT$ENTRY,RCT$,FIX2,FIX1); 
            #SET UP NEW REFERENCE COUNT TABLE ENTRIES#
            RFTLENGTH = RFTLENGTH + 2;
            SET(RCT$ENTRY,RCT$,RFTLENGTH,0);
            SET(RCT$ENTRY,RCT$,RFTLENGTH+1,0);
            #GENERATE GTEXT INTO STACK# 
            S = S + 1;
            XSTACK(S,GTX(GVERB,RFTLENGTH,GSUBSUM)); 
            S = S + 1;
            XSTACK(S,GTX(GSUBATOM,MNUM,SUBSCRIPT$));
            S = S + 1;
            XSTACK(S,GTX(GSUBATOM,PREVMNUM,0)); 
            #SAVE CURRENT RESULT AND REF TABLE POINTER# 
            PREVMNUM = SUBSCRIPT$;
            PREVREFINDEX = RFTLENGTH; 
            END #OF THE DO# 
         #UPDATE IDENTIFIER REFERENCE WITH APPROPRIATE MNEMONIC#
         #UPDATE DNREF REFERENCE COUNT FOR THIS CALCULATION#
         FIX1 = GET(RCT$ENTRY,RCT$,PREVREFINDEX) + 1; 
         SET(RCT$ENTRY,RCT$,PREVREFINDEX,FIX1); 
         #SAVE REFERENCE COUNT INDEX FOR LATER USE# 
         COUNTINDEX [MD] = PREVREFINDEX;
         S = S + 1; 
         XSTACK(S,GTX(GVERB,MODIFIER[MD],GSUBSREF));
         S = S + 1; 
         XSTACK(S,GTX(GSUBVERB,PREVMNUM,0));
         SNUMBER [MD] = PREVMNUM; 
         #WRITE CONSTRUCTED GTEXT FROM STACK IF ANY GENERATED#
          # IF THE PROGRAM IS IN DEBUGGING MODE AND DEBUGGING MUST BE  #
          # DONE FOR THE PREVIOUSLY PARSED SUBSCRIPTED DATA-NAME, CALL #
          # STDEBUGELEM TO STACK THE DATA-NAME AND ITS SUBSCRIPTS IN   #
          # THE DEBUG STACK.                                           #
          IF DEBUGFLAG EQ 1  AND
             GET(DN$DEBUG,DNAT$,TABLENAME) EQ 1 
         THEN BEGIN 
              PASSDA = 0; 
              PASSMODE = 3; 
              STDEBUGELEM;
              END 
         $BEGIN 
         IF CSTDEBUGSW EQ 1 
         THEN BEGIN 
              W1 = "SUBSCRIPT"; 
              W2 = "EPILOGUE";
              CBLIST(SSP,PL,20);
              CSTDUMP;
              END 
         $END 
         RETURN;
SUB57:  
#SUBSCRIPT OPT PAUSE# 
         #DE-ACTIVATE SUBSCRIPT OPTIMIZATION TEMPORARILY# 
         OPTIMIZATION = 0;
         CSTPURGE;
         SUBSCRIPT$ = 0;
         RETURN;
SUB58:  
#SUBSCRIPT OPT RESUME#
         #RE-ACTIVATE SUBSCRIPT OPTIMIZATION IF POSSIBLE# 
         IF CCTSUBSOPTIM[0] 
         THEN OPTIMIZATION = 1; 
         RETURN;
SUB31:  
#SUBSCRIPT LIQUIDATE ROUTINE# 
         #KILL ALL CURRENTLY ACTIVE SUBSCRIPTS# 
         CSTPURGE;
         RETURN;
SUB52:  
#SUBSCRIPT FILE NAME ROUTINE# 
         #ON ENTRY TO THIS ROUTINE THE FILE AND RECORD PROCESSING#
         #ROUTINES HAVE SET UP STACK[3] WITH AN ERROR INDICATOR#
         #FOR THE SPECIFIED FILE. A NONZERO VALUE INDICATES NO ERROR# 
         #DECLARATIVE OR AN EARLIER ERROR AND ALL CURRENTLY ACTIVE# 
         #SUBSCRIPTS MUST BE KILLED.# 
         IF STACK(3) NQ 0 
         THEN CSTPURGE; 
         RETURN;
SUB50:  
#SUBSCRIPT CONDITIONAL PROLOGUE#
         #INCREMENT DEPTH OF CALCULATION INDICATOR# 
         CONDDEPTH = CONDDEPTH + 1; 
         #PREPARE FOR CONDITIONAL CODE SECTION# 
         CSTCONDPRO;
         RETURN;
SUB8: 
#SUBSCRIPT CONDITIONAL EPILOGUE#
         #CLEAN UP SUBSCRIPTS AT END OF CONDITIONAL CODE SECTIONS#
         CSTCONDEPI;
         #FALL THROUGH# 
SUB51:  
#SUBSCRIPT CONDITIONAL ERROR# 
         #DECREMENT CONDITIONAL DEPTH INDICATOR#
         CONDDEPTH = CONDDEPTH - 1; 
         RETURN;
SUB47:  
#IDENT RECEIVING FIELD# 
         #THIS ROUTINE IS INVOKED FOR RECEIVING FIELDS# 
         #IDENTIFIED USING IDENTIFIER AND IDENTIFIER 2# 
         #SET UP PARAMETERS FOR IN LINE SUBROUTINE# 
         REG1 = TABLENAME;
         REG2 = LINECTRFLAG;
         REG3 = LINAGEFLAG; 
         LINECTRFLAG = 0; 
         LINAGEFLAG = 0;
         FIX1 = TABLELINE;
         FIX2 = TABLECOLUMN;
         GOTO RFTICS; 
SUB54:  
#REF RECEIVING FIELD# 
         #THIS ROUTINE IS INVOKED FOR RECEIVING FIELDS# 
         #IDENTIFIED USING THE DN REF COMMAND#
         #SET UP PARAMETERS AS ABOVE# 
         REG1 = VALUE$; 
         REG2 = 0;
         REG3 = 0;
         FIX1 = LINE$;
         FIX2 = COLUMN$;
         GOTO RFTICS; 
SUB48:  
#IDENT POSSIBLE RECEIVING FIELD#
         #THIS ROUTINE IS INVOKED FOR POTENTIAL RECEIVING#
         #FIELDS IDENTIFIED USING IDENTIFIER AND IDENTIFIER 2#
         #SAVE POSSIBLE RECEIVING FIELD PARAMETERS# 
         RECFIELD = TABLENAME;
         RFLINE = TABLELINE;
         RFCOLUMN = TABLECOLUMN;
         RFLINEFLAG = LINECTRFLAG;
         RFLINAGEFLAG = LINAGEFLAG; 
         LINECTRFLAG = 0; 
         LINAGEFLAG = 0;
         RETURN;
SUB55:  
#REF POSSIBLE RECEIVING FIELD#
         #THIS ROUTINE IS INVOKED FOR POTENTIAL RECEIVING#
         #FIELDS IDENTIFIED USING THE DN REF COMMAND# 
         #SAVE POSSIBLE PARAMETERS AS ABOVE#
         RECFIELD = VALUE$; 
         RFLINE = LINE$;
         RFCOLUMN = COLUMN$;
         RFLINEFLAG = 0;
         RFLINAGEFLAG = 0;
         RETURN;
SUB49:  
#POSTPONED RECEIVING FIELD# 
         #RESTORE SAVED PARAMETER VALUES# 
          REG1 = RECFIELD;
         REG2 = RFLINEFLAG; 
         REG3 = RFLINAGEFLAG; 
         FIX1 = RFLINE; 
         FIX2 = RFCOLUMN; 
         #FALL THROUGH# 
RFTICS: 
         #THIS SECTION OF CODE IS ENTERED WITH# 
         #REG1 - DNAT INDEX OF RECIVING FIELD#
         #REG2 - FLAG FOR USE OF LINE-COUNTER#
         #REG3 - FLAG FOR USE OF LINAGE-COUNTER#
         #FIX1 - APPROPRIATE LINE NUMBER# 
         #FIX2 - APPROPRIATE COLUMN NUMBER# 
         #DELETION OF DEPENDENT SUBSCRIPT CALCULATIONS# 
         IF OPTIMIZATION EQ 1 
         THEN CSTSEARCH(REG1);
         #CHECK FOR MODIFICATION OF LINE COUNTER# 
         IF REG2 EQ 1 
         THEN BEGIN 
              #SAVE ERROR MESSAGE NUMBER# 
              FIX3 = 289; 
              GOTO RFERROR; 
              END 
         #CHECK FOR MODIFICATION OF LINAGE COUNTER# 
         IF REG3 EQ 1 
         THEN BEGIN 
              #SAVE ERROR MESSAGE NUMBER# 
              FIX3 = 290; 
              GOTO RFERROR; 
              END 
         #CHECK FOR MODIFICATION OF A CONTROL DATA ITEM#
         #IN A VALID USE BEFORE REPORTING DECLARATIVE#
         IF F26 EQ 1 AND UBR$RD$DNAT NQ 0 
         THEN BEGIN 
              #CHECK THAT THE ITEM DOES NOT OVERLAP A CONTROL # 
              #DATA ITEM FOR THE REPORT.                      # 
              REG4 = GET(DN$AUXREF,DNAT$,UBR$RD$DNAT);
              REG4 = FINDAUX(AUXCDI,REG4);
              FOR $DUMMY$ = 0 WHILE REG4 NQ 0 
              DO   BEGIN
                   IF STOROVERLAP(GET(AX$CDIDNAT,AUX$,REG4),
                                    REG1) EQ 1
                   THEN BEGIN 
                        FIX3 = 291; 
                        GOTO RFERROR; 
                        END 
                   REG4 = FINDAUX ( AUXCDI, 
                                    GET(AX$TNEXTPTR,AUX$,REG4));
                  END  # OF DO #
              END 
          # IF THE PROGRAM IS IN DEBUGGING MODE, CALL STDEBUGELEM # 
          # TO STACK THE ENCOUNTERED DATA-NAME IN THE DEBUG-STACK # 
          # IF DEBUGGING MUST BE DONE FOR IT, OR TO SET THE SUBSCR.#
          # RECEIVING FIELD FLAG ON IF THE DATA-NAME IS A SUBSCRIPT#
          # STACKED IN THE DEBUG-STACK.                            #
         IF DEBUGFLAG EQ 1
         THEN BEGIN 
              PASSDA = REG1;
              PASSMODE = 1; 
              STDEBUGELEM;
              END 
         RETURN;
RFERROR:  
         #GENERATE ERROR MESSAGE USING PREVIOUS INFORMATION#
         ERROR(SEVERE,FIX3,FIX1,FIX2);
         RETURN;
SUB10:  
#LINE AND COLUMN# 
          PREVIOUSLINE = VERBLINE;
         VERBLINE = LINE$;
         VERBCOLUMN = COLUMN$;
         RETURN;
SUB40:  
#STACK RESET# 
         S$ = 0;
         S = 0; 
         DS = 0;
         RETURN;
SUB41:  
#IMPERATIVE STATEMENT PROLOGUE# 
         PERIODFLAG = 0;
         DS = 0;
         IF IMPSTATFLG EQ 1 
         THEN ERROR(TRIVIAL,88,VERBLINE,VERBCOLUMN);
         IMPSTATFLG = 1;
         RETURN;
SUB42:  
#IMPERATIVE STATEMENT EPILOGUE# 
         IMPSTATFLG = 0;
         #SAVE PARAGRAPH STATUS FOR SUBSCRIPT OPTIMIZER#
         OLDPARSTATUS = PARSTATUS;
         PARSTATUS = 3; 
         RETURN;
SUB16:  
#USE BEFORE REPORTING#
         UBR$RD$DNAT = 0; 
         UBRTYPE = 0; 
         #UBRAUXPTR USED BY SUPPRESS# 
         UBRAUXPTR = 0; 
         REG1 = TABLENAME;
         #RETURN IF UNDEFINED, AMBIGUOUS OR ERRONEOUS#
         IF GET(DN$TYPE,DNAT$,REG1) EQ ERRTYPE
         THEN RETURN; 
         #IS DNAT DEFINED IN THE REPORT SECTION # 
         #IS DNAT A LEVEL 01 REPORT GROUP NAME #
         IF CCTRSDNATPTR EQ 0     # NO REPORT SECTION # 
            OR
            REG1 LS CCTRSDNATPTR  # ITEM IS NOT IN REPORT SECTION#
            OR
            GET(DN$LEVEL,DNAT$,REG1) NQ 1  #NOT A REPORT GROUP# 
         THEN BEGIN 
              #THIS REFERENCE MUST BE A REPORT GROUP NAME#
              ERROR(SEVERE,806,TABLELINE,TABLECOLUMN);
              RETURN; 
              END 
         #SET UBR$RD$DNAT TO THE DNAT OF THE RD SO REF ROUTINE #
         #AND RFTICS CAN CHECK FOR REFERENCES TO CONTROL DATA  #
         #ITEMS IN THE UBR.  IF THERE ARE NO CONTROLS, SET     #
         #UBR$RD$DNAT TO 0 SO NO CHECKING WILL BE DONE.        #
         UBR$RD$DNAT = GET(DN$RDDNAT,DNAT$,VALUE$); 
  
         #DN$RDDANT IS 0 IF NO CONTROLS. #
  
         #SET UBRTYPE FOR REF ROUTINE:  # 
         #   0- CDI OR ANY ITEM OVERLAPPING CDI MAY BE REFERENCED.# 
         #   1- NEITHER CDIS NOR OVERLAPPING ITEMS MAY BE REFERENCED# 
         #   2- CDI MAY BE REFERENCED BUT OVERLAPS MAY NOT.         # 
         #      USE PREVIOUS VALUE BUCKET FOR CDI REFERENCES.       # 
         #   2- NEITHER CDIS NOR OVERLAPPING ITEMS MAY BE REFERENCED# 
  
         UBRTYPE = GET(DN$RGCDI,DNAT$,VALUE$);
         #IT IS NOT LEGAL TO REFERENCE THE SAME REPORT GROUP# 
         #IN MORE THAN ONE USE BEFORE REPORTING STATEMENT#
         #THIS WE DETERMINE BY RECOGNIZING THAT A UBR SECTION#
         #AUX TABLE ENTRY HAS ALREADY BEEN ATTACHED TO THE# 
         #REPORT GROUP NAME IN QUESTION#
         REG2 = GET(DN$AUXREF,DNAT$,REG1);
         REG3 = FINDAUX(UBRSECTION,REG2); 
         IF REG3 NQ 0 
         THEN BEGIN 
              #ONLY ONE UBR PER GROUP IS LEGAL# 
              ERROR(SEVERE,803,TABLELINE,TABLECOLUMN);
              RETURN; 
              END 
         #ATTACH AN AUX TABLE ENTRY TO THE REPORT GROUP DNAT# 
         #TYPE = UBR SECTION# 
         #FIRST BIG FIELD = UBR SECTION DNAT POINTER# 
         #SECOND BIG FIELD WILL CONTAIN A SUPPRESS SWITCH#
         #DNAT POINTER IF AND ONLY IF THE UBR SECTION CONTAINS# 
         #A SUPPRESS VERB - THE DNAT WILL BE CREATED BY#
         #THE SUPPRESS STATEMENT AND A NON-ZERO VALUE IN# 
         #SECOND BIG FIELD CAN BE USED TO DETERMINE IF A# 
         #SUPPRESS STATEMENT WAS PRESENT# 
         REG2 = ATTACHAUX(REG1);
         SET(AX$TTYPE,AUX$,REG2,UBRSECTION);
         SET(FST$BIG$FLD,AUX$,REG2,LASTSDEF); 
         #SAVE AUX POINTER SO SUPPRESS CAN FILL IN# 
         #SECOND BIG FIELD# 
         UBRAUXPTR = REG2;
         RETURN;
SUB39:  
#ON SIZE ERROR PROLOGUE#
         FIX1 = G;
         G = SIZEPATCH - 1; 
         NG($SIZEERROR);
         G = FIX1;
         NG($SIZEEND);
         IF ENDADDRESS EQ 0 THEN ENDADDRESS = NEXTPNAT; 
         NGLABELREF(ENDADDRESS,GFALSE); 
         NSFLAG = 1;
         RETURN;
SUB56:  
#SET TEMP BASE OFFSET#
         BASEOFFSET = MAXOFFSET;
         CURRNTOFFSET = BASEOFFSET; 
         RETURN;
SUB18:  
#MNEMONIC NAME ROUTINE# 
          #CHECK IF IDENTIFIER IS A MNEMONIC NAME#
          REG1 = TABLENAME; 
          IF GET(DN$LEVEL,DNAT$,REG1) EQ MNEMNAME 
          THEN BEGIN
               #SET FLAG FOR MNEMONIC#
               TRUEFALSE = 1; 
               #CHANGE GTEXT CODE IN STACK# 
               XTCODE(S,GSYSREF); 
               #SET UP LAT ENTRY FOR MNEMONIC NAME# 
               LATLENGTH = LATLENGTH + 1; 
               SET(L$GROUP,LAT$,LATLENGTH,0); 
               SET(L$DNAT,LAT$,LATLENGTH,REG1); 
               FIX1 = GET(DN$IMPLPTR,DNAT$,REG1); 
               SET(L$PLT,LAT$,LATLENGTH,FIX1);
               #CHANGE GTEXT POINTER FIELD IN STACK ATOM# 
               XTPOINTER(S,LATLENGTH);
               VERIFYIMP(FIX1); 
               END
          ELSE #ERROR OR UNDEFINED ACCEPTED AS MNEMONIC NAME# 
               IF GET(DN$TYPE,DNAT$,REG1) EQ ERRTYPE
               THEN TRUEFALSE = 1;
               ELSE TRUEFALSE = 0;
          RETURN; 
SUB19:  
#NULL ROUTINE#
          S = S + 1;
          S$ = S$ + 1;
          XSTACK(S,$NULL);
          RETURN; 
SUB20:  
# DIVIDE REMAINDER ROUTINE #
         OPERANDTEST(S-3);
         OPERANDTEST(S-2);
         RESULTTEST(S-1); 
         RESULTTEST(S); 
         # SEE IF DIVISOR OR DIVIDEND OVERLAPS QUOTIENT # 
         PROTECT(4);
         PROTECT(5);
         RETURN;
SUB21:  
# REFERENCE MODIFICATION PROLOGUE # 
          # REFERENCE MODIFICATION IS PRESENT # 
          # SEE STRING AND UNSTRING # 
         RMPRESENT = 1; 
         REG1 = GET(DN$TYPE,DNAT$,TABLENAME); 
         IF REG1 EQ ERRTYPE 
         THEN RETURN; 
         IF REG1 EQ COMP4 OR
            REG1 EQ COMP2 OR
            REG1 EQ BINARY OR 
            REG1 EQ DPCOMP2 OR
            REG1 EQ LINECTR OR
            REG1 EQ INDXDATA OR 
            REG1 EQ INDXNAME OR 
            REG1 EQ BOOLBIT OR
            REG1 EQ NONDATA 
         THEN BEGIN 
              # REFERENCE MODIFICATION IS ONLY ALLOWED #
              # ON DATA ITEMS WHOSE USAGE IS DISPLAY #
              DIAG478 = TRUE; 
              DIAGLINE = TABLELINE; 
              DIAGCOLUMN = TABLECOLUMN; 
              RETURN; 
              END 
         ELSE DIAG478 = FALSE;
         DNATLENGTH = DNATLENGTH + 1; 
         COPYD4(TABLENAME,DNATLENGTH);
         SET(DN$LEVEL,DNAT$,DNATLENGTH,REFMODLEVEL);
         SET(DN$REFERENCE,DNAT$,DNATLENGTH,TABLENAME);
         TABLENAME = DNATLENGTH;
         XTPOINTER(BACKPOINTER[MD],DNATLENGTH); 
         RMTABLENAME [MD] = TABLENAME;
         REG1 = GET(DN$TYPE,DNAT$,DNATLENGTH);
         IF REG1 NQ ALPHNUM AND 
            REG1 NQ ALPHABET AND
            REG1 NQ BOOLDSP 
         THEN BEGIN 
              SET(DN$TYPE,DNAT$,DNATLENGTH,ALPHNUM);
              END 
         RETURN;
SUB22:  
# REFERENCE MODIFICATION START ROUTINE #
         # TRANSFER FORMULA TO GTEXT #
         # END RESULT IS IN OPERAND1 #
          #COLON WAS FOUND SO DIAG 478 IS RELEVANT# 
         IF DIAG478 THEN ERROR(SEVERE,478,DIAGLINE,DIAGCOLUMN); 
         TRANSFER;
         IF MODIFIER [MD] EQ 0
         THEN BEGIN 
              MNUMBER = MNUMBER + 1;
              MODIFIER [MD] = MNUMBER;
              IF MNUMBER GR CCTMAXMNUM
              THEN BEGIN
                   CCTMAXMNUM = MNUMBER;
                   END
              XTSUBCODE(BACKPOINTER[MD],MODIFIER[MD]);
              END 
         S = S + 1; 
         XSTACK(S,GTX(GVERB,MODIFIER[MD],GREFLCP)); 
         S = S + 1; 
         XSTACK(S,RMOPERAND1);
         RETURN;
SUB23:  
# REFERENCE MODIFICATION END ROUTINE #
         S = S + 1; 
         XSTACK(S,GTX(GVERB,MODIFIER[MD],GREFLEN)); 
         S = S + 1; 
         XSTACK(S,$NULL); 
         RETURN;
SUB24:  
# REFERENCE MODIFICATION LENGTH ROUTINE # 
         # TRANSFER FORMULA TO GTEXT #
         # END RESULT IS IN OPERAND1 #
         TRANSFER;
         S = S + 1; 
         XSTACK(S,GTX(GVERB,MODIFIER[MD],GREFLEN)); 
         S = S + 1; 
         XSTACK(S,RMOPERAND1);
         RETURN;
SUB25:  
# REFERENCE MODIFICATION EPILOGUE # 
         IF CCTRFCHECK
         THEN BEGIN 
              S = S + 1;
              XSTACK(S,GTX(GVERB,MODIFIER[MD],GREFCHK));
              S = S + 1;
              XSTACK(S,GTX(GDATAREF,RMTABLENAME[MD],0));
              END 
         RETURN;
SUB43:  
# M-NUMBER PROLOGUE # 
         # SAVE S FOR BACK POINTER #
         MD = MD + 1; 
         IF MD GR MAXMD 
         THEN BEGIN 
              # M-NUMBER DEPTH EXCEEDS CURRENT MAXIMUM #
              CMM$GLV(MSTACK,35); 
              MAXMD = MAXMD + 5;
              END 
         # NO SUBSCRIPTS #
         # NO REFERENCE MODIFICATION #
         BACKPOINTER [MD] = S;
         MODIFIER [MD] = 0; 
         RMTABLENAME [MD] = TABLENAME;
         RMTABLELINE [MD] = TABLELINE;
         RMTABLECOL [MD] = TABLECOLUMN; 
         COUNTINDEX [MD] = 0; 
         RETURN;
SUB44:  
# M-NUMBER EPILOGUE # 
         REFCOUNTINDX = COUNTINDEX [MD];
         INITSNUMBER = SNUMBER [MD];
         TABLENAME = RMTABLENAME [MD];
         TABLELINE = RMTABLELINE [MD];
         TABLECOLUMN = RMTABLECOL [MD]; 
         # DECREMENT M-NUMBER DEPTH # 
         IF S NQ BACKPOINTER[MD]
         THEN BEGIN 
              # PUT BACK POINTER AND MARKER INTO STACK #
              S = S + 1;
              XSTACK(S,BACKPOINTER[MD]+1);
              S = S + 1;
              XSTACK(S,SUBMARKER);
              END 
         MD = MD - 1; 
         RETURN;
SUB26:  
# MOVE SUBSCRIPTS ROUTINE # 
         # OUTPUT SUBSCRIPTS AND/OR REF MOD TO GTEXT #
         S = REMOVE(1); 
         # MAINTAIN PROPER S AND S$ CORRESPONDENCE #
         S$ = S$ + 1; 
         RETURN;
SUB27:  
# STOP ROUTINE #
         VD;
         S = S + 1; 
         XSTACK (S,$STOP);
         RETURN;
SUB28:  
# STOP RUN #
         # SET UP PARAGRAPH STATUS FOR LAST STATEMENT TEST #
         PARSTATUS = 7; 
         S = S + 1; 
         XSTACK (S,$RUN); 
         RETURN;
SUB29:  
#PROC DIV PROLOGUE# 
          #CGEN THINKS 347 IS RWENTRY#
          NGGTX(GVERB,347,GVERBDES);
          NGGTX(GSUBVERB,VERBLINE,VERBCOLUMN);
          NGLABELDEF((NEXTPNAT)); 
          NG($ENTRY); 
          NGLABELREF(PNATLENGTH,0); 
          LATTEMP = PLTPROGNAME;
          NGLITREF((NEXTLAT));
          REG1 = DNATLENGTH;
          SET(DN$TYPE,DNAT$,REG1,ALPHNUM);
          #ACCESS LENGTH FROM PLT ENTRY#
          REG2 = GET(PL$LENGTH,PLT$,LATTEMP); 
          SET(DN$ITMLEN,DNAT$,REG1,REG2); 
          G = G + 1;
          PARAMPATCH = G; 
          PARAMCOUNT = 0; 
          MAXPDUSINGID = 0; 
          RETURN; 
SUB4: 
#PROC DIV EPILOGUE# 
          SETGT(PARAMPATCH,GTX(GSUBVERB,PARAMCOUNT,GCOUNT));
          IF CCTCOLLSEQ  NQ  0
          THEN BEGIN
               NG($SETALPHABET);
               NG($SETPROGRAM); 
               NGDATAREF(CCTCOLLSEQ); 
               END
          IF CCTLKDNATPTR NQ 0
          THEN   # MARK ALL 77 OR 01 LINDAGE SEC ITEMS NOT IN          #
              BEGIN   # THE PROCEDURE DIVISION USING PHRASE            #
              FIX1 = 1; 
              FOR I = CCTLKDNATPTR + 1 STEP 1 
              WHILE I LQ CCTDNATLEN AND 
                   ((GET(DN$LEVEL,DNAT$,I) LS 49 AND
                     GET(DN$LEVEL,DNAT$,I) GR 0) OR 
                    GET(DN$LEVEL,DNAT$,I) EQ 77 OR
                    GET(DN$LEVEL,DNAT$,I) EQ 66 OR
                    GET(DN$LEVEL,DNAT$,I) EQ 88)
              DO
                  BEGIN 
                  REG1 = GET(DN$LEVEL,DNAT$,I); 
                  IF REG1 EQ 77 OR REG1 EQ 1
                  THEN   # THIS DNAT IS A LEVEL 01 OR 77 ITEM          #
                      BEGIN 
                      FIX1 = 1;  # ASSUME LINK SEC ITEM NOT IN PD USING#
                      FOR J= 1 STEP 1 
                      WHILE FIX1 EQ 1 AND J LQ MAXPDUSINGID 
                      DO
                          BEGIN 
                          IF I EQ COMMONSTACK(J)
                          THEN   # ITEM IN PD USING PHRASE             #
                              BEGIN 
                              FIX1 = 0;   # FLAG IS SO                 #
                              END 
                          ELSE   # ITEM NOT IN PD USING PHRASE         #
                              BEGIN 
                              IF GET(DN$RDEF,DNAT$,I) NQ 0
                              THEN   # THIS ITEM REDIFINES AN ITEM     #
                                  BEGIN 
                                 REG2 = GET(DN$AUXREF,DNAT$,I); 
                                 REG2 = FINDAUX(RDEFNAME,REG2); 
                                 IF GET(AX$RDEFNAM,AUX$,REG2) EQ
                                       COMMONSTACK(J) 
                                 THEN   # THIS ITEM REDIFINES AN ITEM  #
                                     BEGIN   # IN THE PD USING PHRASE  #
                                     FIX1 = 0;   # FLAG IT SO          #
                                     END
                                 END
                              END 
                          END  # SEARCH OF PD USING ITEM STACK         #
                      IF FIX1 NQ 0
                      THEN   # 01 OR 77 NOT FOUND IN STACK             #
                          BEGIN   # DIAGNOSE AND CHANGE TO ERRTYPE     #
                          REG2 = GET(DN$LINE,DNAT$,I);
                          ERROR(ADVISORY,282,REG2,0); 
                          SET(DN$TYPE,DNAT$,I,ERRTYPE); 
                          END 
                      END 
                  ELSE   # THIS DNAT NOT 01 OR 77                      #
                      BEGIN 
                      IF FIX1 NQ 0
                      THEN   # SUBOR ITEM TO 01 NOT IN PD USING PHRASE #
                          BEGIN   # CHANGE TO ERRTYPE                  #
                          SET(DN$TYPE,DNAT$,I,ERRTYPE); 
                          END 
                      END 
                  END   # LOOP THRU LINKAGE SECTION DNATS              #
              END   # CHECK OF LNK SEC ITMS IN P. D. USING PHRASE      #
          RETURN; 
         END
         TERM 
