001:       SUBROUTINE SLASRT( ID, N, D, INFO )
002: *
003: *  -- LAPACK routine (version 3.2) --
004: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
005: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
006: *     November 2006
007: *
008: *     .. Scalar Arguments ..
009:       CHARACTER          ID
010:       INTEGER            INFO, N
011: *     ..
012: *     .. Array Arguments ..
013:       REAL               D( * )
014: *     ..
015: *
016: *  Purpose
017: *  =======
018: *
019: *  Sort the numbers in D in increasing order (if ID = 'I') or
020: *  in decreasing order (if ID = 'D' ).
021: *
022: *  Use Quick Sort, reverting to Insertion sort on arrays of
023: *  size <= 20. Dimension of STACK limits N to about 2**32.
024: *
025: *  Arguments
026: *  =========
027: *
028: *  ID      (input) CHARACTER*1
029: *          = 'I': sort D in increasing order;
030: *          = 'D': sort D in decreasing order.
031: *
032: *  N       (input) INTEGER
033: *          The length of the array D.
034: *
035: *  D       (input/output) REAL array, dimension (N)
036: *          On entry, the array to be sorted.
037: *          On exit, D has been sorted into increasing order
038: *          (D(1) <= ... <= D(N) ) or into decreasing order
039: *          (D(1) >= ... >= D(N) ), depending on ID.
040: *
041: *  INFO    (output) INTEGER
042: *          = 0:  successful exit
043: *          < 0:  if INFO = -i, the i-th argument had an illegal value
044: *
045: *  =====================================================================
046: *
047: *     .. Parameters ..
048:       INTEGER            SELECT
049:       PARAMETER          ( SELECT = 20 )
050: *     ..
051: *     .. Local Scalars ..
052:       INTEGER            DIR, ENDD, I, J, START, STKPNT
053:       REAL               D1, D2, D3, DMNMX, TMP
054: *     ..
055: *     .. Local Arrays ..
056:       INTEGER            STACK( 2, 32 )
057: *     ..
058: *     .. External Functions ..
059:       LOGICAL            LSAME
060:       EXTERNAL           LSAME
061: *     ..
062: *     .. External Subroutines ..
063:       EXTERNAL           XERBLA
064: *     ..
065: *     .. Executable Statements ..
066: *
067: *     Test the input paramters.
068: *
069:       INFO = 0
070:       DIR = -1
071:       IF( LSAME( ID, 'D' ) ) THEN
072:          DIR = 0
073:       ELSE IF( LSAME( ID, 'I' ) ) THEN
074:          DIR = 1
075:       END IF
076:       IF( DIR.EQ.-1 ) THEN
077:          INFO = -1
078:       ELSE IF( N.LT.0 ) THEN
079:          INFO = -2
080:       END IF
081:       IF( INFO.NE.0 ) THEN
082:          CALL XERBLA( 'SLASRT', -INFO )
083:          RETURN
084:       END IF
085: *
086: *     Quick return if possible
087: *
088:       IF( N.LE.1 )
089:      $   RETURN
090: *
091:       STKPNT = 1
092:       STACK( 1, 1 ) = 1
093:       STACK( 2, 1 ) = N
094:    10 CONTINUE
095:       START = STACK( 1, STKPNT )
096:       ENDD = STACK( 2, STKPNT )
097:       STKPNT = STKPNT - 1
098:       IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
099: *
100: *        Do Insertion sort on D( START:ENDD )
101: *
102:          IF( DIR.EQ.0 ) THEN
103: *
104: *           Sort into decreasing order
105: *
106:             DO 30 I = START + 1, ENDD
107:                DO 20 J = I, START + 1, -1
108:                   IF( D( J ).GT.D( J-1 ) ) THEN
109:                      DMNMX = D( J )
110:                      D( J ) = D( J-1 )
111:                      D( J-1 ) = DMNMX
112:                   ELSE
113:                      GO TO 30
114:                   END IF
115:    20          CONTINUE
116:    30       CONTINUE
117: *
118:          ELSE
119: *
120: *           Sort into increasing order
121: *
122:             DO 50 I = START + 1, ENDD
123:                DO 40 J = I, START + 1, -1
124:                   IF( D( J ).LT.D( J-1 ) ) THEN
125:                      DMNMX = D( J )
126:                      D( J ) = D( J-1 )
127:                      D( J-1 ) = DMNMX
128:                   ELSE
129:                      GO TO 50
130:                   END IF
131:    40          CONTINUE
132:    50       CONTINUE
133: *
134:          END IF
135: *
136:       ELSE IF( ENDD-START.GT.SELECT ) THEN
137: *
138: *        Partition D( START:ENDD ) and stack parts, largest one first
139: *
140: *        Choose partition entry as median of 3
141: *
142:          D1 = D( START )
143:          D2 = D( ENDD )
144:          I = ( START+ENDD ) / 2
145:          D3 = D( I )
146:          IF( D1.LT.D2 ) THEN
147:             IF( D3.LT.D1 ) THEN
148:                DMNMX = D1
149:             ELSE IF( D3.LT.D2 ) THEN
150:                DMNMX = D3
151:             ELSE
152:                DMNMX = D2
153:             END IF
154:          ELSE
155:             IF( D3.LT.D2 ) THEN
156:                DMNMX = D2
157:             ELSE IF( D3.LT.D1 ) THEN
158:                DMNMX = D3
159:             ELSE
160:                DMNMX = D1
161:             END IF
162:          END IF
163: *
164:          IF( DIR.EQ.0 ) THEN
165: *
166: *           Sort into decreasing order
167: *
168:             I = START - 1
169:             J = ENDD + 1
170:    60       CONTINUE
171:    70       CONTINUE
172:             J = J - 1
173:             IF( D( J ).LT.DMNMX )
174:      $         GO TO 70
175:    80       CONTINUE
176:             I = I + 1
177:             IF( D( I ).GT.DMNMX )
178:      $         GO TO 80
179:             IF( I.LT.J ) THEN
180:                TMP = D( I )
181:                D( I ) = D( J )
182:                D( J ) = TMP
183:                GO TO 60
184:             END IF
185:             IF( J-START.GT.ENDD-J-1 ) THEN
186:                STKPNT = STKPNT + 1
187:                STACK( 1, STKPNT ) = START
188:                STACK( 2, STKPNT ) = J
189:                STKPNT = STKPNT + 1
190:                STACK( 1, STKPNT ) = J + 1
191:                STACK( 2, STKPNT ) = ENDD
192:             ELSE
193:                STKPNT = STKPNT + 1
194:                STACK( 1, STKPNT ) = J + 1
195:                STACK( 2, STKPNT ) = ENDD
196:                STKPNT = STKPNT + 1
197:                STACK( 1, STKPNT ) = START
198:                STACK( 2, STKPNT ) = J
199:             END IF
200:          ELSE
201: *
202: *           Sort into increasing order
203: *
204:             I = START - 1
205:             J = ENDD + 1
206:    90       CONTINUE
207:   100       CONTINUE
208:             J = J - 1
209:             IF( D( J ).GT.DMNMX )
210:      $         GO TO 100
211:   110       CONTINUE
212:             I = I + 1
213:             IF( D( I ).LT.DMNMX )
214:      $         GO TO 110
215:             IF( I.LT.J ) THEN
216:                TMP = D( I )
217:                D( I ) = D( J )
218:                D( J ) = TMP
219:                GO TO 90
220:             END IF
221:             IF( J-START.GT.ENDD-J-1 ) THEN
222:                STKPNT = STKPNT + 1
223:                STACK( 1, STKPNT ) = START
224:                STACK( 2, STKPNT ) = J
225:                STKPNT = STKPNT + 1
226:                STACK( 1, STKPNT ) = J + 1
227:                STACK( 2, STKPNT ) = ENDD
228:             ELSE
229:                STKPNT = STKPNT + 1
230:                STACK( 1, STKPNT ) = J + 1
231:                STACK( 2, STKPNT ) = ENDD
232:                STKPNT = STKPNT + 1
233:                STACK( 1, STKPNT ) = START
234:                STACK( 2, STKPNT ) = J
235:             END IF
236:          END IF
237:       END IF
238:       IF( STKPNT.GT.0 )
239:      $   GO TO 10
240:       RETURN
241: *
242: *     End of SLASRT
243: *
244:       END
245: