LAPACK: SRC/dlasrt.f Source File

Go to the documentation of this file.
00001       SUBROUTINE DLASRT( ID, N, D, INFO )
00002 *
00003 *  -- LAPACK routine (version 3.2) --
00004 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00005 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00006 *     November 2006
00007 *
00008 *     .. Scalar Arguments ..
00009       CHARACTER          ID
00010       INTEGER            INFO, N
00011 *     ..
00012 *     .. Array Arguments ..
00013       DOUBLE PRECISION   D( * )
00014 *     ..
00015 *
00016 *  Purpose
00017 *  =======
00018 *
00019 *  Sort the numbers in D in increasing order (if ID = 'I') or
00020 *  in decreasing order (if ID = 'D' ).
00021 *
00022 *  Use Quick Sort, reverting to Insertion sort on arrays of
00023 *  size <= 20. Dimension of STACK limits N to about 2**32.
00024 *
00025 *  Arguments
00026 *  =========
00027 *
00028 *  ID      (input) CHARACTER*1
00029 *          = 'I': sort D in increasing order;
00030 *          = 'D': sort D in decreasing order.
00031 *
00032 *  N       (input) INTEGER
00033 *          The length of the array D.
00034 *
00035 *  D       (input/output) DOUBLE PRECISION array, dimension (N)
00036 *          On entry, the array to be sorted.
00037 *          On exit, D has been sorted into increasing order
00038 *          (D(1) <= ... <= D(N) ) or into decreasing order
00039 *          (D(1) >= ... >= D(N) ), depending on ID.
00040 *
00041 *  INFO    (output) INTEGER
00042 *          = 0:  successful exit
00043 *          < 0:  if INFO = -i, the i-th argument had an illegal value
00044 *
00045 *  =====================================================================
00046 *
00047 *     .. Parameters ..
00048       INTEGER            SELECT
00049       PARAMETER          ( SELECT = 20 )
00050 *     ..
00051 *     .. Local Scalars ..
00052       INTEGER            DIR, ENDD, I, J, START, STKPNT
00053       DOUBLE PRECISION   D1, D2, D3, DMNMX, TMP
00054 *     ..
00055 *     .. Local Arrays ..
00056       INTEGER            STACK( 2, 32 )
00057 *     ..
00058 *     .. External Functions ..
00059       LOGICAL            LSAME
00060       EXTERNAL           LSAME
00061 *     ..
00062 *     .. External Subroutines ..
00063       EXTERNAL           XERBLA
00064 *     ..
00065 *     .. Executable Statements ..
00066 *
00067 *     Test the input paramters.
00068 *
00069       INFO = 0
00070       DIR = -1
00071       IF( LSAME( ID, 'D' ) ) THEN
00072          DIR = 0
00073       ELSE IF( LSAME( ID, 'I' ) ) THEN
00074          DIR = 1
00075       END IF
00076       IF( DIR.EQ.-1 ) THEN
00077          INFO = -1
00078       ELSE IF( N.LT.0 ) THEN
00079          INFO = -2
00080       END IF
00081       IF( INFO.NE.0 ) THEN
00082          CALL XERBLA( 'DLASRT', -INFO )
00083          RETURN
00084       END IF
00085 *
00086 *     Quick return if possible
00087 *
00088       IF( N.LE.1 )
00089      $   RETURN
00090 *
00091       STKPNT = 1
00092       STACK( 1, 1 ) = 1
00093       STACK( 2, 1 ) = N
00094    10 CONTINUE
00095       START = STACK( 1, STKPNT )
00096       ENDD = STACK( 2, STKPNT )
00097       STKPNT = STKPNT - 1
00098       IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
00099 *
00100 *        Do Insertion sort on D( START:ENDD )
00101 *
00102          IF( DIR.EQ.0 ) THEN
00103 *
00104 *           Sort into decreasing order
00105 *
00106             DO 30 I = START + 1, ENDD
00107                DO 20 J = I, START + 1, -1
00108                   IF( D( J ).GT.D( J-1 ) ) THEN
00109                      DMNMX = D( J )
00110                      D( J ) = D( J-1 )
00111                      D( J-1 ) = DMNMX
00112                   ELSE
00113                      GO TO 30
00114                   END IF
00115    20          CONTINUE
00116    30       CONTINUE
00117 *
00118          ELSE
00119 *
00120 *           Sort into increasing order
00121 *
00122             DO 50 I = START + 1, ENDD
00123                DO 40 J = I, START + 1, -1
00124                   IF( D( J ).LT.D( J-1 ) ) THEN
00125                      DMNMX = D( J )
00126                      D( J ) = D( J-1 )
00127                      D( J-1 ) = DMNMX
00128                   ELSE
00129                      GO TO 50
00130                   END IF
00131    40          CONTINUE
00132    50       CONTINUE
00133 *
00134          END IF
00135 *
00136       ELSE IF( ENDD-START.GT.SELECT ) THEN
00137 *
00138 *        Partition D( START:ENDD ) and stack parts, largest one first
00139 *
00140 *        Choose partition entry as median of 3
00141 *
00142          D1 = D( START )
00143          D2 = D( ENDD )
00144          I = ( START+ENDD ) / 2
00145          D3 = D( I )
00146          IF( D1.LT.D2 ) THEN
00147             IF( D3.LT.D1 ) THEN
00148                DMNMX = D1
00149             ELSE IF( D3.LT.D2 ) THEN
00150                DMNMX = D3
00151             ELSE
00152                DMNMX = D2
00153             END IF
00154          ELSE
00155             IF( D3.LT.D2 ) THEN
00156                DMNMX = D2
00157             ELSE IF( D3.LT.D1 ) THEN
00158                DMNMX = D3
00159             ELSE
00160                DMNMX = D1
00161             END IF
00162          END IF
00163 *
00164          IF( DIR.EQ.0 ) THEN
00165 *
00166 *           Sort into decreasing order
00167 *
00168             I = START - 1
00169             J = ENDD + 1
00170    60       CONTINUE
00171    70       CONTINUE
00172             J = J - 1
00173             IF( D( J ).LT.DMNMX )
00174      $         GO TO 70
00175    80       CONTINUE
00176             I = I + 1
00177             IF( D( I ).GT.DMNMX )
00178      $         GO TO 80
00179             IF( I.LT.J ) THEN
00180                TMP = D( I )
00181                D( I ) = D( J )
00182                D( J ) = TMP
00183                GO TO 60
00184             END IF
00185             IF( J-START.GT.ENDD-J-1 ) THEN
00186                STKPNT = STKPNT + 1
00187                STACK( 1, STKPNT ) = START
00188                STACK( 2, STKPNT ) = J
00189                STKPNT = STKPNT + 1
00190                STACK( 1, STKPNT ) = J + 1
00191                STACK( 2, STKPNT ) = ENDD
00192             ELSE
00193                STKPNT = STKPNT + 1
00194                STACK( 1, STKPNT ) = J + 1
00195                STACK( 2, STKPNT ) = ENDD
00196                STKPNT = STKPNT + 1
00197                STACK( 1, STKPNT ) = START
00198                STACK( 2, STKPNT ) = J
00199             END IF
00200          ELSE
00201 *
00202 *           Sort into increasing order
00203 *
00204             I = START - 1
00205             J = ENDD + 1
00206    90       CONTINUE
00207   100       CONTINUE
00208             J = J - 1
00209             IF( D( J ).GT.DMNMX )
00210      $         GO TO 100
00211   110       CONTINUE
00212             I = I + 1
00213             IF( D( I ).LT.DMNMX )
00214      $         GO TO 110
00215             IF( I.LT.J ) THEN
00216                TMP = D( I )
00217                D( I ) = D( J )
00218                D( J ) = TMP
00219                GO TO 90
00220             END IF
00221             IF( J-START.GT.ENDD-J-1 ) THEN
00222                STKPNT = STKPNT + 1
00223                STACK( 1, STKPNT ) = START
00224                STACK( 2, STKPNT ) = J
00225                STKPNT = STKPNT + 1
00226                STACK( 1, STKPNT ) = J + 1
00227                STACK( 2, STKPNT ) = ENDD
00228             ELSE
00229                STKPNT = STKPNT + 1
00230                STACK( 1, STKPNT ) = J + 1
00231                STACK( 2, STKPNT ) = ENDD
00232                STKPNT = STKPNT + 1
00233                STACK( 1, STKPNT ) = START
00234                STACK( 2, STKPNT ) = J
00235             END IF
00236          END IF
00237       END IF
00238       IF( STKPNT.GT.0 )
00239      $   GO TO 10
00240       RETURN
00241 *
00242 *     End of DLASRT
00243 *
00244       END