TG Murphy
Active User
Joined: 23 Mar 2007 Posts: 148 Location: Ottawa Canada
|
|
|
|
In previous threads we discussed ways to sort a COBOL table. I had mentioned that I planned on creating a pair of COBOL copybooks that would be generic in nature in that they could be used to sort any table using an efficient sort algorithm (heapsort).
I have finished a first cut of these copybooks. I have tested them and they appear to work. My guess is that some of you may be interested in trying the copybooks out and if so, I would appreciate it if you could test them out and report back any problems. Of course feel free to use once you are confident that they work well.
1. Working Storage copybook SORTWORK
Code: |
*-----------------------------------------------------------------
* Sort Utility : Working storage
*-----------------------------------------------------------------
01 SORT-SORT-UTILITY-GRP.
05 SORT-SORT-SEQUENCE PIC X(1).
88 SORT-ASCENDING VALUE "A".
88 SORT-DESCENDING VALUE "D".
05 SORT-OK PIC X.
05 SORT-IDX PIC S9(9) COMP.
05 SORT-IDX2 PIC S9(9) COMP.
05 SORT-GAP PIC S9(9) COMP.
05 SORT-NBR-OF-ELEMENTS PIC S9(9) COMP.
05 SORT-LOOP PIC S9(9) COMP.
05 SORT-TEMP PIC X(1000).
|
2. Procedure Division copybook SORTPROC
Code: |
*-----------------------------------------------------------------
* Sort a COBOL table - procedure division copybook
*
* This copybook provides a section that can be performed to sort
* a COBOL table. It is very efficient because it uses the
* heapsort algorithm. As a result it can be used in CICS.
*
* In order to use this copybook you must also copy in its
* working storage counterpart SORTWORK.
*
* Sample Table
*
* 05 WS-MONTH-TABLE.
* 10 WS-NBR-OF-ELEMENTS PIC S9(4) COMP VALUE +12.
* 10 WS-MONTH-TABLE-MAXSIZE PIC S9(4) COMP VALUE +12.
* 10 WS-MONTH-VALUES.
* 15 WS-JANUARY PIC X(12) VALUE '01January'.
* 15 WS-FEBRUARY PIC X(12) VALUE '02February'.
* 15 WS-MARCH PIC X(12) VALUE '03March'.
* 15 WS-APRIL PIC X(12) VALUE '04April'.
* 15 WS-MAY PIC X(12) VALUE '05May'.
* 15 WS-JUNE PIC X(12) VALUE '06June'.
* 15 WS-JULY PIC X(12) VALUE '07July'.
* 15 WS-AUGUST PIC X(12) VALUE '08August'.
* 15 WS-SEPTEMBER PIC X(12) VALUE '09September'.
* 15 WS-OCTOBER PIC X(12) VALUE '10October'.
* 15 WS-NOVEMBER PIC X(12) VALUE '11November'.
* 15 WS-DECEMBER PIC X(12) VALUE '12December'.
*
* 10 WS-MONTH-ENTRY REDEFINES WS-MONTH-VALUES
* OCCURS 12 TIMES.
* 15 WS-MONTH-NBR PIC 9(2).
* 15 WS-MONTH-NM PIC X(10).
*
* Example of how to copy SORTWORK into working storage.
*
* COPY SORTWORK.
*
* Example of how to copy SORTPROC into procedure division.
*
* COPY SORTPROC REPLACING
* ==:SUFFIX:== BY MYSORT
* ==:SORT-SEQUENCE:== BY SORT-ASCENDING
* ==:SORTROW:== BY WS-MONTH-ENTRY
* ==:SORTKEY:== BY WS-MONTH-NM
* ==:NBR-OF-ELEMENTS:== BY WS-NBR-OF-ELEMENTS.
*
* where SUFFIX is concatenated to the end of the section
* names used within the copybook to ensure unique
* section names.
*
* where SORT-SEQUENCE must be either SORT-ASCENDING
* or SORT-DESCENDING.
*
* where SORTROW specifies the COBOL group variable (within
* the table that you want sorted) that contains a
* a single table element.
*
* where SORTKEY specifies the sort key that gets compared.
*
* where NBR-OF-ELEMENTS specifies how many elements are in
* the table. This number cannot exceed the maximum
* size of the table but it can be less.
*
* How to perform the sort:
*
* PERFORM SORT-TABLE-MYSORT
*
* (Note that -MYSORT will differ depending on what you set
* the REPLACING parm SUFFIX to)
*
* Usage Notes
*
* 1. You may copy the procedure division copybook in as many
* times as necessary. Just make sure to specify unique
* values for the REPLACING parm SUFFIX. However, the working
* storage copybook should only ever be copied in once.
*
* 2. Your sortkey may specify either an elementary field or a
* group field. If elementary, then there are no restrictions
* as to what datatype the field can be. It can be alpha or
* PIC 9 or COMP or COMP-3.
*
* However, if sortkey is a group field, then remember that
* the comparison will be an alphanumeric comparison. As
* a result, make sure that none of your sort key sub-fields
* use packed decimal (COMP-3) or the sort will not work
* as you intend it to. There are workarounds for this.
*----------------------------------------------------------------
*
*----------------------------------------------------------------
SORT-TABLE-:SUFFIX: SECTION.
SET :SORT-SEQUENCE: TO TRUE
MOVE :NBR-OF-ELEMENTS: TO SORT-NBR-OF-ELEMENTS
*
* Gap divides the table into parts. The gap will get increasingly
* smaller as the table is sorted.
*
DIVIDE 2 INTO SORT-NBR-OF-ELEMENTS GIVING SORT-GAP.
*
* Perform the outer loop until the gap reaches zero.
*
PERFORM PASS-LOOP-:SUFFIX: UNTIL SORT-GAP = 0
.
PASS-LOOP-:SUFFIX: SECTION.
PERFORM PASS-TABLE-:SUFFIX:
VARYING SORT-LOOP FROM 1 BY 1
UNTIL SORT-LOOP =
SORT-NBR-OF-ELEMENTS - SORT-GAP + 1
DIVIDE 2 INTO SORT-GAP
.
PASS-TABLE-:SUFFIX: SECTION.
*
* Test items starting with ;SORT-LOOP.
* The distance between keys being compared is ;SORT-GAP.
* If when a set of keys are found out of order, the rows
* are swaped AND the index is reduced by 'gap'. This
* causes the compares to back up to see if the key just
* moved up, might need to be moved up again. Essentially,
* causing the row to 'bubble-up' quickly and optimizes
* for rows that are very much out of order.
*
MOVE SORT-LOOP TO SORT-IDX.
PERFORM COMPARISONS-:SUFFIX:
UNTIL SORT-IDX < 0 OR SORT-IDX = 0
.
COMPARISONS-:SUFFIX: SECTION.
ADD SORT-IDX SORT-GAP GIVING SORT-IDX2
PERFORM COMPARE-KEYS-:SUFFIX:
IF SORT-OK = "N"
PERFORM SWAP-ROWS-:SUFFIX:
SUBTRACT SORT-GAP FROM SORT-IDX
ELSE
MOVE 0 TO SORT-IDX
END-IF
.
COMPARE-KEYS-:SUFFIX: SECTION.
*
* Compare keys here.
* This routine returns ;SORT-OK = N if the comparison is true.
* This means that the keys being compared are out of order and
* must be switched.
*
MOVE "Y" TO SORT-OK
IF ( SORT-ASCENDING AND
:SORTKEY: (SORT-IDX) >
:SORTKEY: (SORT-IDX2) )
OR ( SORT-DESCENDING AND
:SORTKEY: (SORT-IDX) <
:SORTKEY: (SORT-IDX2) )
MOVE "N" TO SORT-OK
END-IF
.
SWAP-ROWS-:SUFFIX: SECTION.
MOVE :SORTROW: (SORT-IDX)
TO SORT-TEMP (1:LENGTH OF :SORTROW: (1))
MOVE :SORTROW: (SORT-IDX2) TO :SORTROW: (SORT-IDX)
MOVE SORT-TEMP (1: LENGTH OF :SORTROW: (1))
TO :SORTROW: (SORT-IDX2)
. |
|
|