ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
slapst.f
Go to the documentation of this file.
1  SUBROUTINE slapst( ID, N, D, INDX, INFO )
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 *
251  END
slapst
subroutine slapst(ID, N, D, INDX, INFO)
Definition: slapst.f:2