ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
slasrt2.f
Go to the documentation of this file.
1 *
2 *
3  SUBROUTINE slasrt2( ID, N, D, KEY, INFO )
4 *
5 * -- ScaLAPACK routine (version 1.7) --
6 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
7 * and University of California, Berkeley.
8 * May 1, 1997
9 *
10 * .. Scalar Arguments ..
11  CHARACTER ID
12  INTEGER INFO, N
13 * ..
14 * .. Array Arguments ..
15  INTEGER KEY( * )
16  REAL D( * )
17 * ..
18 *
19 * Purpose
20 * =======
21 *
22 * Sort the numbers in D in increasing order (if ID = 'I') or
23 * in decreasing order (if ID = 'D' ).
24 *
25 * Use Quick Sort, reverting to Insertion sort on arrays of
26 * size <= 20. Dimension of STACK limits N to about 2**32.
27 *
28 * Arguments
29 * =========
30 *
31 * ID (input) CHARACTER*1
32 * = 'I': sort D in increasing order;
33 * = 'D': sort D in decreasing order.
34 *
35 * N (input) INTEGER
36 * The length of the array D.
37 *
38 * D (input/output) REAL array, dimension (N)
39 * On entry, the array to be sorted.
40 * On exit, D has been sorted into increasing order
41 * (D(1) <= ... <= D(N) ) or into decreasing order
42 * (D(1) >= ... >= D(N) ), depending on ID.
43 *
44 * KEY (input/output) INTEGER array, dimension (N)
45 * On entry, KEY contains a key to each of the entries in D()
46 * Typically, KEY(I) = I for all I
47 * On exit, KEY is permuted in exactly the same manner as
48 * D() was permuted from input to output
49 * Therefore, if KEY(I) = I for all I upon input, then
50 * D_out(I) = D_in(KEY(I))
51 *
52 * INFO (output) INTEGER
53 * = 0: successful exit
54 * < 0: if INFO = -i, the i-th argument had an illegal value
55 *
56 * =====================================================================
57 *
58 * .. Parameters ..
59  INTEGER SELECT
60  parameter( SELECT = 20 )
61 * ..
62 * .. Local Scalars ..
63  INTEGER DIR, ENDD, I, J, START, STKPNT, TMPKEY
64  REAL D1, D2, D3, DMNMX, TMP
65 * ..
66 * .. Local Arrays ..
67  INTEGER STACK( 2, 32 )
68 * ..
69 * .. External Functions ..
70  LOGICAL LSAME
71  EXTERNAL lsame
72 * ..
73 * .. External Subroutines ..
74  EXTERNAL xerbla
75 * ..
76 * .. Executable Statements ..
77 *
78 * Test the input paramters.
79 *
80 *
81  info = 0
82  dir = -1
83  IF( lsame( id, 'D' ) ) THEN
84  dir = 0
85  ELSE IF( lsame( id, 'I' ) ) THEN
86  dir = 1
87  END IF
88  IF( dir.EQ.-1 ) THEN
89  info = -1
90  ELSE IF( n.LT.0 ) THEN
91  info = -2
92  END IF
93  IF( info.NE.0 ) THEN
94  CALL xerbla( 'SLASRT2', -info )
95  RETURN
96  END IF
97 *
98 * Quick return if possible
99 *
100  IF( n.LE.1 )
101  $ RETURN
102 *
103  stkpnt = 1
104  stack( 1, 1 ) = 1
105  stack( 2, 1 ) = n
106  10 CONTINUE
107  start = stack( 1, stkpnt )
108  endd = stack( 2, stkpnt )
109  stkpnt = stkpnt - 1
110  IF( endd-start.GT.0 ) THEN
111 *
112 * Do Insertion sort on D( START:ENDD )
113 *
114  IF( dir.EQ.0 ) THEN
115 *
116 * Sort into decreasing order
117 *
118  DO 30 i = start + 1, endd
119  DO 20 j = i, start + 1, -1
120  IF( d( j ).GT.d( j-1 ) ) THEN
121  dmnmx = d( j )
122  d( j ) = d( j-1 )
123  d( j-1 ) = dmnmx
124  tmpkey = key( j )
125  key( j ) = key( j-1 )
126  key( j-1 ) = tmpkey
127  ELSE
128  GO TO 30
129  END IF
130  20 CONTINUE
131  30 CONTINUE
132 *
133  ELSE
134 *
135 * Sort into increasing order
136 *
137  DO 50 i = start + 1, endd
138  DO 40 j = i, start + 1, -1
139  IF( d( j ).LT.d( j-1 ) ) THEN
140  dmnmx = d( j )
141  d( j ) = d( j-1 )
142  d( j-1 ) = dmnmx
143  tmpkey = key( j )
144  key( j ) = key( j-1 )
145  key( j-1 ) = tmpkey
146  ELSE
147  GO TO 50
148  END IF
149  40 CONTINUE
150  50 CONTINUE
151 *
152  END IF
153 *
154  ELSE IF( endd-start.GT.SELECT ) THEN
155 *
156 * Partition D( START:ENDD ) and stack parts, largest one first
157 *
158 * Choose partition entry as median of 3
159 *
160  d1 = d( start )
161  d2 = d( endd )
162  i = ( start+endd ) / 2
163  d3 = d( i )
164  IF( d1.LT.d2 ) THEN
165  IF( d3.LT.d1 ) THEN
166  dmnmx = d1
167  ELSE IF( d3.LT.d2 ) THEN
168  dmnmx = d3
169  ELSE
170  dmnmx = d2
171  END IF
172  ELSE
173  IF( d3.LT.d2 ) THEN
174  dmnmx = d2
175  ELSE IF( d3.LT.d1 ) THEN
176  dmnmx = d3
177  ELSE
178  dmnmx = d1
179  END IF
180  END IF
181 *
182  IF( dir.EQ.0 ) THEN
183 *
184 * Sort into decreasing order
185 *
186  i = start - 1
187  j = endd + 1
188  60 CONTINUE
189  70 CONTINUE
190  j = j - 1
191  IF( d( j ).LT.dmnmx )
192  $ GO TO 70
193  80 CONTINUE
194  i = i + 1
195  IF( d( i ).GT.dmnmx )
196  $ GO TO 80
197  IF( i.LT.j ) THEN
198  tmp = d( i )
199  d( i ) = d( j )
200  d( j ) = tmp
201  tmpkey = key( j )
202  key( j ) = key( i )
203  key( i ) = tmpkey
204  GO TO 60
205  END IF
206  IF( j-start.GT.endd-j-1 ) THEN
207  stkpnt = stkpnt + 1
208  stack( 1, stkpnt ) = start
209  stack( 2, stkpnt ) = j
210  stkpnt = stkpnt + 1
211  stack( 1, stkpnt ) = j + 1
212  stack( 2, stkpnt ) = endd
213  ELSE
214  stkpnt = stkpnt + 1
215  stack( 1, stkpnt ) = j + 1
216  stack( 2, stkpnt ) = endd
217  stkpnt = stkpnt + 1
218  stack( 1, stkpnt ) = start
219  stack( 2, stkpnt ) = j
220  END IF
221  ELSE
222 *
223 * Sort into increasing order
224 *
225  i = start - 1
226  j = endd + 1
227  90 CONTINUE
228  100 CONTINUE
229  j = j - 1
230  IF( d( j ).GT.dmnmx )
231  $ GO TO 100
232  110 CONTINUE
233  i = i + 1
234  IF( d( i ).LT.dmnmx )
235  $ GO TO 110
236  IF( i.LT.j ) THEN
237  tmp = d( i )
238  d( i ) = d( j )
239  d( j ) = tmp
240  tmpkey = key( j )
241  key( j ) = key( i )
242  key( i ) = tmpkey
243  GO TO 90
244  END IF
245  IF( j-start.GT.endd-j-1 ) THEN
246  stkpnt = stkpnt + 1
247  stack( 1, stkpnt ) = start
248  stack( 2, stkpnt ) = j
249  stkpnt = stkpnt + 1
250  stack( 1, stkpnt ) = j + 1
251  stack( 2, stkpnt ) = endd
252  ELSE
253  stkpnt = stkpnt + 1
254  stack( 1, stkpnt ) = j + 1
255  stack( 2, stkpnt ) = endd
256  stkpnt = stkpnt + 1
257  stack( 1, stkpnt ) = start
258  stack( 2, stkpnt ) = j
259  END IF
260  END IF
261  END IF
262  IF( stkpnt.GT.0 )
263  $ GO TO 10
264 *
265 *
266  RETURN
267 *
268 * End of SLASRT2
269 *
270  END
slasrt2
subroutine slasrt2(ID, N, D, KEY, INFO)
Definition: slasrt2.f:4