Sort

SQR Techniques - Sorting Arrays

Bubble, Insertion, Short are demonstrated. I'll also provide a detailed description of a Recursive Sort (QuickSort). Demo versions of these programs may be downloaded.

Defining and Loading a Sample Array

We'll load a simple 100 element array with a key value ranging from '0100' to '0001' (descending order). The objective of each sort routine is to place the elements in ascending order (i.e. '0001' thru '0100').

!**********************************************************************
!*       Define Array                                                 *
!**********************************************************************

begin-procedure Define-Array

create-array name=ARRdat size=101 field=ARRkey:char

let #ARR     = 0
let #ARR_max = 100

end-procedure

!**********************************************************************
!*       Load Array                                                   *
!**********************************************************************

begin-procedure Load-Array

let #ARR       = 0
let #ctr       = #ARR_max

while #ARR     < #ARR_max

  let #ARRkey              = #ctr
  let $ARRkey              = edit(#ARRkey,'0999')

  let ARRdat.ARRkey (#ARR) = $ARRkey

  let #ARR                 = #ARR + 1
  let #ctr                 = #ctr - 1

end-while

end-procedure

Bubble Sort

!**********************************************************************
!*       Sort Array - Bubble                                          *
!**********************************************************************

begin-procedure SORT-Bubble

let #SORTptr = 0

while #SORTptr < #ARR_max

   let #SCANptr = #SORTptr + 1

   get $SORTkey from ARRdat (#SORTptr) ARRkey

   while #SCANptr < #ARR_max

      get $SCANkey from ARRdat (#SCANptr) ARRkey

      if  $SORTkey > $SCANkey

          put $SORTkey into ARRdat (#SCANptr) ARRkey
          put $SCANkey into ARRdat (#SORTptr) ARRkey

          let $SORTkey =  $SCANkey

      end-if

      let #SCANptr = #SCANptr + 1

   end-while

   let #SORTptr = #SORTptr + 1

end-while

end-procedure

Insertion Sort

!**********************************************************************
!*       Sort Array - Insertion                                       *
!**********************************************************************

begin-procedure SORT-Insertion

let #SORTptr = 1

while #SORTptr < #ARR_max

   let $SORTkey = ARRdat.ARRkey (#SORTptr)

   let #SCANptr = #SORTptr - 1
   let $SCANkey = ARRdat.ARRkey (#SCANptr)

   while $SORTkey    < $SCANkey
     and #SCANptr   >= 0

       let ARRdat.ARRkey (#SCANptr + 1) = $SCANkey

       let #SCANptr = #SCANptr - 1

       if  #SCANptr >= 0
           let $SCANkey = ARRdat.ARRkey (#SCANptr)
       end-if

   end-while

   let ARRdat.ARRkey (#SCANptr + 1) = $SORTkey

   let #SORTptr = #SORTptr + 1

end-while

end-procedure

Short Sort

Note: This sort is very slow. This is only effective for very, very small arrays. It is worthy of discussion as an alternate example of sorting. Personally I've found the Bubble Sort to be most effective. It is fairly quick and very easy to understand and maintain. The decision on choosing a sort method is dictated by the number of rows being sorted AND the number of times the sort routine will be called. The Recursive Sort found later is much quicker but very abstract.

!**********************************************************************
!*       Sort Array - Short                                           *
!**********************************************************************

begin-procedure SORT-Short

let #SORTptr = 0

while #SORTptr < #ARR_max - 1

   let $SORTkey = ARRdat.ARRkey (#SORTptr)
   let $SCANkey = ARRdat.ARRkey (#SORTptr + 1)

   if  $SORTkey > $SCANkey

       let ARRdat.ARRkey (#SORTptr)     = $SCANkey
       let ARRdat.ARRkey (#SORTptr + 1) = $SORTkey
       let #SORTptr = -1

   end-if

   let #SORTptr = #SORTptr + 1

end-while

end-procedure

Recursive Sort (QuickSort)

Below is the full SQR source code demonstrating a recursive sort. An array is loaded in random order which consists of State, Area Code and description. The array is then put into ascending State/Area Code sequence. This is a two-column sort. SQR provides a sample QuickSort algorithm which had plenty of room for improvement. Since I've used this technique previously using Assembler language this was a good opportunity to duplicate the procedure in SQR.

!**********************************************************************
!*                                                                    *
!*       MODULE:  TDSORTR.SQR                                         *
!*       AUTHOR:  TONY DELIA.                                         *
!*         DATE:  03/01/1999.                                         *
!*       SYSTEM:  TD SQR UTILITY SERIES.                              *
!*         DESC:  SQR RECURSIVE SORT EXPLANATION (QUICKSORT).         *
!*                                                                    *
!**********************************************************************
!*                                                                    *
!*         NOTE:  THIS SAMPLE EXPANDS ON THE SQR TUTORIAL PROGRAM     *
!*                EX24A.SQR (QUICKSORT SAMPLE CODE). THE QUICKSORT    *
!*                ALGORITHM IS COMMONLY UTILIZED IN C, BASIC, JAVA,   *
!*                ETC. BUT NOT COMMONLY UNDERSTOOD. SOME STRUCTURAL   *
!*                CHANGES HAVE BEEN MADE TO THE QUICKSORT ROUTINE     *
!*                AS FOLLOWS:                                         *
!*                                                                    *
!*                A) ALLOW MULTIPLE SORT KEYS TO BE USED.             *
!*                                                                    *
!*                   EXAMPLE USES STATE AND AREA CODE AS KEYS.        *
!*                                                                    *
!*                B) SENSIBLE POINTER NAMES REPLACING #m, #n, #i, #j. *
!*                                                                    *
!*                   #qlo  - LO ARRAY BOUNDARY.                       *
!*                   #qhi  - HI ARRAY BOUNDARY.                       *
!*                   #qbwd - BACKWARD TRAVERSAL POINTER.              *
!*                   #qfwd - FORWARD  TRAVERSAL POINTER.              *
!*                                                                    *
!*                C) CHANGED MISLEADING POINTER LIMIT ON BACKWARD     *
!*                   TRAVERSAL. EX24A.SQR USES STATEMENT...           *
!*                                                                    *
!*                   while #j >= 0  TO CONTROL BACKWARD TRAVERSAL.    *
!*                                                                    *
!*                   THIS IMPLIES BACKWARD TRAVERSAL GOES THROUGH THE *
!*                   START OF ARRAY. ACTUALLY THE BACKWARD TRAVERSAL  *
!*                   ENDS WHEN IT INTERSECTS WITH FORWARD POINTER.    *
!*                   BESIDES WHEN 2ND RECURSIVE SORT IS CALLED WITHIN *
!*                   THE 'PARENT' SORT THE LO BOUNDARY IS NEVER ZERO. *
!*                                                                    *
!*                D) FURTHER CLARIFIED CODE ON FINAL SWAP. CURRENTLY  *
!*                   LO/BWD SWAP IS UNCONDITIONAL. IF ELEMENTS ARE IN *
!*                   THEIR PROPER PLACE THERE'S NO NEED TO SWAP. ALSO *
!*                   STREAMLINED RECURSIVE ARRAY POPULATION A BIT.    *
!*                                                                    *
!*                E) COMMENTS INSERTED TO EXPLAIN FUNCTIONALITY OF    *
!*                   PROGRAM.                                         *
!*                                                                    *
!**********************************************************************
!*                                                                    *
!*     OVERVIEW:  THE RECURSIVE 'QUICKSORT' PERFORMS SEVERAL TASKS.   *
!*                NOTE THE FIRST ELEMENT IS USED AS THE 'OBJECT' KEY. *
!*                LO AND HI ARRAY BOUNDARIES ARE PASSED TO THE SORT.  *
!*                                                                    *
!*                THE FIRST STEP USES A FORWARD POINTER TO FIND THE   *
!*                'NEXT' ELEMENT > OBJECT KEY. THEN STARTING FROM THE *
!*                HI BOUNDARY A BACKWARD POINTER IS USED TO FIND THE  *
!*                'NEXT' ELEMENT < OBJECT KEY. THE FWD AND BWD ARRAY  *
!*                ELEMENTS MAY THEN BE SWAPPED. THIS IS BASED ON THE  *
!*                SIMPLE ALGEBRAIC RULE:                              *
!*                                                                    *
!*                IF (KEY < FWD) AND (KEY > BWD) THEN (FWD > BWD).    *
!*                                                                    *
!*                ABOVE PROCESS REPEATED UNTIL FWD/BWD POINTERS       *
!*                INTERSECT. ONCE COMPLETE A FINAL SWAP 'MAY' BE      *
!*                REQUIRED BETWEEN THE OBJECT KEY (LO) AND BACKWARD   *
!*                POINTER. AT THIS POINT THE BACKWARD POINTER IS USED *
!*                AS A TABLE DIVIDER. FOR BOTH SECTIONS THE RECURSIVE *
!*                SORT IS PERFORMED AGAIN USING THE SECTION LO/HI     *
!*                BOUNDARIES. SINCE SQR DOES NOT SUPPORT RECURSIVE    *
!*                VARIABLES AN ARRAY IS USED TO STORE LO/HI BOUNDARY  *
!*                PARAMETERS FOR THE SECOND HALF OF THE TABLE (THE    *
!*                FIRST SECTION IS CALLED IMMEDIATELY).               *
!*                                                                    *
!*      GRAPHIC:                                                      *
!*                     ---------------------------------------------- *
!*              LEVEL  LO     FWD->                     <-BWD      HI *
!*               #1    0   1   2   3   4   5   6   .   .   .   .   n  *
!*                                            /|                      *
!*                     ---------------------   ---------------------- *
!*              LEVEL  LO  FWD->    <-BWD HI   LO  FWD->    <-BWD  HI *
!*               #2    0   1   2   3   4   5   6   .   .   .   .   n  *
!*                                /|                      /|          *
!*                     etc.        etc.        etc.        etc.       *
!*                     ---------   ---------   ---------   ---------- *
!*               #3    0   1   2   3   4   5   6   .   .   .   .   n  *
!*                                                                    *
!**********************************************************************
!*                                                                    *
!*                SEE TDSORTR.ALC FOR IBM/370 ASSEMBLER VERSION OF    *
!*                RECURSIVE SORTING. COMMENTS GIVEN FOR EACH LINE.    *
!*                SAME STATE/AREACODE/DESCRIPTION ARRAY USED IN BOTH  *
!*                ASSEMBLER AND SQR VERSIONS.                         *
!*                                                                    *
!**********************************************************************

#include 'setenv.sqc'        ! Set environment

!**********************************************************************
!*       Setup Procedure                                              *
!**********************************************************************

begin-setup

#Include 'setup02a.sqc'      ! Printer and page-size init landscape
#define max_rows 5000

end-setup

!**********************************************************************
!*       Mainline Processing                                          *
!**********************************************************************

begin-report

  do Init-DateTime
  do Get-Current-DateTime
  move $AsOfToday   to $AsOfDate

  do Process-Main

end-report

!**********************************************************************
!*       Set Defaults                                                 *
!**********************************************************************

begin-procedure Set-Defaults

let $ReportId     = 'TDSORTR'
let $ReportTitle  = 'SQR Recursive Sort (QuickSort)'

display $ReportId    noline
display ' '          noline
display $ReportTitle
display ' '

end-procedure

!**********************************************************************
!*       Process Main                                                 *
!**********************************************************************

begin-procedure Process-Main

create-array name=Qsort   size={max_rows} field=Qlo:number   -
                                          field=Qhi:number

create-array name=Qarray  size={max_rows} field=Qkey:char    -
                                          field=Qarea:char   -
                                          field=Qdesc:char

do Load-Array

do QuickSort(0, 0, #Qmax)

do Display-Results

end-procedure

!**********************************************************************
!*       Recursive Sort                                               *
!**********************************************************************

begin-procedure QuickSort(#level, #Qlo, #Qhi)

if #Qlo < #Qhi

   let #Qfwd  = #Qlo                ! Init forward  pointer
   let #Qbwd  = #Qhi + 1            ! Init backward pointer

   !   Lo Boundary is Key Object(s)
   let $Qkey  = Qarray.Qkey  (#Qlo)
   let $Qarea = Qarray.Qarea (#Qlo)

   while 1 = 1

      !     Traverse Forward  - find 'next' array.key > Qkey
      !     Bypass all keys less than Object Key (Qkey)
      let   #Qfwd      = #Qfwd + 1
      while #Qfwd     <= #Qbwd
            if  $Qkey  < Qarray.Qkey  (#Qfwd)
            or  $Qkey  = Qarray.Qkey  (#Qfwd)
            and $Qarea < Qarray.Qarea (#Qfwd)
               break
            end-if
            let #Qfwd = #Qfwd + 1
      end-while

      !     Traverse Backward - find 'next' array.key < Qkey
      !     Bypass all keys more than Object Key (Qkey)
      let   #Qbwd     = #Qbwd - 1
!     while #Qbwd    >= 0                  ! SQR Book uses zero but...
      while #Qbwd    >= #Qfwd              ! Logically #Qfwd is limit
            if  $Qkey  > Qarray.Qkey  (#Qbwd)
            or  $Qkey  = Qarray.Qkey  (#Qbwd)
            and $Qarea > Qarray.Qarea (#Qbwd)
                break
            end-if
            let #Qbwd = #Qbwd - 1
      end-while

      !  Once traversed Boundaries meet exit main loop
      if #Qfwd >= #Qbwd
         break
      end-if

      !  Swap Forward/Backward Elements
      do QSortSwap(#Qfwd, #Qbwd)

   end-while

   !   Swap Lo Boundary / Backward Elements
   if  $Qkey  > Qarray.Qkey  (#Qbwd)
   or  $Qkey  = Qarray.Qkey  (#Qbwd)
   and $Qarea > Qarray.Qarea (#Qbwd)
       do QSortSwap(#Qlo, #Qbwd)
   end-if

   !   At this point the table is split in two sections.
   !   Save boundaries of 2nd half (due to non-recursive variables)
   let #level                  = #level + 1
   let Qsort.Qlo  (#level - 1) = #Qbwd  + 1
   let Qsort.Qhi  (#level - 1) = #Qhi

   !   Now sort from Lo to New Hi
   let #Qhi                    = #Qbwd  - 1
   do QuickSort(#level, #Qlo, #Qhi)

   !   Now sort from New Lo to Hi (Restoring first)
   let #Qlo                    = Qsort.Qlo (#level - 1)
   let #Qhi                    = Qsort.Qhi (#level - 1)
   do QuickSort(#level, #Qlo, #Qhi)

   let #level                  = #level - 1

end-if

end-procedure

!**********************************************************************
!*       Sort Lo/Hi Array Elements                                    *
!**********************************************************************

begin-procedure QSortSwap(#lo, #hi)

get $Qkey $Qarea $Qdesc from Qarray (#lo) Qkey Qarea Qdesc

let Qarray.Qkey   (#lo) = Qarray.Qkey  (#hi)
let Qarray.Qarea  (#lo) = Qarray.Qarea (#hi)
let Qarray.Qdesc  (#lo) = Qarray.Qdesc (#hi)

put $Qkey $Qarea $Qdesc into Qarray (#hi) Qkey Qarea Qdesc

end-procedure

!**********************************************************************
!*       Load Array                                                   *
!**********************************************************************

begin-procedure Load-Array

let #idx                 = 0

let $Qdata               = 'AK907ALASKA'
do Load-Element

let $Qdata               = 'DE302DELAWARE'
do Load-Element

let $Qdata               = 'GA404GEORGIA'
do Load-Element

let $Qdata               = 'GA706GEORGIA'
do Load-Element

let $Qdata               = 'MD301MARYLAND'
do Load-Element

let $Qdata               = 'NJ201NEW JERSEY'
do Load-Element

let $Qdata               = 'WA206WASHINGTON'
do Load-Element

let $Qdata               = 'NY607NEW YORK'
do Load-Element

let $Qdata               = 'NJ908NEW JERSEY'
do Load-Element

let $Qdata               = 'NJ609NEW JERSEY'
do Load-Element

let $Qdata               = 'WA509WASHINGTON'
do Load-Element

let $Qdata               = 'MD410MARYLAND'
do Load-Element

let $Qdata               = 'PA610PENNSYLVANIA'
do Load-Element

let $Qdata               = 'GA912GEORGIA'
do Load-Element

let $Qdata               = 'NY212NEW YORK'
do Load-Element

let $Qdata               = 'PA412PENNSYLVANIA'
do Load-Element

let $Qdata               = 'NY914NEW YORK'
do Load-Element

let $Qdata               = 'PA814PENNSYLVANIA'
do Load-Element

let $Qdata               = 'NY315NEW YORK'
do Load-Element

let $Qdata               = 'NY516NEW YORK'
do Load-Element

let $Qdata               = 'NY716NEW YORK'
do Load-Element

let $Qdata               = 'NY917NEW YORK'
do Load-Element

let $Qdata               = 'NY917MANHATTEN'
do Load-Element

let $Qdata               = 'PA215PENNSYLVANIA'
do Load-Element

let $Qdata               = 'PA717PENNSYLVANIA'
do Load-Element

let $Qdata               = 'NY518NEW YORK'
do Load-Element

let $Qdata               = 'NY718NEW YORK'
do Load-Element

let $Qdata               = 'PA724PENNSYLVANIA'
do Load-Element

let $Qdata               = 'NJ732NEW JERSEY'
do Load-Element

let $Qdata               = 'MD240MARYLAND'
do Load-Element

let $Qdata               = 'MD443MARYLAND'
do Load-Element

let $Qdata               = 'WA360WASHINGTON'
do Load-Element

let $Qdata               = 'GA770GEORGIA'
do Load-Element

let $Qdata               = 'NJ973NEW JERSEY'
do Load-Element

let $Qdata               = 'GA678GEORGIA'
do Load-Element

let #Qmax                = #idx - 1

end-procedure

!**********************************************************************
!*       Load Element                                                 *
!**********************************************************************

begin-procedure Load-Element

let Qarray.Qkey   (#idx) = substr($Qdata,1,2)
let Qarray.Qarea  (#idx) = substr($Qdata,3,3)
let Qarray.Qdesc  (#idx) = rtrim(substr($Qdata,6,20),' ')
let #idx                 = #idx + 1

end-procedure

!**********************************************************************
!*       Display Results                                              *
!**********************************************************************

begin-procedure Display-Results

display ' '
display 'Sorted Results'
display ' '
display 'State  Area  Description'
display '-----  ----  --------------------'
display ' '

let   #idx  = 0
while #idx <= #Qmax

   let $Qkey     = Qarray.Qkey  (#idx)
   let $Qarea    = Qarray.Qarea (#idx)
   let $Qdesc    = Qarray.Qdesc (#idx)

   let $Qdata    = rpad($Qkey,7,' ') || rpad($Qarea,6,' ') || $Qdesc

   display $Qdata

   let #idx = #idx + 1

end-while

display ' '

end-procedure

!**********************************************************************
!*       Include Members:                                             *
!**********************************************************************

#Include 'curdttim.sqc'  !Get-Current-DateTime procedure
#Include 'datetime.sqc'  !Routines for date and time formatting
                         !Init-DateTime procedure

!**********************************************************************
!*       End of Program                                               *
!**********************************************************************

Special Treat - The ASSEMBLER version

For those familiar with my posts to the SQR User Group you may have noticed I occasionally include an assembler version of techniques in addition to the SQR version. The reason is simple. I comment each line of code and it is extremely effective in explaining what is actually happening in the process. If you're not familiar with assembler the comments alone should be beneficial. The assembler version is the exact equivalent to the SQR version not only in technique, but also the actual data stored in the array.

!**********************************************************************
         TITLE 'TDSORTR  - PC/370 4.2 RECURSIVE SORT// DELIA'
***********************************************************************
*                                                                     *
*        MODULE:  TDSORTR.                                            *
*        AUTHOR:  TONY DELIA.                                         *
*          DATE:  09/25/96.                                           *
*          DESC:  PC/370 4.2 - RECURSIVE SORT.                        *
*          NOTE:  PC/370 RELEASE 4.2                                  *
*                                                                     *
***********************************************************************
         EJECT
***********************************************************************
*        T  D  S  O  R  T  R        P  R  O  G  R  A  M               *
***********************************************************************
TDSORTR  START 0                             START PROGRAM
         STM   14,12,12(13)                  SAVE REGISTERS
         LR    12,15                         LOAD PROGRAM ENTRY POINT
         USING TDSORTR+0*4096,12             BASE REGISTER 1
         L     11,BASE2                      LOAD BASE REGISTER 2
         USING TDSORTR+1*4096,11             TELL ASSEMBLER ABOUT BASE2
         ST    13,SAVE+4                     SAVE EXTERNAL SAVE ADDRESS
         LR    14,13                         XFER ADDRESS TO TEMP R14
         LA    13,SAVE                       LOAD INTERNAL SAVE ADDRESS
         ST    13,8(14)                      SAVE IN EXTERNAL SAVE AREA
         B     GO                            BRANCH TO PROCESSING RTN
***********************************************************************
RETURN   EQU   *                             TIME TO RETURN
         L     13,SAVE+4                     RESTORE REGISTER 13
         LM    14,12,12(13)                  RESTORE REMAINING REGS
         SR    15,15                         CLEAR RETURN CODE
         BR    14                            BRANCH TO CALLING PROGRAM
***********************************************************************
SAVE     DC    18F'0'                        S A V E   A R E A
***********************************************************************
BASE2    DC    A(TDSORTR+1*4096)             BASE2 DISPLACEMENT
***********************************************************************
GO       EQU   *                             BEGIN PROCESSING ...
***********************************************************************
         EJECT
***********************************************************************
*        MAINLINE PROCEDURE                                           *
***********************************************************************
         PRINT NOGEN
         LA    2,=C'BEFORE SORT <enter>$'    LOAD FIELD ADDRESS
         SVC   @WTO                          ISSUE SUPERVISOR CALL
         SVC   @RDKEY                        ISSUE SUPERVISOR CALL
         STC   0,KEY                         STORE KEYSTROKE
*
         LA    3,RSTACK-12                   LOAD STACK ADDRESS - 12
         LA    4,RTAB                        LOAD TABLE LO ADDRESS
         LA    5,RTABX-L'RENTRY              LOAD TABLE HI ADDRESS
         BAL   6,RSORT                       EXECUTE RECURSIVE SORT
*
         BAL   6,TRACE                       PRINT TRACE FILE
*
         LA    2,=C'AFTER SORT <enter>$'     LOAD FIELD ADDRESS
         SVC   @WTO                          ISSUE SUPERVISOR CALL
         SVC   @RDKEY                        ISSUE SUPERVISOR CALL
         STC   0,KEY                         STORE KEYSTROKE
         B     RETURN                        EXIT PROGRAM PLEASE
***********************************************************************
         EJECT
***********************************************************************
*        RECURSIVE SORT                      R3=STACK  R4=LO  R5=HI   *
***********************************************************************
         CNOP  0,4                           FULLWORD ALIGNMENT
RSORT    EQU   *
         LA    3,12(,3)                      INCREMENT STACK POINTER
         ST    6,0(3)                        SAVE RETURN ADDRESS
*
         CR    4,5                           LO ADDRESS >= HI ADDRESS
         BNL   RSORTX                        YES - EXIT RSORT
*
         LR    6,4                           LOAD FWD POINTER
         LA    7,L'RENTRY(,5)                LOAD BWD POINTER
         MVC   RKEY,0(4)                     LOAD SORT OBJECT
RFWD     EQU   *
         LA    6,L'RENTRY(,6)                INCREMENT FWD POINTER
         CR    6,7                           FWD/BWD BOUNDARY CROSS?
         BH    *+14                          YES - TRAVERSE BACKWARDS
         CLC   RKEY,0(6)                     KEY LESS THAN OBJECT?
         BNL   RFWD                          NO  - REPEAT FWD LOOP
RBWD     EQU   *
         SH    7,=Y(L'RENTRY)                DECREMENT BWD POINTER
         CR    6,7                           FWD/BWD BOUNDARY CROSS?
         BH    RDONE                         YES - MAKE PRIMARY SWAP
         CLC   RKEY,0(7)                     KEY MORE THAN OBJECT?
         BNH   RBWD                          NO  - REPEAT BWD LOOP
*
         XC    0(L'RENTRY,6),0(7)            ISOLATE UNIQUE BITS
         XC    0(L'RENTRY,7),0(6)            REPLACE LO WITH HI ENTRY
         XC    0(L'RENTRY,6),0(7)            REPLACE HI WITH LO ENTRY
         B     RFWD                          REPEAT FWD PROCEDURE
RDONE    EQU   *
         CLC   RKEY,0(7)                     KEY > BWD TRAVERSAL?
         BNH   *+22                          NO  - BYPASS FINAL SWAP
         XC    0(L'RENTRY,4),0(7)            ISOLATE UNIQUE BITS
         XC    0(L'RENTRY,7),0(4)            REPLACE LO WITH HI ENTRY
         XC    0(L'RENTRY,4),0(7)            REPLACE HI WITH LO ENTRY
*
         ST    5,8(3)                        STORE NXT HI IN STACK
         LR    5,7                           LOAD BWD POINTER ADDRESS
         SH    5,=Y(L'RENTRY)                DECREMENT BWD (NEW HI)
         LA    7,L'RENTRY(,7)                INCREMENT BWD (NXT LO)
         ST    7,4(3)                        STORE NXT LO IN STACK
         BAL   6,RSORT                       EXECUTE RECURSIVE SORT
         L     4,4(3)                        LOAD NXT LO ADDRESS
         L     5,8(3)                        LOAD NXT HI ADDRESS
         BAL   6,RSORT                       EXECUTE RECURSIVE SORT
RSORTX   EQU   *
         L     6,0(3)                        RESTORE LINK REGISTER
         SH    3,=H'12'                      DECREMENT STACK POINTER
         BR    6                             BRANCH ON LINK REGISTER
***********************************************************************
         EJECT
***********************************************************************
         DC    F'0'                          RETURN ADDRESS SAVE AREA
TRACE    EQU   *
         ST    6,*-4                         SAVE RETURN ADDRESS
*
         XFILO STDWKO                        OPEN OUTPUT FILE
*
         LA    6,RTAB                        LOAD TABLE ADDRESS
RESULTS  EQU   *
         C     6,=A(RTABX)                   END OF TABLE?
         BNL   RESULTX                       YES - EXIT LOOP PLEASE
         MVC   OPRT(L'RENTRY),0(6)           MOVE SORTED ENTRY
         XPRNT OREC,81                       WRITE OUTPUT RECORD
         LA    6,L'RENTRY(,6)                BUMP TABLE POINTER
         B     RESULTS                       TEST NEXT TABLE ENTRY
RESULTX  EQU   *
         L     6,TRACE-4                     RESTORE LINK REGISTER
         BR    6                             BRANCH ON LINK REGISTER
***********************************************************************
         EJECT
***********************************************************************
*        WORKING STORAGE                                              *
***********************************************************************
KEY      DC    CL1' '                        KEY STROKE (@RDKEY)
STDWKO   DC    CL64'C:\TEMP\TDSORTR.OUT'     OUTPUT FILE (RESULTS)
OREC     DS    0CL133                        OUTPUT RECORD
OCC      DC    CL1' '                        DUMMY CARRIAGE CONTROL
OPRT     DC    CL132' '                      PRINT LINE AREA
***********************************************************************
         LTORG                               LITERAL POOL
***********************************************************************
*        SUPERVISOR CALLS                                             *
***********************************************************************
@OPEN    EQU   1                             SUPERVISOR CALL ROUTINE
@CLOSE   EQU   2                             SUPERVISOR CALL ROUTINE
@GET     EQU   5                             SUPERVISOR CALL ROUTINE
@PUT     EQU   6                             SUPERVISOR CALL ROUTINE
@ASCEBC  EQU   12                            SUPERVISOR CALL ROUTINE
@EBCASC  EQU   13                            SUPERVISOR CALL ROUTINE
@RDKEY   EQU   201                           SUPERVISOR CALL ROUTINE
@WTO     EQU   209                           SUPERVISOR CALL ROUTINE
***********************************************************************
*        SAMPLE TABLE - STATE/AREACODE/DESCRIPTION                    *
***********************************************************************
         CNOP  0,4                           FULLWORD ALIGNMENT
RTAB     EQU   *
         DC    CL25'MD301MARYLAND'
         DC    CL25'NJ201NEW JERSEY'
         DC    CL25'DE302DELAWARE'
         DC    CL25'GA404GEORGIA'
         DC    CL25'GA706GEORGIA'
         DC    CL25'WA206WASHINGTON'
         DC    CL25'AK907ALASKA'
         DC    CL25'NY607NEW YORK'
         DC    CL25'NJ908NEW JERSEY'
         DC    CL25'NJ609NEW JERSEY'
         DC    CL25'WA509WASHINGTON'
         DC    CL25'MD410MARYLAND'
         DC    CL25'PA610PENNSYLVANIA'
         DC    CL25'GA912GEORGIA'
         DC    CL25'NY212NEW YORK'
         DC    CL25'PA412PENNSYLVANIA'
         DC    CL25'NY914NEW YORK'
         DC    CL25'PA814PENNSYLVANIA'
         DC    CL25'NY315NEW YORK'
         DC    CL25'PA215PENNSYLVANIA'
         DC    CL25'NY516NEW YORK'
         DC    CL25'NY716NEW YORK'
         DC    CL25'NY917NEW YORK'
         DC    CL25'NY917MANHATTEN'
         DC    CL25'PA717PENNSYLVANIA'
         DC    CL25'NY518NEW YORK'
         DC    CL25'NY718NEW YORK'
         DC    CL25'PA724PENNSYLVANIA'
         DC    CL25'NJ732NEW JERSEY'
         DC    CL25'MD240MARYLAND'
         DC    CL25'MD443MARYLAND'
         DC    CL25'WA360WASHINGTON'
         DC    CL25'GA770GEORGIA'
         DC    CL25'NJ973NEW JERSEY'
         DC    CL25'GA678GEORGIA'
RTABX    DC    C'$'
RKEY     DC    CL5' '                        SORT OBJECT KEY
***********************************************************************
*        RECURSION STACK - UP TO 1000 RECURSIVE CALLS SUPPORTED       *
***********************************************************************
         CNOP  0,4                           FULLWORD ALIGNMENT
RSTACK   EQU   *
         DS    1000XL12                      RECURSION STACK AREA
***********************************************************************
RDSECT   DSECT                               RTAB DSECT
RENTRY   DS    0CL25                         TABLE ENTRY
RSTATE   DS    CL2                           STATE
RAREA    DS    CL3                           AREA CODE
RDESC    DS    CL20                          DESCRIPTION
***********************************************************************
         END   TDSORTR

Feedback

I would appreciate any feedback you may have on this site. Send mail to tdelia@erols.com or click on the Octopus.

Technical difficulties?

Please report any technical difficulties you may encounter to the address above OR click on the Octopus. Thanks.

Tony DeLia - Updated April 28, 1999