LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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.
Date
June 2016

Definition at line 90 of file slasrt.f.

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