LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ slasrt()

subroutine slasrt ( character id,
integer n,
real, dimension( * ) d,
integer info )

SLASRT sorts numbers in increasing or decreasing order.

Download SLASRT + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> Sort the numbers in D in increasing order (if ID = 'I') or
!> in decreasing order (if ID = 'D' ).
!>
!> Use Quick Sort, reverting to Insertion sort on arrays of
!> size <= 20. Dimension of STACK limits N to about 2**32.
!>
Parameters
[in]ID
!>          ID is CHARACTER*1
!>          = 'I': sort D in increasing order;
!>          = 'D': sort D in decreasing order.
!>
[in]N
!>          N is INTEGER
!>          The length of the array D.
!>
[in,out]D
!>          D is REAL array, dimension (N)
!>          On entry, the array to be sorted.
!>          On exit, D has been sorted into increasing order
!>          (D(1) <= ... <= D(N) ) or into decreasing order
!>          (D(1) >= ... >= D(N) ), depending on ID.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 85 of file slasrt.f.

86*
87* -- LAPACK computational routine --
88* -- LAPACK is a software package provided by Univ. of Tennessee, --
89* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
90*
91* .. Scalar Arguments ..
92 CHARACTER ID
93 INTEGER INFO, N
94* ..
95* .. Array Arguments ..
96 REAL D( * )
97* ..
98*
99* =====================================================================
100*
101* .. Parameters ..
102 INTEGER SELECT
103 parameter( SELECT = 20 )
104* ..
105* .. Local Scalars ..
106 INTEGER DIR, ENDD, I, J, START, STKPNT
107 REAL D1, D2, D3, DMNMX, TMP
108* ..
109* .. Local Arrays ..
110 INTEGER STACK( 2, 32 )
111* ..
112* .. External Functions ..
113 LOGICAL LSAME
114 EXTERNAL lsame
115* ..
116* .. External Subroutines ..
117 EXTERNAL xerbla
118* ..
119* .. Executable Statements ..
120*
121* Test the input parameters.
122*
123 info = 0
124 dir = -1
125 IF( lsame( id, 'D' ) ) THEN
126 dir = 0
127 ELSE IF( lsame( id, 'I' ) ) THEN
128 dir = 1
129 END IF
130 IF( dir.EQ.-1 ) THEN
131 info = -1
132 ELSE IF( n.LT.0 ) THEN
133 info = -2
134 END IF
135 IF( info.NE.0 ) THEN
136 CALL xerbla( 'SLASRT', -info )
137 RETURN
138 END IF
139*
140* Quick return if possible
141*
142 IF( n.LE.1 )
143 $ RETURN
144*
145 stkpnt = 1
146 stack( 1, 1 ) = 1
147 stack( 2, 1 ) = n
148 10 CONTINUE
149 start = stack( 1, stkpnt )
150 endd = stack( 2, stkpnt )
151 stkpnt = stkpnt - 1
152 IF( endd-start.LE.SELECT .AND. endd-start.GT.0 ) THEN
153*
154* Do Insertion sort on D( START:ENDD )
155*
156 IF( dir.EQ.0 ) THEN
157*
158* Sort into decreasing order
159*
160 DO 30 i = start + 1, endd
161 DO 20 j = i, start + 1, -1
162 IF( d( j ).GT.d( j-1 ) ) THEN
163 dmnmx = d( j )
164 d( j ) = d( j-1 )
165 d( j-1 ) = dmnmx
166 ELSE
167 GO TO 30
168 END IF
169 20 CONTINUE
170 30 CONTINUE
171*
172 ELSE
173*
174* Sort into increasing order
175*
176 DO 50 i = start + 1, endd
177 DO 40 j = i, start + 1, -1
178 IF( d( j ).LT.d( j-1 ) ) THEN
179 dmnmx = d( j )
180 d( j ) = d( j-1 )
181 d( j-1 ) = dmnmx
182 ELSE
183 GO TO 50
184 END IF
185 40 CONTINUE
186 50 CONTINUE
187*
188 END IF
189*
190 ELSE IF( endd-start.GT.SELECT ) THEN
191*
192* Partition D( START:ENDD ) and stack parts, largest one first
193*
194* Choose partition entry as median of 3
195*
196 d1 = d( start )
197 d2 = d( endd )
198 i = ( start+endd ) / 2
199 d3 = d( i )
200 IF( d1.LT.d2 ) THEN
201 IF( d3.LT.d1 ) THEN
202 dmnmx = d1
203 ELSE IF( d3.LT.d2 ) THEN
204 dmnmx = d3
205 ELSE
206 dmnmx = d2
207 END IF
208 ELSE
209 IF( d3.LT.d2 ) THEN
210 dmnmx = d2
211 ELSE IF( d3.LT.d1 ) THEN
212 dmnmx = d3
213 ELSE
214 dmnmx = d1
215 END IF
216 END IF
217*
218 IF( dir.EQ.0 ) THEN
219*
220* Sort into decreasing order
221*
222 i = start - 1
223 j = endd + 1
224 60 CONTINUE
225 70 CONTINUE
226 j = j - 1
227 IF( d( j ).LT.dmnmx )
228 $ GO TO 70
229 80 CONTINUE
230 i = i + 1
231 IF( d( i ).GT.dmnmx )
232 $ GO TO 80
233 IF( i.LT.j ) THEN
234 tmp = d( i )
235 d( i ) = d( j )
236 d( j ) = tmp
237 GO TO 60
238 END IF
239 IF( j-start.GT.endd-j-1 ) THEN
240 stkpnt = stkpnt + 1
241 stack( 1, stkpnt ) = start
242 stack( 2, stkpnt ) = j
243 stkpnt = stkpnt + 1
244 stack( 1, stkpnt ) = j + 1
245 stack( 2, stkpnt ) = endd
246 ELSE
247 stkpnt = stkpnt + 1
248 stack( 1, stkpnt ) = j + 1
249 stack( 2, stkpnt ) = endd
250 stkpnt = stkpnt + 1
251 stack( 1, stkpnt ) = start
252 stack( 2, stkpnt ) = j
253 END IF
254 ELSE
255*
256* Sort into increasing order
257*
258 i = start - 1
259 j = endd + 1
260 90 CONTINUE
261 100 CONTINUE
262 j = j - 1
263 IF( d( j ).GT.dmnmx )
264 $ GO TO 100
265 110 CONTINUE
266 i = i + 1
267 IF( d( i ).LT.dmnmx )
268 $ GO TO 110
269 IF( i.LT.j ) THEN
270 tmp = d( i )
271 d( i ) = d( j )
272 d( j ) = tmp
273 GO TO 90
274 END IF
275 IF( j-start.GT.endd-j-1 ) THEN
276 stkpnt = stkpnt + 1
277 stack( 1, stkpnt ) = start
278 stack( 2, stkpnt ) = j
279 stkpnt = stkpnt + 1
280 stack( 1, stkpnt ) = j + 1
281 stack( 2, stkpnt ) = endd
282 ELSE
283 stkpnt = stkpnt + 1
284 stack( 1, stkpnt ) = j + 1
285 stack( 2, stkpnt ) = endd
286 stkpnt = stkpnt + 1
287 stack( 1, stkpnt ) = start
288 stack( 2, stkpnt ) = j
289 END IF
290 END IF
291 END IF
292 IF( stkpnt.GT.0 )
293 $ GO TO 10
294 RETURN
295*
296* End of SLASRT
297*
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
Here is the call graph for this function:
Here is the caller graph for this function: