SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ slapst()

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

Definition at line 1 of file slapst.f.

2*
3* -- ScaLAPACK auxiliary routine (version 1.7) --
4* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5* and University of California, Berkeley.
6* December 31, 1998
7*
8* .. Scalar Arguments ..
9 CHARACTER ID
10 INTEGER INFO, N
11* ..
12* .. Array Arguments ..
13 INTEGER INDX( * )
14 REAL D( * )
15* ..
16*
17* Purpose
18* =======
19* SLAPST is a modified version of the LAPACK routine SLASRT.
20*
21* Define a permutation INDX that sorts the numbers in D
22* 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) REAL array, dimension (N)
39* The array to be sorted.
40*
41* INDX (ouput) INTEGER array, dimension (N).
42* The permutation which sorts the array D.
43*
44* INFO (output) INTEGER
45* = 0: successful exit
46* < 0: if INFO = -i, the i-th argument had an illegal value
47*
48* =====================================================================
49*
50* .. Parameters ..
51 INTEGER SELECT
52 parameter( SELECT = 20 )
53* ..
54* .. Local Scalars ..
55 INTEGER DIR, ENDD, I, ITMP, J, START, STKPNT
56 REAL D1, D2, D3, DMNMX
57* ..
58* .. Local Arrays ..
59 INTEGER STACK( 2, 32 )
60* ..
61* .. External Functions ..
62 LOGICAL LSAME
63 EXTERNAL lsame
64* ..
65* .. External Subroutines ..
66 EXTERNAL xerbla
67* ..
68* .. Executable Statements ..
69*
70* Test the input paramters.
71*
72 info = 0
73 dir = -1
74 IF( lsame( id, 'D' ) ) THEN
75 dir = 0
76 ELSE IF( lsame( id, 'I' ) ) THEN
77 dir = 1
78 END IF
79 IF( dir.EQ.-1 ) THEN
80 info = -1
81 ELSE IF( n.LT.0 ) THEN
82 info = -2
83 END IF
84 IF( info.NE.0 ) THEN
85 CALL xerbla( 'SLAPST', -info )
86 RETURN
87 END IF
88*
89* Quick return if possible
90*
91 IF( n.LE.1 )
92 $ RETURN
93*
94 DO 10 i = 1, n
95 indx( i ) = i
96 10 CONTINUE
97*
98 stkpnt = 1
99 stack( 1, 1 ) = 1
100 stack( 2, 1 ) = n
101 20 CONTINUE
102 start = stack( 1, stkpnt )
103 endd = stack( 2, stkpnt )
104 stkpnt = stkpnt - 1
105 IF( endd-start.LE.SELECT .AND. endd-start.GT.0 ) THEN
106*
107* Do Insertion sort on D( START:ENDD )
108*
109 IF( dir.EQ.0 ) THEN
110*
111* Sort into decreasing order
112*
113 DO 40 i = start + 1, endd
114 DO 30 j = i, start + 1, -1
115 IF( d( indx( j ) ).GT.d( indx( j-1 ) ) ) THEN
116 itmp = indx( j )
117 indx( j ) = indx( j-1 )
118 indx( j-1 ) = itmp
119 ELSE
120 GO TO 40
121 END IF
122 30 CONTINUE
123 40 CONTINUE
124*
125 ELSE
126*
127* Sort into increasing order
128*
129 DO 60 i = start + 1, endd
130 DO 50 j = i, start + 1, -1
131 IF( d( indx( j ) ).LT.d( indx( j-1 ) ) ) THEN
132 itmp = indx( j )
133 indx( j ) = indx( j-1 )
134 indx( j-1 ) = itmp
135 ELSE
136 GO TO 60
137 END IF
138 50 CONTINUE
139 60 CONTINUE
140*
141 END IF
142*
143 ELSE IF( endd-start.GT.SELECT ) THEN
144*
145* Partition D( START:ENDD ) and stack parts, largest one first
146*
147* Choose partition entry as median of 3
148*
149 d1 = d( indx( start ) )
150 d2 = d( indx( endd ) )
151 i = ( start+endd ) / 2
152 d3 = d( indx( i ) )
153 IF( d1.LT.d2 ) THEN
154 IF( d3.LT.d1 ) THEN
155 dmnmx = d1
156 ELSE IF( d3.LT.d2 ) THEN
157 dmnmx = d3
158 ELSE
159 dmnmx = d2
160 END IF
161 ELSE
162 IF( d3.LT.d2 ) THEN
163 dmnmx = d2
164 ELSE IF( d3.LT.d1 ) THEN
165 dmnmx = d3
166 ELSE
167 dmnmx = d1
168 END IF
169 END IF
170*
171 IF( dir.EQ.0 ) THEN
172*
173* Sort into decreasing order
174*
175 i = start - 1
176 j = endd + 1
177 70 CONTINUE
178 80 CONTINUE
179 j = j - 1
180 IF( d( indx( j ) ).LT.dmnmx )
181 $ GO TO 80
182 90 CONTINUE
183 i = i + 1
184 IF( d( indx( i ) ).GT.dmnmx )
185 $ GO TO 90
186 IF( i.LT.j ) THEN
187 itmp = indx( i )
188 indx( i ) = indx( j )
189 indx( j ) = itmp
190 GO TO 70
191 END IF
192 IF( j-start.GT.endd-j-1 ) THEN
193 stkpnt = stkpnt + 1
194 stack( 1, stkpnt ) = start
195 stack( 2, stkpnt ) = j
196 stkpnt = stkpnt + 1
197 stack( 1, stkpnt ) = j + 1
198 stack( 2, stkpnt ) = endd
199 ELSE
200 stkpnt = stkpnt + 1
201 stack( 1, stkpnt ) = j + 1
202 stack( 2, stkpnt ) = endd
203 stkpnt = stkpnt + 1
204 stack( 1, stkpnt ) = start
205 stack( 2, stkpnt ) = j
206 END IF
207 ELSE
208*
209* Sort into increasing order
210*
211 i = start - 1
212 j = endd + 1
213 100 CONTINUE
214 110 CONTINUE
215 j = j - 1
216 IF( d( indx( j ) ).GT.dmnmx )
217 $ GO TO 110
218 120 CONTINUE
219 i = i + 1
220 IF( d( indx( i ) ).LT.dmnmx )
221 $ GO TO 120
222 IF( i.LT.j ) THEN
223 itmp = indx( i )
224 indx( i ) = indx( j )
225 indx( j ) = itmp
226 GO TO 100
227 END IF
228 IF( j-start.GT.endd-j-1 ) THEN
229 stkpnt = stkpnt + 1
230 stack( 1, stkpnt ) = start
231 stack( 2, stkpnt ) = j
232 stkpnt = stkpnt + 1
233 stack( 1, stkpnt ) = j + 1
234 stack( 2, stkpnt ) = endd
235 ELSE
236 stkpnt = stkpnt + 1
237 stack( 1, stkpnt ) = j + 1
238 stack( 2, stkpnt ) = endd
239 stkpnt = stkpnt + 1
240 stack( 1, stkpnt ) = start
241 stack( 2, stkpnt ) = j
242 END IF
243 END IF
244 END IF
245 IF( stkpnt.GT.0 )
246 $ GO TO 20
247 RETURN
248*
249* End of SLAPST
250*
lsame
logical function lsame(ca, cb)
Definition tools.f:1724
Here is the caller graph for this function: