| blob | 9befeffc082c6d88c1b1281db7b485c6d6b3690f |
1 SUBROUTINE DLASRT( ID, N, D, INFO )
2 !
3 ! -- LAPACK routine (version 3.1) --
4 ! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
5 ! November 2006
6 !
7 ! .. Scalar Arguments ..
8 CHARACTER ID
9 INTEGER INFO, N
10 ! ..
11 ! .. Array Arguments ..
12 DOUBLE PRECISION D( * )
13 ! ..
14 !
15 ! Purpose
16 ! =======
17 !
18 ! Sort the numbers in D in increasing order (if ID = 'I') or
19 ! in decreasing order (if ID = 'D' ).
20 !
21 ! Use Quick Sort, reverting to Insertion sort on arrays of
22 ! size <= 20. Dimension of STACK limits N to about 2**32.
23 !
24 ! Arguments
25 ! =========
26 !
27 ! ID (input) CHARACTER*1
28 ! = 'I': sort D in increasing order;
29 ! = 'D': sort D in decreasing order.
30 !
31 ! N (input) INTEGER
32 ! The length of the array D.
33 !
34 ! D (input/output) DOUBLE PRECISION array, dimension (N)
35 ! On entry, the array to be sorted.
36 ! On exit, D has been sorted into increasing order
37 ! (D(1) <= ... <= D(N) ) or into decreasing order
38 ! (D(1) >= ... >= D(N) ), depending on ID.
39 !
40 ! INFO (output) INTEGER
41 ! = 0: successful exit
42 ! < 0: if INFO = -i, the i-th argument had an illegal value
43 !
44 ! =====================================================================
45 !
46 ! .. Parameters ..
47 INTEGER SELECT
48 PARAMETER ( SELECT = 20 )
49 ! ..
50 ! .. Local Scalars ..
51 INTEGER DIR, ENDD, I, J, START, STKPNT
52 DOUBLE PRECISION D1, D2, D3, DMNMX, TMP
53 ! ..
54 ! .. Local Arrays ..
55 INTEGER STACK( 2, 32 )
56 ! ..
57 ! .. External Functions ..
58 ! LOGICAL LSAME
59 ! EXTERNAL LSAME
60 ! ..
61 ! .. External Subroutines ..
62 ! EXTERNAL XERBLA
63 ! ..
64 ! .. Executable Statements ..
65 !
66 ! Test the input paramters.
67 !
68 INFO = 0
69 DIR = -1
70 IF( LSAME( ID, 'D' ) ) THEN
71 DIR = 0
72 ELSE IF( LSAME( ID, 'I' ) ) THEN
73 DIR = 1
74 END IF
75 IF( DIR.EQ.-1 ) THEN
76 INFO = -1
77 ELSE IF( N.LT.0 ) THEN
78 INFO = -2
79 END IF
80 IF( INFO.NE.0 ) THEN
81 CALL XERBLA( 'DLASRT', -INFO )
82 RETURN
83 END IF
84 !
85 ! Quick return if possible
86 !
87 IF( N.LE.1 ) &
88 RETURN
89 !
90 STKPNT = 1
91 STACK( 1, 1 ) = 1
92 STACK( 2, 1 ) = N
93 10 CONTINUE
94 START = STACK( 1, STKPNT )
95 ENDD = STACK( 2, STKPNT )
96 STKPNT = STKPNT - 1
97 IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
98 !
99 ! Do Insertion sort on D( START:ENDD )
100 !
101 IF( DIR.EQ.0 ) THEN
102 !
103 ! Sort into decreasing order
104 !
105 DO 30 I = START + 1, ENDD
106 DO 20 J = I, START + 1, -1
107 IF( D( J ).GT.D( J-1 ) ) THEN
108 DMNMX = D( J )
109 D( J ) = D( J-1 )
110 D( J-1 ) = DMNMX
111 ELSE
112 GO TO 30
113 END IF
114 20 CONTINUE
115 30 CONTINUE
116 !
117 ELSE
118 !
119 ! Sort into increasing order
120 !
121 DO 50 I = START + 1, ENDD
122 DO 40 J = I, START + 1, -1
123 IF( D( J ).LT.D( J-1 ) ) THEN
124 DMNMX = D( J )
125 D( J ) = D( J-1 )
126 D( J-1 ) = DMNMX
127 ELSE
128 GO TO 50
129 END IF
130 40 CONTINUE
131 50 CONTINUE
132 !
133 END IF
134 !
135 ELSE IF( ENDD-START.GT.SELECT ) THEN
136 !
137 ! Partition D( START:ENDD ) and stack parts, largest one first
138 !
139 ! Choose partition entry as median of 3
140 !
141 D1 = D( START )
142 D2 = D( ENDD )
143 I = ( START+ENDD ) / 2
144 D3 = D( I )
145 IF( D1.LT.D2 ) THEN
146 IF( D3.LT.D1 ) THEN
147 DMNMX = D1
148 ELSE IF( D3.LT.D2 ) THEN
149 DMNMX = D3
150 ELSE
151 DMNMX = D2
152 END IF
153 ELSE
154 IF( D3.LT.D2 ) THEN
155 DMNMX = D2
156 ELSE IF( D3.LT.D1 ) THEN
157 DMNMX = D3
158 ELSE
159 DMNMX = D1
160 END IF
161 END IF
162 !
163 IF( DIR.EQ.0 ) THEN
164 !
165 ! Sort into decreasing order
166 !
167 I = START - 1
168 J = ENDD + 1
169 60 CONTINUE
170 70 CONTINUE
171 J = J - 1
172 IF( D( J ).LT.DMNMX ) &
173 GO TO 70
174 80 CONTINUE
175 I = I + 1
176 IF( D( I ).GT.DMNMX ) &
177 GO TO 80
178 IF( I.LT.J ) THEN
179 TMP = D( I )
180 D( I ) = D( J )
181 D( J ) = TMP
182 GO TO 60
183 END IF
184 IF( J-START.GT.ENDD-J-1 ) THEN
185 STKPNT = STKPNT + 1
186 STACK( 1, STKPNT ) = START
187 STACK( 2, STKPNT ) = J
188 STKPNT = STKPNT + 1
189 STACK( 1, STKPNT ) = J + 1
190 STACK( 2, STKPNT ) = ENDD
191 ELSE
192 STKPNT = STKPNT + 1
193 STACK( 1, STKPNT ) = J + 1
194 STACK( 2, STKPNT ) = ENDD
195 STKPNT = STKPNT + 1
196 STACK( 1, STKPNT ) = START
197 STACK( 2, STKPNT ) = J
198 END IF
199 ELSE
200 !
201 ! Sort into increasing order
202 !
203 I = START - 1
204 J = ENDD + 1
205 90 CONTINUE
206 100 CONTINUE
207 J = J - 1
208 IF( D( J ).GT.DMNMX ) &
209 GO TO 100
210 110 CONTINUE
211 I = I + 1
212 IF( D( I ).LT.DMNMX ) &
213 GO TO 110
214 IF( I.LT.J ) THEN
215 TMP = D( I )
216 D( I ) = D( J )
217 D( J ) = TMP
218 GO TO 90
219 END IF
220 IF( J-START.GT.ENDD-J-1 ) THEN
221 STKPNT = STKPNT + 1
222 STACK( 1, STKPNT ) = START
223 STACK( 2, STKPNT ) = J
224 STKPNT = STKPNT + 1
225 STACK( 1, STKPNT ) = J + 1
226 STACK( 2, STKPNT ) = ENDD
227 ELSE
228 STKPNT = STKPNT + 1
229 STACK( 1, STKPNT ) = J + 1
230 STACK( 2, STKPNT ) = ENDD
231 STKPNT = STKPNT + 1
232 STACK( 1, STKPNT ) = START
233 STACK( 2, STKPNT ) = J
234 END IF
235 END IF
236 END IF
237 IF( STKPNT.GT.0 ) &
238 GO TO 10
239 RETURN
240 !
241 ! End of DLASRT
242 !
243 END SUBROUTINE DLASRT