CTITLEUSSORT -- SORT MULTIPLE WORD ELEMENTS 00010000 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR G. WHIPPLE 00020000 CA DESIGNER G. WHIPPLE 00030000 CA LANGUAGE FORTRAN 00040000 CA SYSTEM IBM (SEE CRAY) 00050000 CA WRITTEN 06-26-77 00060000 C REVISED 01-17-85 BY ESN. FOR CRAY COMPATABILITY. 00070000 C REVISED 07-06-90 BY JDB/ESN. CALL USSHELL. 00080000 C REVISED 10-09-91 REM. CALL FRESP1 BEFORE XDUMPX IF GETMN2 00090001 C FAILS 00100001 C REVISED 10-21-91 BY ESN. Add in call to USDMERG. 00110001 CA 00120000 CA 00130000 CA CALL USSORT (NEL, NWPE, KEY, ARRAY, UPDOWN) 00140000 CA 00150000 CA IN/OUT ARGUMENT TYPE DESCRIPTION 00160000 CA 00170000 CA IN NEL I4 NUMBER OF ELEMENTS TO SORT. 00180000 CA IN NWPE I4 NUMBER OF WORDS PER ELEMENT. 00190000 CA IN KEY I4 WORD WITHIN ELEMENTS TO SORT ON - 00200000 CA 1 INDICATES FIRST WORD. 00210000 CA IN ARRAY I4 ARRAY OF INPUT ELEMENTS TO SORT. 00220000 CA IN UPDOWN A4 'DOWN' IF ELEMENTS ARE TO BE SORTED 00230000 CA INTO DECREASING ORDER; ANY OTHER 00240000 CA 4-BYTE VARIABLE IF ELEMENTS ARE TO 00250000 CA BE SORTED INTO INCREASING ORDER. 00260000 CA 00270000 CA 00280000 CA THIS SUBROUTINE SORTS MULTIPLE-WORD ELEMENTS INTO ASCENDING 00290000 CA OR DESCENDING ORDER. CALLS A SHELL SORT ROUTINE. 00300000 CAEND 00310000 C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00320000 C* This is a complete rewrite of the old USSORT. All of the 00330000 C* specifications are identical. 00340000 C* 00350000 C* This module builds an array of double-precision values in XCOM. 00360000 C* The first word of each element is the value of the KEY word from an 00370000 C* element in ARRAY (ARRAY is to be sorted by KEY). The second word 00380000 C* of each element is an index representing the original element # 00390000 C* of KEY in ARRAY. We found it necessary to include the original 00400000 C* index because in sorting seismic traces, some of the original order 00410000 C* does need to be preserved. In the example below, the recordsare 00420000 C* sorted by trace. Notice that the results from a bubble sort and 00430000 C* a shell sort are different (denoted with a '.' over the numbers). 00440000 C* 00450000 C* ARRAY: ShotPt 1 1 1 1 2 2 2 2 3 3 3 3 00460000 C* Trace 1 2 3 4 1 2 3 4 1 2 3 4 00470000 C* . . . . . . 00480000 C* Bubble- ShotPt 1 2 3 1 2 3 1 2 3 1 2 3 00490000 C* Sorted Trace 1 1 1 2 2 2 3 3 3 4 4 4 00500000 C* . . . . . . 00510000 C* Shell- ShotPt 1 2 3 3 1 2 2 3 1 1 2 3 00520000 C* Sorted Trace 1 1 1 2 2 2 3 3 3 4 4 4 00530000 C* 00540000 C* While both results are indeed in order by trace number, what we 00550000 C* really need is the result put out by the bubble sort. If the 00560000 C* shell-sorted array were to later be sorted by some other key 00570000 C* (i.e. not shotpoint or trace), the data will most likely be 00580000 C* so jumbled up that the seismic display will look like a bunch 00590000 C* of static. Because the elements of the double-precision array 00600000 C* (built by this module) are unique, other fields sharing the 00610000 C* key-field value will not be mixed up as they were above. 00620000 C* 00630000 C* USSHELL is then called to sort the values in COM. Finally, 00640000 C* ARRAY is rearranged according to the indeces (2nd words) in COM 00650000 C* so that ARRAY is returned in sorted order. 00660000 C* Belive it or not, all of this runs orders of magnitude faster 00670000 C* than a simple routine using a bubble sort. 00680000 C* - JDB 00690000 C* LOCAL 00700000 C* VARIABLE TYPE DESCRIPTION 00710000 C* 00720000 C* XCOM R4 Common storage to hold the double-precision 00730000 C* array values. 00740000 C* ILEN, I4 00750000 C* OLEN, IPTR 00760000 C* MinKey I4 Minimum value of the key elements in ARRAY. 00770000 C* Indx I4 Index for an element in ARRAY. 00780000 C* Elem I4 Loop variable representing element index. 00790000 C* 00800000 C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00810000 C 00820001 SUBROUTINE USSORT (NEL, NWPE, KEY, ARRAY, UPDOWN) 00830000 C 00840000 C* I don't like IMPLICITs, but somebody wants it here! * 00850000 IMPLICIT INTEGER (A-Z) 00860000 C...TRANSLATED BY FPP 2.26B16 10/09/91 15:37:45 00870003 C...SWITCHES: OPTOFF=CVY,TDYON=TDYON=RENUMB=100:10,FORMAT=9000:10,INDA 00880003 C...SWITCHES: AL=2,CONCHR=+,TDYON=BFJORSTV,TDYOFF=MY 00890003 C************************************************************** 00900003 C * 00910003 C SUBROUTINES AND FUNCTIONS CALLED FROM THIS ROUTINE * 00920003 C * 00930003 C GETMN2 FRESP1 XDUMPX USSHELL ARMVE FREMN2 * 00940003 C * 00950003 C************************************************************** 00960003 INTEGER NEL, NWPE, KEY 00970000 CHARACTER*4 UPDOWN 00980000 INTEGER ARRAY (1) 00990000 C 01000000 INTEGER ILEN, OLEN, IPTR, MINKEY, INDX, ELEM 01010000 COMMON COM (1) 01020000 REAL XCOM (1) 01030000 EQUIVALENCE (COM(1), XCOM(1)) 01040000 IF (NEL .GT. 1) THEN 01050005 C 01060000 C** Allocate memory ** 01070000 ILEN = NEL * (NWPE + 2 ) 01080003 IF (ILEN .LT. NEL*4) ILEN = NEL*4 01090001 CALL GETMN2 ( COM, ILEN, IPTR, OLEN ) 01100003 IF (ILEN .GT. OLEN) THEN 01110001 WRITE ( 6, 9000 ) 01120001 CALL FRESP1 01130001 CALL XDUMPX (ILEN, OLEN) 01140001 ENDIF 01150001 C 01160000 C** Find minimum value of KEYs in ARRAY ** 01170000 MINKEY = 1 01180001 DO 100 ELEM = 1, NEL 01190001 MINKEY = MIN0 ( ARRAY(NWPE * (ELEM - 1 ) + KEY), MINKEY ) 01200003 100 CONTINUE 01210001 MINKEY = 1 - MINKEY 01220001 C 01230001 C* MINKEY = 0 if all of the key values are positive. 01240000 C* If the minimum key value is negative, say, -25, then MINKEY will 01250000 C* be 26. When the array is built (in the next step), MINKEY is 01260000 C* added to each of the KEY values for storage in the first word of 01270000 C* the double-precision element. This ensures that each of those 01280000 C* values is positive, so that when combined with the index #s, they 01290000 C* will be sorted correctly. Since the double-precision array is 01300000 C* needed only to order the indeces (not to order the actual ARRAY), 01310000 C* the actual value of the 1st words is irrelevant - as long as they 01320000 C* have the same relative values as did the original KEYs. 01330000 C 01340000 C* Build double-precision array: 1st word = key value * 01350000 C* 2nd word = index * * * 01360000 C ** First word (for each element): ** 01370000 C 01380001 DO 110 ELEM = 1, NEL 01390001 XCOM(IPTR + 2 * ELEM - 1) = ARRAY(NWPE * (ELEM - 1 ) + KEY) 01400001 + + MINKEY 01410002 110 CONTINUE 01420001 C ** Second word : ** 01430000 C ** To preserve the order as described above, indices must ** 01440003 C ** go in different directions for UP sorts & DOWN sorts. ** 01450000 IF (UPDOWN .EQ. 'DOWN') THEN 01460002 DO 120 ELEM = 1, NEL 01470002 COM(IPTR + 2 * ELEM) = NEL + 1 - ELEM 01480003 120 CONTINUE 01490002 ELSE 01500000 DO 130 ELEM = 1, NEL 01510002 COM(IPTR + 2 * ELEM) = ELEM 01520003 130 CONTINUE 01530002 ENDIF 01540000 C 01550000 C** Sort double-precision array: ** 01560000 CESN CALL USSHELL (NEL, COM(IPTR+1)) 01570007 C** Sort and merge double-precision array: ** 01580006 NSORTS = 1 01590002 IF (NEL .GE. 1000000) NSORTS = 4 01600002 IF (NEL .GE. 5000000) NSORTS = 16 01610002 NELPER = NEL / NSORTS 01620002 NELAST = NEL - NELPER*(NSORTS-1) 01630002 DO 1100 I = 1, NSORTS 01640002 NUMEL = NELPER 01650000 IF (I .EQ. NSORTS) NUMEL = NELAST 01660000 C WRITE (6,9009) (COM(IPTR+1+2*(I-1)*NELPER+J-1),J=1,NUMEL*2) 01670000 CALL USSHELL (NUMEL, COM(IPTR+1+2*(I-1)*NELPER)) 01680000 C WRITE (6,9009) (COM(IPTR+1+2*(I-1)*NELPER+J-1),J=1,NUMEL*2) 01690000 1100 CONTINUE 01700002 IF (NSORTS .GT. 1) THEN 01710002 INMSTR = IPTR + 1 01720000 OTMSTR = IPTR + 1 + 2*NEL 01730000 NMERGE = NSORTS / 2 01740000 LMERGE = NELPER 01750000 1200 CONTINUE 01760000 INMERG = INMSTR 01770000 OTMERG = OTMSTR 01780000 DO 1300 I = 1, NMERGE 01790000 LMERG2 = LMERGE 01800002 IF (I .EQ. NMERGE) LMERG2 = NEL - LMERGE*(2*NMERGE-1) 01810002 CALL USDMERG (COM(INMERG), LMERGE, COM(INMERG+2*LMERGE), 01820002 + LMERG2, COM(OTMERG)) 01830002 INMERG = INMERG + 2*LMERGE*2 01840002 OTMERG = OTMERG + 2*LMERGE*2 01850002 1300 CONTINUE 01860000 IF (NMERGE .GT. 1) THEN 01870000 ITEMP = INMSTR 01880002 INMSTR = OTMSTR 01890002 OTMSTR = ITEMP 01900002 NMERGE = NMERGE / 2 01910002 LMERGE = 2 * LMERGE 01920002 GO TO 1200 01930002 ELSE 01940000 IF (OTMSTR .NE. IPTR+1) THEN 01950002 CALL ARMVE (COM(IPTR+1+2*NEL), COM(IPTR+1), 2*NEL) 01960002 ENDIF 01970002 ENDIF 01980000 ENDIF 01990002 C WRITE (6,9009) (COM(IPTR+I),I=1,2*NEL) 02000002 C9009 FORMAT (5x,10z10) 02010002 C 02020000 C* Elements in COM are now sorted by KEY and INDEX. * 02030000 C* Use the sorted indeces to rewrite ARRAY in sorted order. * 02040000 C 02050000 IF (UPDOWN .EQ. 'DOWN') THEN 02060002 DO 140 ELEM = 1, NEL 02070003 INDX = NEL + 1 - COM(IPTR + 2 * ELEM) 02080004 CALL ARMVE ( ARRAY(NWPE * (INDX - 1 ) + 1), COM(IPTR + 2 * 02090005 + NEL + 1 + NWPE * (NEL - ELEM ) ), NWPE ) 02100004 140 CONTINUE 02110003 ELSE 02120000 DO 150 ELEM = 1, NEL 02130003 INDX = COM(IPTR + 2 * ELEM) 02140004 CALL ARMVE ( ARRAY(NWPE * (INDX - 1 ) + 1), COM(IPTR + 2 * 02150004 + NEL + 1 + NWPE * (ELEM - 1 ) ), NWPE ) 02160004 150 CONTINUE 02170003 ENDIF 02180000 CALL ARMVE ( COM(IPTR + 2 * NEL + 1), ARRAY, NWPE * NEL ) 02190003 C 02200000 C** Free memory: ** 02210000 CALL FREMN2 ( COM(IPTR + 1), OLEN ) 02220003 C 02230003 ENDIF 02240002 RETURN 02250002 C 02260002 9000 FORMAT ('0*** GETMN2 FAILED TO ACQUIRE ENOUGH CORE.'/ 02270002 + ' *** PROGRAM TERMINATED.') 02280002 END 02290000