*DECK SET3
USETEXT CCTTEXT 
USETEXT DNTEXT
USETEXT PPTEXT
    PROC SET3;
         CONTROL PACK;
         BEGIN
*CALL DPPPDDATA 
*CALL PPCOMMON2 
*CALL RCT 
*CALL AUXTVALS
*CALL DNATVALS
*CALL FNATVALS
*CALL INTVALS 
*CALL PLTVALS 
         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,      , SUB25, 
         SUB26, SUB27, SUB28, SUB29, SUB30, 
         SUB31, SUB32, SUB33, SUB34, SUB35, 
         SUB36; 
     PROC CORR2;
         BEGIN
          ITEM I    I;
          #COPY SUBSCRIPT NUMBERS (IF ANY) TO THE CORRESPONDING PAIR# 
          XTSUBCODE(S,TSUBCODE(S-2)); 
          XTSUBCODE(S-1,TSUBCODE(S-3)); 
          #NOW, EXAMINE EACH MEMBER OF THE CORRESPONDING PAIR#
          FOR I = 0 STEP 1 UNTIL 1 DO BEGIN 
               #DNAT OF THE PAIR ITEM#
               REG1 = TPOINTER(S-I);
               #DNAT OF ORIGINAL GROUP# 
               REG2 = TPOINTER(S-I-2);
               #IGNORE THE PAIR IF THE ITEM IS AN INDEX DATA ITEM#
               IF GET(DN$TYPE,DNAT$,REG1) EQ INDXDATA 
               THEN GOTO IGNOREPAIR;
               GOTO L2; 
L1: 
               #MINOR LOOP# 
               #ARE WE SUBORDINATE TO AN ITEM THAT CONTAINS#
               #REDEFINES OR OCCURS  #
               #STOP WHEN WE REACH THE ORIGINAL GROUP#
               #DO NOT TEST ORIGINAL GROUP# 
               REG1 = REG1 - 1; 
               IF REG1 EQ REG2
               THEN GOTO BOTTOM;
               #TEST FOR SUPERIOR ITEM# 
               IF GET(DN$LEVEL,DNAT$,REG1) GQ REG3
               THEN GOTO L1;
L2: 
               #TEST PAIR (OR SUPERIOR) ITEM# 
               IF GET(DN$RDEF,DNAT$,REG1) EQ 1   OR 
                  GET(DN$OCCURS,DNAT$,REG1) EQ 1
               THEN GOTO IGNOREPAIR;
               REG3 = GET(DN$LEVEL,DNAT$,REG1); 
               GOTO L1; 
BOTTOM: 
               END   #END OF DO CASE# 
          GOTO L3;
IGNOREPAIR: 
          TRUEFALSE = 0;
L3: 
          RETURN; 
          END   #CORR2# 
  
         GOTO SUB[SUB$];
SUB2: 
# AR 1 #
          XSTACK(1,GTX(GDATAREF,(NEXTTEMP),0)); 
          OPERANDTEST(4); 
          OPERANDTEST(5); 
          RETURN; 
SUB5: 
# AR 2 #
          OPERANDTEST(S); 
          RETURN; 
SUB7: 
# AR 4 #
          RESULTTEST(S);
          RETURN; 
SUB8: 
# AR 5 #
          TRUEFALSE = 1;
          IF TCODE(S-1) EQ GLITREF
          THEN TRUEFALSE = 0; 
          RETURN; 
SUB9: 
# AR 6 #
          OPERANDTEST(S-1); 
          OPERANDTEST(S); 
          RETURN; 
SUB10:  
# AR 7 #
          OPERANDTEST(S); 
          IF FREEZEFLAG EQ 1
          THEN BEGIN
               TEMP = S-1;
               I = TPOINTER(TEMP);
               LATTEMP = GET(L$PLT,LAT$,I); 
               XTPOINTER(TEMP,(NEXTLAT)); 
               END
          RETURN; 
SUB11:  
# AR 8 #
          OPERANDTEST(S-1); 
          XSTACK(1,GTX(GDATAREF,(NEXTTEMP),0)); 
         #THIS TEMP IS NOT AN INTERMEDIATE RESULT TEMP# 
         #WE ARE PROTECTING AN OPERAND - COPY ATTRIBUTES OF THE GUY WE# 
         #ARE PROTECTING AND ASSIGN LEVEL TEMPLEVL# 
         REG1 = TPOINTER(S-1);
         COPYD4 (REG1,DNATLENGTH);
         SET(DN$LEVEL,DNAT$,DNATLENGTH,TEMPLEVL); 
          S = S+1;
          XSTACK(S,$MOVE);
          RETURN; 
SUB12:  
# AR 9 #
          OPERANDTEST(S-2); 
          OPERANDTEST(S-1); 
          RESULTTEST(S);
          RETURN; 
SUB4: 
# AR 11 # 
          XSTACK(2,$MOVE);
          XSTACK(3,$MOVEROUND); 
          RETURN; 
SUB6: 
# AR 12 # 
          IF ICOMPOSITE + FCOMPOSITE GR 18
          THEN ERROR(JOD,295,VERBLINE,VERBCOLUMN);
          RETURN; 
SUB13:  
# AR 13 # 
          IF ICOMPOSITE2 + FCOMPOSITE2 GR 18
          THEN ERROR(JOD,297,VERBLINE,VERBCOLUMN);
          RETURN; 
SUB28:  
# AR 16 # 
          XSTACK(1,GTX(GDATAREF,(NEXTTEMP),0)); 
          OPERANDTEST(6); 
          OPERANDTEST(5); 
          RETURN; 
SUB29:  
# AR 17 # 
          OPERANDTEST(S-1); 
          RESULTTEST(S);
          RETURN; 
SUB30:  
# AR 18 # 
          OPERANDTEST(S-1); 
          RETURN; 
SUB23:  
# AR 19 # 
          XSTACK(2,$REMAINDER); 
          XSTACK(3,$DIVREMROUND); 
          RETURN; 
SUB25:  
# AR 20 # 
          #SERIES IDENTIFIERS ARE NOT ALLOWED IN THE ADD OR SUBTRACT# 
          #CORRESPONDING STATEMENTS : HARD TO GET RIGHT COLUMN NUMBER#
          #FOR THE MESSAGE IF IT IS GENERATED IN THE TABLES#
          ERROR(JOD,83,LINE(S),COLUMN(S));
          RETURN; 
SUB31:  
# NEW TEMP1 R # 
          REG1 = 5; 
          GOTO NEWTEMPR;
SUB32:  
# NEW TEMP2 R # 
          REG1 = 6; 
          GOTO NEWTEMPR;
SUB33:  
# NEW TEMP3 R # 
          REG1 = 7; 
NEWTEMPR: 
          XSTACK(REG1,STACK(1));
          XSTACK(1,GTX(GDATAREF,(NEXTTEMP),0)); 
          RETURN; 
SUB1: 
# ADD ROUTINE # 
          VD; 
          NG($NOOP);
          SIZEPATCH = G;
          XSTACK(2,$ADD); 
          XSTACK(3,$ADDROUND);
          S = 3;
          ICOMPOSITE = 0; 
          FCOMPOSITE = 0; 
          RETURN; 
SUB3: 
#RESULT TEMP 14#
         FIX1 = TPOINTER(1);
         FIX2 = TPOINTER(4);
         RTEMP(FIX1,FIX2);
         RETURN;
SUB34:  
#RESULT TEMP 16#
         FIX1 = TPOINTER(1);
         FIX2 = TPOINTER(6);
         RTEMP(FIX1,FIX2);
         RETURN;
SUB35:  
#RESULT TEMP 17#
         FIX1 = TPOINTER(1);
         FIX2 = TPOINTER(7);
         RTEMP(FIX1,FIX2);
         RETURN;
SUB18:  
# ADD ROUNDED ROUTINE # 
          VERBENTRY = 3;
          RETURN; 
SUB19:  
# ADD WITHOUT ROUNDING #
          VERBENTRY = 2;
          RETURN; 
SUB15:  
# ADD CORR PAIR ROUTINE # 
         TRUEFALSE = 1; 
          CORR2;
          #DID CORR2 DISQUALIFY THIS PAIR  #
          IF TRUEFALSE EQ 0 
          THEN RETURN;
          #IF EITHER MEMBER IS A GROUP, THE PAIR DOESN"S CORRESPOND#
          #REMEMBER, THIS IS OK IN MOVE CORRESPONDING#
          FOR I = 0 STEP 1 UNTIL 1 DO BEGIN 
               J = TPOINTER(S-I); 
               TEMP = GET(DN$TYPE,DNAT$,J); 
               IF TEMP EQ GROUP OR TEMP EQ VARGROUP 
               THEN BEGIN 
                    TRUEFALSE = 0;
                    RETURN; 
                    END 
               END
          #OK SO FAR - NOW BOTH MEMBERS MUST BE NUMERIC#
          #OTHERWISE - THEY DO NOT CORRESPOND#
          FOR I = 0 STEP 1 UNTIL 1 DO BEGIN 
               J = TPOINTER(S-I); 
               TEMP = GET(DN$TYPE,DNAT$,J); 
               IF TEMP LS LOWNUMOPERND OR TEMP GR HINUMOPERND 
               THEN BEGIN 
                    TRUEFALSE = 0;
                    RETURN; 
                    END 
               END
          #INCREMENT COUNTER FOR NUMBER OF CORRESPONDING PAIRS# 
          PAIRCOUNT = PAIRCOUNT + 1;
          RETURN; 
  
