*DECK QSORT4
PROC QSORT4(  L1, U1 ); 
  # THIS ROUTINE SORTS THE ERRORS IN WORK1 ACCORDING TO LINE, COL AND 
    ERROR MESSAGE NUMBER
  # 
  
  # TO ENSURE THAT THE ERROR IS IN MEMORY, A VIRTUAL (REAL) INDEX IS
    COMPUTED AND HELD IN AN INDEX PREFIXED BY R 
  # 
BEGIN 
   ITEM  $$$DUMMY$$$$  I; 
   ITEM  L1 I;
   ITEM  U1 I;
   ITEM  P I; 
   ITEM  Q I; 
   ITEM  IX I;
   ITEM  IZ I;
   ITEM  I I; 
   ITEM  J I; 
   ITEM  XC U;
   ITEM  XXC U; 
   ITEM  YC U;
   ITEM  ZC U;
   ITEM  ZZC U; 
   ITEM  D1C I; 
   ITEM  D2C I; 
   ITEM  SP I;
   ITEM  SB I;
   ITEM  L I; 
   ITEM  U I; 
*CALL TABLNAMES 
*CALL GETSET
*CALL WORKTABS
*CALL ETEXT 
  DEF AC #W1$SORT$KEY#; 
  DEF DFVIRTUAL(XX) #VIRTUAL(TABLETYPE"WORK1$",XX)#;
    ARRAY STACK [1] ; 
    BEGIN 
        ITEM LS$ U(0,0,20), 
             US  U(0,20,20),
             RS  U(0,40,20),
         STACKWORD U(0,0,60); 
     END
$BEGIN
  XREF ITEM DFDEBUG B;
  XREF PROC OUTPUT   ;
XREF
  BEGIN 
    FUNC OCT C(40); 
    PROC DISPLAY; 
    FUNC DEC C(10); 
  END 
$END
  
  ITEM RP U, RQ U, RIX U, RIZ U;
  
CONTROL EJECT;
  $BEGIN
    IF DFDEBUG THEN OUTPUT(2," QSORT4 CA","LLED."); 
    IF DFDEBUG THEN 
      BEGIN 
        OUTPUT(4," PARAM1= ",DEC(L1), "PARAM2= ", DEC(U1)); 
      END 
  $END
  SP = U1 + 1;  #START OF SAVE STACK IN WORK1 # 
SORT: 
  L = L1; U = U1; 
PART: 
  P = L;
  RP = DFVIRTUAL(P);
  Q = U;
  XC = AC[RP];
  RQ = DFVIRTUAL(Q);
  ZC = AC[RQ];
  I = 0;
  J = Q - P - 1;
  D1C = XC; 
  D2C = ZC; 
  IF D1C GR D2C 
  THEN
    BEGIN 
    RP = DFVIRTUAL(P);
    YC = XC;
    AC[RP] = ZC;
    RQ = DFVIRTUAL(Q);
    XC = ZC;
    AC[RQ] = YC;
    ZC = YC;
    END 
  IF U - L GR 1 
  THEN
    BEGIN 
    XXC = XC; 
    IX = P; 
    ZZC = ZC; 
    IZ = Q; 
 LEFT:  
    FOR $$$DUMMY$$$$ = 0 WHILE P + 1 LS Q DO
      BEGIN 
      P = P + 1;
      RP = DFVIRTUAL(P);
      XC = AC[RP];
      D1C = XC; 
      D2C = XXC;
      IF D1C GQ D2C 
      THEN
        GOTO RIGHT; 
      END 
    P = Q - 1;
    GOTO OUT; 
 RIGHT: 
    FOR $$$DUMMY$$$$ = 0 WHILE Q - 1 GR P DO
      BEGIN 
      Q = Q - 1;
      RQ = DFVIRTUAL(Q);
      ZC = AC[RQ];
      D1C = ZC; 
      D2C = ZZC;
      IF D1C LQ D2C 
      THEN
        GOTO DIST;
      END 
    Q = P;
    P = P - 1;
    RP = DFVIRTUAL(P);
    ZC = XC;
    XC = AC[RP];
 DIST:  
    D1C = XC; 
    D2C = ZC; 
    IF D1C GR D2C 
    THEN
      BEGIN 
      RP = DFVIRTUAL(P);
      YC = XC;
      AC[RP] = ZC;
      RQ = DFVIRTUAL(Q);
      XC = ZC;
      AC[RQ] = YC;
      ZC = YC;
      END 
    D1C = XC; 
    D2C = XXC;
    IF D1C GR D2C 
    THEN
      BEGIN 
      XXC = XC; 
      I = I + 1;
      IX = P; 
      END 
    D1C = ZC; 
    D2C = ZZC;
    IF D1C LS D2C 
    THEN
      BEGIN 
      ZZC = ZC; 
      I = I + 1;
      IZ = Q; 
      END 
    GOTO LEFT;
 OUT: 
    IF P NQ IX AND XC NQ XXC
    THEN
      BEGIN 
      RP = DFVIRTUAL(P);
      AC[RP] = XXC; 
      RIX = DFVIRTUAL(IX);
      AC[RIX] = XC; 
      END 
    IF Q NQ IZ AND ZC NQ ZZC
    THEN
      BEGIN 
      RQ = DFVIRTUAL(Q);
      AC[RQ] = ZZC; 
      RIZ = DFVIRTUAL(IZ);
      AC[RIZ] = ZC; 
      END 
    IF U-Q GR P-L 
    THEN
      BEGIN L1 = L; U1 = P-1; L = Q+1;
      END 
    ELSE
      BEGIN U1 = U; L1 = Q+1; U = P-1;
      END 
    IF I NQ J 
    THEN
      BEGIN 
      IF U1 GR L1 
      THEN
        BEGIN 
          SP=SP+1;  LS$[0]=L; US[0]=U ; RS[0] = 1;
          SETFIELD(WORK1WORD,WORK1$,SP,STACKWORD[0]); 
          GOTO SORT ; 
  
RS1:  
          STACKWORD[0] = GETFIELD(WORK1WORD,WORK1$,SP); 
          L= LS$[0]; U = US[0];  SP= SP-1 ; 
        END 
      IF U GR L THEN GOTO PART; 
      END 
    END 
  IF SP GR U1 + 1 
  THEN
    BEGIN 
          IF RS[0] EQ 1 THEN GOTO RS1;
          IF RS[0] EQ 2 THEN GOTO RS2;
    END 
  IF U1 GR L1 
  THEN
    BEGIN 
           SP= SP+1 ; LS$[0] =L; US[0] = U; RS[0] = 2;
           SETFIELD(WORK1WORD,WORK1$,SP,STACKWORD[0]);
           GOTO SORT ;
RS2:  
            STACKWORD[0] = GETFIELD(WORK1WORD,WORK1$,SP); 
            L= LS$[0];  U = US[0]; SP =SP -1 ;
  
    END 
END #QSORT4#
TERM
