LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
dlasrt.f
Go to the documentation of this file.
00001 *> \brief \b DLASRT
00002 *
00003 *  =========== DOCUMENTATION ===========
00004 *
00005 * Online html documentation available at 
00006 *            http://www.netlib.org/lapack/explore-html/ 
00007 *
00008 *> \htmlonly
00009 *> Download DLASRT + dependencies 
00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasrt.f"> 
00011 *> [TGZ]</a> 
00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasrt.f"> 
00013 *> [ZIP]</a> 
00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasrt.f"> 
00015 *> [TXT]</a>
00016 *> \endhtmlonly 
00017 *
00018 *  Definition:
00019 *  ===========
00020 *
00021 *       SUBROUTINE DLASRT( ID, N, D, INFO )
00022 * 
00023 *       .. Scalar Arguments ..
00024 *       CHARACTER          ID
00025 *       INTEGER            INFO, N
00026 *       ..
00027 *       .. Array Arguments ..
00028 *       DOUBLE PRECISION   D( * )
00029 *       ..
00030 *  
00031 *
00032 *> \par Purpose:
00033 *  =============
00034 *>
00035 *> \verbatim
00036 *>
00037 *> Sort the numbers in D in increasing order (if ID = 'I') or
00038 *> in decreasing order (if ID = 'D' ).
00039 *>
00040 *> Use Quick Sort, reverting to Insertion sort on arrays of
00041 *> size <= 20. Dimension of STACK limits N to about 2**32.
00042 *> \endverbatim
00043 *
00044 *  Arguments:
00045 *  ==========
00046 *
00047 *> \param[in] ID
00048 *> \verbatim
00049 *>          ID is CHARACTER*1
00050 *>          = 'I': sort D in increasing order;
00051 *>          = 'D': sort D in decreasing order.
00052 *> \endverbatim
00053 *>
00054 *> \param[in] N
00055 *> \verbatim
00056 *>          N is INTEGER
00057 *>          The length of the array D.
00058 *> \endverbatim
00059 *>
00060 *> \param[in,out] D
00061 *> \verbatim
00062 *>          D is DOUBLE PRECISION array, dimension (N)
00063 *>          On entry, the array to be sorted.
00064 *>          On exit, D has been sorted into increasing order
00065 *>          (D(1) <= ... <= D(N) ) or into decreasing order
00066 *>          (D(1) >= ... >= D(N) ), depending on ID.
00067 *> \endverbatim
00068 *>
00069 *> \param[out] INFO
00070 *> \verbatim
00071 *>          INFO is INTEGER
00072 *>          = 0:  successful exit
00073 *>          < 0:  if INFO = -i, the i-th argument had an illegal value
00074 *> \endverbatim
00075 *
00076 *  Authors:
00077 *  ========
00078 *
00079 *> \author Univ. of Tennessee 
00080 *> \author Univ. of California Berkeley 
00081 *> \author Univ. of Colorado Denver 
00082 *> \author NAG Ltd. 
00083 *
00084 *> \date November 2011
00085 *
00086 *> \ingroup auxOTHERcomputational
00087 *
00088 *  =====================================================================
00089       SUBROUTINE DLASRT( ID, N, D, INFO )
00090 *
00091 *  -- LAPACK computational routine (version 3.4.0) --
00092 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00093 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00094 *     November 2011
00095 *
00096 *     .. Scalar Arguments ..
00097       CHARACTER          ID
00098       INTEGER            INFO, N
00099 *     ..
00100 *     .. Array Arguments ..
00101       DOUBLE PRECISION   D( * )
00102 *     ..
00103 *
00104 *  =====================================================================
00105 *
00106 *     .. Parameters ..
00107       INTEGER            SELECT
00108       PARAMETER          ( SELECT = 20 )
00109 *     ..
00110 *     .. Local Scalars ..
00111       INTEGER            DIR, ENDD, I, J, START, STKPNT
00112       DOUBLE PRECISION   D1, D2, D3, DMNMX, TMP
00113 *     ..
00114 *     .. Local Arrays ..
00115       INTEGER            STACK( 2, 32 )
00116 *     ..
00117 *     .. External Functions ..
00118       LOGICAL            LSAME
00119       EXTERNAL           LSAME
00120 *     ..
00121 *     .. External Subroutines ..
00122       EXTERNAL           XERBLA
00123 *     ..
00124 *     .. Executable Statements ..
00125 *
00126 *     Test the input paramters.
00127 *
00128       INFO = 0
00129       DIR = -1
00130       IF( LSAME( ID, 'D' ) ) THEN
00131          DIR = 0
00132       ELSE IF( LSAME( ID, 'I' ) ) THEN
00133          DIR = 1
00134       END IF
00135       IF( DIR.EQ.-1 ) THEN
00136          INFO = -1
00137       ELSE IF( N.LT.0 ) THEN
00138          INFO = -2
00139       END IF
00140       IF( INFO.NE.0 ) THEN
00141          CALL XERBLA( 'DLASRT', -INFO )
00142          RETURN
00143       END IF
00144 *
00145 *     Quick return if possible
00146 *
00147       IF( N.LE.1 )
00148      $   RETURN
00149 *
00150       STKPNT = 1
00151       STACK( 1, 1 ) = 1
00152       STACK( 2, 1 ) = N
00153    10 CONTINUE
00154       START = STACK( 1, STKPNT )
00155       ENDD = STACK( 2, STKPNT )
00156       STKPNT = STKPNT - 1
00157       IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
00158 *
00159 *        Do Insertion sort on D( START:ENDD )
00160 *
00161          IF( DIR.EQ.0 ) THEN
00162 *
00163 *           Sort into decreasing order
00164 *
00165             DO 30 I = START + 1, ENDD
00166                DO 20 J = I, START + 1, -1
00167                   IF( D( J ).GT.D( J-1 ) ) THEN
00168                      DMNMX = D( J )
00169                      D( J ) = D( J-1 )
00170                      D( J-1 ) = DMNMX
00171                   ELSE
00172                      GO TO 30
00173                   END IF
00174    20          CONTINUE
00175    30       CONTINUE
00176 *
00177          ELSE
00178 *
00179 *           Sort into increasing order
00180 *
00181             DO 50 I = START + 1, ENDD
00182                DO 40 J = I, START + 1, -1
00183                   IF( D( J ).LT.D( J-1 ) ) THEN
00184                      DMNMX = D( J )
00185                      D( J ) = D( J-1 )
00186                      D( J-1 ) = DMNMX
00187                   ELSE
00188                      GO TO 50
00189                   END IF
00190    40          CONTINUE
00191    50       CONTINUE
00192 *
00193          END IF
00194 *
00195       ELSE IF( ENDD-START.GT.SELECT ) THEN
00196 *
00197 *        Partition D( START:ENDD ) and stack parts, largest one first
00198 *
00199 *        Choose partition entry as median of 3
00200 *
00201          D1 = D( START )
00202          D2 = D( ENDD )
00203          I = ( START+ENDD ) / 2
00204          D3 = D( I )
00205          IF( D1.LT.D2 ) THEN
00206             IF( D3.LT.D1 ) THEN
00207                DMNMX = D1
00208             ELSE IF( D3.LT.D2 ) THEN
00209                DMNMX = D3
00210             ELSE
00211                DMNMX = D2
00212             END IF
00213          ELSE
00214             IF( D3.LT.D2 ) THEN
00215                DMNMX = D2
00216             ELSE IF( D3.LT.D1 ) THEN
00217                DMNMX = D3
00218             ELSE
00219                DMNMX = D1
00220             END IF
00221          END IF
00222 *
00223          IF( DIR.EQ.0 ) THEN
00224 *
00225 *           Sort into decreasing order
00226 *
00227             I = START - 1
00228             J = ENDD + 1
00229    60       CONTINUE
00230    70       CONTINUE
00231             J = J - 1
00232             IF( D( J ).LT.DMNMX )
00233      $         GO TO 70
00234    80       CONTINUE
00235             I = I + 1
00236             IF( D( I ).GT.DMNMX )
00237      $         GO TO 80
00238             IF( I.LT.J ) THEN
00239                TMP = D( I )
00240                D( I ) = D( J )
00241                D( J ) = TMP
00242                GO TO 60
00243             END IF
00244             IF( J-START.GT.ENDD-J-1 ) THEN
00245                STKPNT = STKPNT + 1
00246                STACK( 1, STKPNT ) = START
00247                STACK( 2, STKPNT ) = J
00248                STKPNT = STKPNT + 1
00249                STACK( 1, STKPNT ) = J + 1
00250                STACK( 2, STKPNT ) = ENDD
00251             ELSE
00252                STKPNT = STKPNT + 1
00253                STACK( 1, STKPNT ) = J + 1
00254                STACK( 2, STKPNT ) = ENDD
00255                STKPNT = STKPNT + 1
00256                STACK( 1, STKPNT ) = START
00257                STACK( 2, STKPNT ) = J
00258             END IF
00259          ELSE
00260 *
00261 *           Sort into increasing order
00262 *
00263             I = START - 1
00264             J = ENDD + 1
00265    90       CONTINUE
00266   100       CONTINUE
00267             J = J - 1
00268             IF( D( J ).GT.DMNMX )
00269      $         GO TO 100
00270   110       CONTINUE
00271             I = I + 1
00272             IF( D( I ).LT.DMNMX )
00273      $         GO TO 110
00274             IF( I.LT.J ) THEN
00275                TMP = D( I )
00276                D( I ) = D( J )
00277                D( J ) = TMP
00278                GO TO 90
00279             END IF
00280             IF( J-START.GT.ENDD-J-1 ) THEN
00281                STKPNT = STKPNT + 1
00282                STACK( 1, STKPNT ) = START
00283                STACK( 2, STKPNT ) = J
00284                STKPNT = STKPNT + 1
00285                STACK( 1, STKPNT ) = J + 1
00286                STACK( 2, STKPNT ) = ENDD
00287             ELSE
00288                STKPNT = STKPNT + 1
00289                STACK( 1, STKPNT ) = J + 1
00290                STACK( 2, STKPNT ) = ENDD
00291                STKPNT = STKPNT + 1
00292                STACK( 1, STKPNT ) = START
00293                STACK( 2, STKPNT ) = J
00294             END IF
00295          END IF
00296       END IF
00297       IF( STKPNT.GT.0 )
00298      $   GO TO 10
00299       RETURN
00300 *
00301 *     End of DLASRT
00302 *
00303       END
 All Files Functions