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

◆ dlasrt()

subroutine dlasrt ( character  id,
integer  n,
double precision, dimension( * )  d,
integer  info 
)

DLASRT sorts numbers in increasing or decreasing order.

Download DLASRT + 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 DOUBLE PRECISION 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 87 of file dlasrt.f.

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