001:       SUBROUTINE SLASRT( ID, N, D, INFO )
002: *
003: *  -- LAPACK routine (version 3.2) --
004: *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
005: *     November 2006
006: *
007: *     .. Scalar Arguments ..
008:       CHARACTER          ID
009:       INTEGER            INFO, N
010: *     ..
011: *     .. Array Arguments ..
012:       REAL               D( * )
013: *     ..
014: *
015: *  Purpose
016: *  =======
017: *
018: *  Sort the numbers in D in increasing order (if ID = 'I') or
019: *  in decreasing order (if ID = 'D' ).
020: *
021: *  Use Quick Sort, reverting to Insertion sort on arrays of
022: *  size <= 20. Dimension of STACK limits N to about 2**32.
023: *
024: *  Arguments
025: *  =========
026: *
027: *  ID      (input) CHARACTER*1
028: *          = 'I': sort D in increasing order;
029: *          = 'D': sort D in decreasing order.
030: *
031: *  N       (input) INTEGER
032: *          The length of the array D.
033: *
034: *  D       (input/output) REAL array, dimension (N)
035: *          On entry, the array to be sorted.
036: *          On exit, D has been sorted into increasing order
037: *          (D(1) <= ... <= D(N) ) or into decreasing order
038: *          (D(1) >= ... >= D(N) ), depending on ID.
039: *
040: *  INFO    (output) INTEGER
041: *          = 0:  successful exit
042: *          < 0:  if INFO = -i, the i-th argument had an illegal value
043: *
044: *  =====================================================================
045: *
046: *     .. Parameters ..
047:       INTEGER            SELECT
048:       PARAMETER          ( SELECT = 20 )
049: *     ..
050: *     .. Local Scalars ..
051:       INTEGER            DIR, ENDD, I, J, START, STKPNT
052:       REAL               D1, D2, D3, DMNMX, TMP
053: *     ..
054: *     .. Local Arrays ..
055:       INTEGER            STACK( 2, 32 )
056: *     ..
057: *     .. External Functions ..
058:       LOGICAL            LSAME
059:       EXTERNAL           LSAME
060: *     ..
061: *     .. External Subroutines ..
062:       EXTERNAL           XERBLA
063: *     ..
064: *     .. Executable Statements ..
065: *
066: *     Test the input paramters.
067: *
068:       INFO = 0
069:       DIR = -1
070:       IF( LSAME( ID, 'D' ) ) THEN
071:          DIR = 0
072:       ELSE IF( LSAME( ID, 'I' ) ) THEN
073:          DIR = 1
074:       END IF
075:       IF( DIR.EQ.-1 ) THEN
076:          INFO = -1
077:       ELSE IF( N.LT.0 ) THEN
078:          INFO = -2
079:       END IF
080:       IF( INFO.NE.0 ) THEN
081:          CALL XERBLA( 'SLASRT', -INFO )
082:          RETURN
083:       END IF
084: *
085: *     Quick return if possible
086: *
087:       IF( N.LE.1 )
088:      $   RETURN
089: *
090:       STKPNT = 1
091:       STACK( 1, 1 ) = 1
092:       STACK( 2, 1 ) = N
093:    10 CONTINUE
094:       START = STACK( 1, STKPNT )
095:       ENDD = STACK( 2, STKPNT )
096:       STKPNT = STKPNT - 1
097:       IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
098: *
099: *        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 SLASRT
242: *
243:       END
244: