vendor/gonum.org/v1/gonum/lapack/internal/testdata/dsterftest/dlasrt.f

   1 *> \brief \b DLASRT sorts numbers in increasing or decreasing order.
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *> \htmlonly
   9 *> Download DLASRT + dependencies
  10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasrt.f">
  11 *> [TGZ]</a>
  12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasrt.f">
  13 *> [ZIP]</a>
  14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasrt.f">
  15 *> [TXT]</a>
  16 *> \endhtmlonly
  17 *
  18 *  Definition:
  19 *  ===========
  20 *
  21 *       SUBROUTINE DLASRT( ID, N, D, INFO )
  22 *
  23 *       .. Scalar Arguments ..
  24 *       CHARACTER          ID
  25 *       INTEGER            INFO, N
  26 *       ..
  27 *       .. Array Arguments ..
  28 *       DOUBLE PRECISION   D( * )
  29 *       ..
  30 *
  31 *
  32 *> \par Purpose:
  33 *  =============
  34 *>
  35 *> \verbatim
  36 *>
  37 *> Sort the numbers in D in increasing order (if ID = 'I') or
  38 *> in decreasing order (if ID = 'D' ).
  39 *>
  40 *> Use Quick Sort, reverting to Insertion sort on arrays of
  41 *> size <= 20. Dimension of STACK limits N to about 2**32.
  42 *> \endverbatim
  43 *
  44 *  Arguments:
  45 *  ==========
  46 *
  47 *> \param[in] ID
  48 *> \verbatim
  49 *>          ID is CHARACTER*1
  50 *>          = 'I': sort D in increasing order;
  51 *>          = 'D': sort D in decreasing order.
  52 *> \endverbatim
  53 *>
  54 *> \param[in] N
  55 *> \verbatim
  56 *>          N is INTEGER
  57 *>          The length of the array D.
  58 *> \endverbatim
  59 *>
  60 *> \param[in,out] D
  61 *> \verbatim
  62 *>          D is DOUBLE PRECISION array, dimension (N)
  63 *>          On entry, the array to be sorted.
  64 *>          On exit, D has been sorted into increasing order
  65 *>          (D(1) <= ... <= D(N) ) or into decreasing order
  66 *>          (D(1) >= ... >= D(N) ), depending on ID.
  67 *> \endverbatim
  68 *>
  69 *> \param[out] INFO
  70 *> \verbatim
  71 *>          INFO is INTEGER
  72 *>          = 0:  successful exit
  73 *>          < 0:  if INFO = -i, the i-th argument had an illegal value
  74 *> \endverbatim
  75 *
  76 *  Authors:
  77 *  ========
  78 *
  79 *> \author Univ. of Tennessee
  80 *> \author Univ. of California Berkeley
  81 *> \author Univ. of Colorado Denver
  82 *> \author NAG Ltd.
  83 *
  84 *> \date September 2012
  85 *
  86 *> \ingroup auxOTHERcomputational
  87 *
  88 *  =====================================================================
  89       SUBROUTINE DLASRT( ID, N, D, INFO )
  90 *
  91 *  -- LAPACK computational routine (version 3.4.2) --
  92 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
  93 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  94 *     September 2012
  95 *
  96 *     .. Scalar Arguments ..
  97       CHARACTER          ID
  98       INTEGER            INFO, N
  99 *     ..
 100 *     .. Array Arguments ..
 101       DOUBLE PRECISION   D( * )
 102 *     ..
 103 *
 104 *  =====================================================================
 105 *
 106 *     .. Parameters ..
 107       INTEGER            SELECT
 108       PARAMETER          ( SELECT = 20 )
 109 *     ..
 110 *     .. Local Scalars ..
 111       INTEGER            DIR, ENDD, I, J, START, STKPNT
 112       DOUBLE PRECISION   D1, D2, D3, DMNMX, TMP
 113 *     ..
 114 *     .. Local Arrays ..
 115       INTEGER            STACK( 2, 32 )
 116 *     ..
 117 *     .. External Functions ..
 118       LOGICAL            LSAME
 119       EXTERNAL           LSAME
 120 *     ..
 121 *     .. External Subroutines ..
 122       EXTERNAL           XERBLA
 123 *     ..
 124 *     .. Executable Statements ..
 125 *
 126 *     Test the input paramters.
 127 *
 128       INFO = 0
 129       DIR = -1
 130       IF( LSAME( ID, 'D' ) ) THEN
 131          DIR = 0
 132       ELSE IF( LSAME( ID, 'I' ) ) THEN
 133          DIR = 1
 134       END IF
 135       IF( DIR.EQ.-1 ) THEN
 136          INFO = -1
 137       ELSE IF( N.LT.0 ) THEN
 138          INFO = -2
 139       END IF
 140       IF( INFO.NE.0 ) THEN
 141          CALL XERBLA( 'DLASRT', -INFO )
 142          RETURN
 143       END IF
 144 *
 145 *     Quick return if possible
 146 *
 147       IF( N.LE.1 )
 148      $   RETURN
 149 *
 150       STKPNT = 1
 151       STACK( 1, 1 ) = 1
 152       STACK( 2, 1 ) = N
 153    10 CONTINUE
 154       START = STACK( 1, STKPNT )
 155       ENDD = STACK( 2, STKPNT )
 156       STKPNT = STKPNT - 1
 157       IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
 158 *
 159 *        Do Insertion sort on D( START:ENDD )
 160 *
 161          IF( DIR.EQ.0 ) THEN
 162 *
 163 *           Sort into decreasing order
 164 *
 165             DO 30 I = START + 1, ENDD
 166                DO 20 J = I, START + 1, -1
 167                   IF( D( J ).GT.D( J-1 ) ) THEN
 168                      DMNMX = D( J )
 169                      D( J ) = D( J-1 )
 170                      D( J-1 ) = DMNMX
 171                   ELSE
 172                      GO TO 30
 173                   END IF
 174    20          CONTINUE
 175    30       CONTINUE
 176 *
 177          ELSE
 178 *
 179 *           Sort into increasing order
 180 *
 181             DO 50 I = START + 1, ENDD
 182                DO 40 J = I, START + 1, -1
 183                   IF( D( J ).LT.D( J-1 ) ) THEN
 184                      DMNMX = D( J )
 185                      D( J ) = D( J-1 )
 186                      D( J-1 ) = DMNMX
 187                   ELSE
 188                      GO TO 50
 189                   END IF
 190    40          CONTINUE
 191    50       CONTINUE
 192 *
 193          END IF
 194 *
 195       ELSE IF( ENDD-START.GT.SELECT ) THEN
 196 *
 197 *        Partition D( START:ENDD ) and stack parts, largest one first
 198 *
 199 *        Choose partition entry as median of 3
 200 *
 201          D1 = D( START )
 202          D2 = D( ENDD )
 203          I = ( START+ENDD ) / 2
 204          D3 = D( I )
 205          IF( D1.LT.D2 ) THEN
 206             IF( D3.LT.D1 ) THEN
 207                DMNMX = D1
 208             ELSE IF( D3.LT.D2 ) THEN
 209                DMNMX = D3
 210             ELSE
 211                DMNMX = D2
 212             END IF
 213          ELSE
 214             IF( D3.LT.D2 ) THEN
 215                DMNMX = D2
 216             ELSE IF( D3.LT.D1 ) THEN
 217                DMNMX = D3
 218             ELSE
 219                DMNMX = D1
 220             END IF
 221          END IF
 222 *
 223          IF( DIR.EQ.0 ) THEN
 224 *
 225 *           Sort into decreasing order
 226 *
 227             I = START - 1
 228             J = ENDD + 1
 229    60       CONTINUE
 230    70       CONTINUE
 231             J = J - 1
 232             IF( D( J ).LT.DMNMX )
 233      $         GO TO 70
 234    80       CONTINUE
 235             I = I + 1
 236             IF( D( I ).GT.DMNMX )
 237      $         GO TO 80
 238             IF( I.LT.J ) THEN
 239                TMP = D( I )
 240                D( I ) = D( J )
 241                D( J ) = TMP
 242                GO TO 60
 243             END IF
 244             IF( J-START.GT.ENDD-J-1 ) THEN
 245                STKPNT = STKPNT + 1
 246                STACK( 1, STKPNT ) = START
 247                STACK( 2, STKPNT ) = J
 248                STKPNT = STKPNT + 1
 249                STACK( 1, STKPNT ) = J + 1
 250                STACK( 2, STKPNT ) = ENDD
 251             ELSE
 252                STKPNT = STKPNT + 1
 253                STACK( 1, STKPNT ) = J + 1
 254                STACK( 2, STKPNT ) = ENDD
 255                STKPNT = STKPNT + 1
 256                STACK( 1, STKPNT ) = START
 257                STACK( 2, STKPNT ) = J
 258             END IF
 259          ELSE
 260 *
 261 *           Sort into increasing order
 262 *
 263             I = START - 1
 264             J = ENDD + 1
 265    90       CONTINUE
 266   100       CONTINUE
 267             J = J - 1
 268             IF( D( J ).GT.DMNMX )
 269      $         GO TO 100
 270   110       CONTINUE
 271             I = I + 1
 272             IF( D( I ).LT.DMNMX )
 273      $         GO TO 110
 274             IF( I.LT.J ) THEN
 275                TMP = D( I )
 276                D( I ) = D( J )
 277                D( J ) = TMP
 278                GO TO 90
 279             END IF
 280             IF( J-START.GT.ENDD-J-1 ) THEN
 281                STKPNT = STKPNT + 1
 282                STACK( 1, STKPNT ) = START
 283                STACK( 2, STKPNT ) = J
 284                STKPNT = STKPNT + 1
 285                STACK( 1, STKPNT ) = J + 1
 286                STACK( 2, STKPNT ) = ENDD
 287             ELSE
 288                STKPNT = STKPNT + 1
 289                STACK( 1, STKPNT ) = J + 1
 290                STACK( 2, STKPNT ) = ENDD
 291                STKPNT = STKPNT + 1
 292                STACK( 1, STKPNT ) = START
 293                STACK( 2, STKPNT ) = J
 294             END IF
 295          END IF
 296       END IF
 297       IF( STKPNT.GT.0 )
 298      $   GO TO 10
 299       RETURN
 300 *
 301 *     End of DLASRT
 302 *
 303       END