SUB36:  
# ADD OR SUBTRACT CORR SEPARATOR ROUTINE #
         NG($SEPARATOR);
         RETURN;
  
SUB14:  
# CORR OPERAND1 ROUTINE # 
          #SAVE REF COUNT TABLE INDEX OF SENDING FIELD# 
          SENDREFINDX = REFCOUNTINDX; 
          GOTO CORRLEGALITY;
SUB17:  
# CORR OPERAND2 ROUTINE # 
          #INITIALIZE COUNTER FOR NUMBER OF CORRESPONDING PAIRS#
          PAIRCOUNT = 0;
          #SAVE REF COUNT TABLE INDEX FOR RECEIVING FIELD#
          RECREFINDX = REFCOUNTINDX;
          #FALL THROUGH#
CORRLEGALITY: 
          #THE OPERAND MUST BE A GROUP ITEM : LEVEL = 1->49#
          REG1 = TABLENAME; 
          REG2 = GET(DN$LEVEL,DNAT$,REG1);
          REG3 = GET(DN$TYPE,DNAT$,REG1); 
          IF REG3 NQ ERRTYPE
          THEN BEGIN
               IF REG2 EQ 66
               THEN  ERROR(SEVERE,66,TABLELINE,TABLECOLUMN);
               IF GET(DN$USAGIDX,DNAT$,REG1) EQ 1 
               THEN  ERROR(SEVERE,294,TABLELINE,TABLECOLUMN); 
               #IS THE OPERAND A GROUP ITEM # 
               IF REG3 NQ GROUP AND REG3 NQ VARGROUP
               THEN  ERROR(SEVERE,119,TABLELINE,TABLECOLUMN); 
               END
               IF REG2 EQ REFMODLEVEL 
               THEN BEGIN 
                    # REFERENCE MODIFICATION IS NOT ALLOWED IN THIS # 
                    # CONTEXT # 
                    ERROR(SEVERE,479,TABLELINE,TABLECOLUMN);
                    END 
          RETURN; 
SUB16:  
# CORR END ROUTINE #
          #ARE THERE ANY CORRESPONDING PAIRS #
          IF PAIRCOUNT EQ 0 
          THEN BEGIN
              #GEN MESSAGE IF NO PREVIOUS STATEMENT ERRORS# 
              IF FREEZEFLAG EQ 1
               THEN  ERROR(ADVISORY,288,LINE(S),COLUMN(S)); 
               #FOR NO PAIRS THE REF COUNTS FOR ANY SUBS WILL BE 0# 
               END
          #FIX UP REF COUNTS FOR SENDING,RECEIVING IDENTIFIERS# 
          IF SENDREFINDX NQ 0 
          THEN BEGIN
               FIX1 = GET(RCT$ENTRY,RCT$,SENDREFINDX)+PAIRCOUNT-1;
               SET(RCT$ENTRY,RCT$,SENDREFINDX,FIX1);
               END
          IF RECREFINDX NQ 0
          THEN BEGIN
               FIX1 = GET(RCT$ENTRY,RCT$,RECREFINDX)+PAIRCOUNT-1; 
               SET(RCT$ENTRY,RCT$,RECREFINDX,FIX1); 
               END
          RETURN; 
SUB27:  
# SUBTRACT ROUTINE #
          VD; 
          NG($NOOP);
          SIZEPATCH = G;
          XSTACK(2,$SUBTRACT);
          XSTACK(3,$SUBTRACTRND); 
          XSTACK(4,$ADD); 
          S = 4;
          ICOMPOSITE = 0; 
          FCOMPOSITE = 0; 
          RETURN; 
SUB26:  
# MULTIPLY ROUTINE #
          VD; 
          NG($NOOP);
          SIZEPATCH = G;
          XSTACK(2,$MULTIPLY);
          XSTACK(3,$MULTROUND); 
          S = 3;
          ICOMPOSITE2 = 0;
          FCOMPOSITE2 = 0;
          RETURN; 
SUB20:  
# DIVIDE ROUTINE #
          VD; 
          NG($NOOP);
          SIZEPATCH = G;
          XSTACK(2,$DIVIDE);
          XSTACK(3,$DIVIDEROUND); 
          S = 3;
          ICOMPOSITE2 = 0;
          FCOMPOSITE2 = 0;
          RETURN; 
SUB21:  
# DIVIDE INTO ROUTINE # 
          DIVIDEND = 5; 
          DIVISOR = 4;
          RETURN; 
SUB22:  
# DIVIDE BY ROUTINE # 
          DIVIDEND = 4; 
          DIVISOR = 5;
          RETURN; 
          END   #SET3#
          TERM
