SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
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