slasrt.f

Go to the documentation of this file.

*> \brief \b SLASRT sorts numbers in increasing or decreasing order.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> Download SLASRT + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slasrt.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slasrt.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slasrt.f">
*> [TXT]</a>
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLASRT( ID, N, D, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          ID
*       INTEGER            INFO, N
*       ..
*       .. Array Arguments ..
*       REAL               D( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> Sort the numbers in D in increasing order (if ID = 'I') or
*> in decreasing order (if ID = 'D' ).
*>
*> Use Quick Sort, reverting to Insertion sort on arrays of
*> size <= 20. Dimension of STACK limits N to about 2**32.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] ID
*> \verbatim
*>          ID is CHARACTER*1
*>          = 'I': sort D in increasing order;
*>          = 'D': sort D in decreasing order.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The length of the array D.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*>          D is REAL array, dimension (N)
*>          On entry, the array to be sorted.
*>          On exit, D has been sorted into increasing order
*>          (D(1) <= ... <= D(N) ) or into decreasing order
*>          (D(1) >= ... >= D(N) ), depending on ID.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup lasrt
*
*  =====================================================================
      SUBROUTINE slasrt( ID, N, D, INFO )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          ID
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      REAL               D( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            SELECT
      parameter( SELECT = 20 )
*     ..
*     .. Local Scalars ..
      INTEGER            DIR, ENDD, I, J, START, STKPNT
      REAL               D1, D2, D3, DMNMX, TMP
*     ..
*     .. Local Arrays ..
      INTEGER            STACK( 2, 32 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. External Subroutines ..
      EXTERNAL           xerbla
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
      dir = -1
      IF( lsame( id, 'D' ) ) THEN
         dir = 0
      ELSE IF( lsame( id, 'I' ) ) THEN
         dir = 1
      END IF
      IF( dir.EQ.-1 ) THEN
         info = -1
      ELSE IF( n.LT.0 ) THEN
         info = -2
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SLASRT', -info )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( n.LE.1 )
     $   RETURN
*
      stkpnt = 1
      stack( 1, 1 ) = 1
      stack( 2, 1 ) = n
   10 CONTINUE
      start = stack( 1, stkpnt )
      endd = stack( 2, stkpnt )
      stkpnt = stkpnt - 1
      IF( endd-start.LE.SELECT .AND. endd-start.GT.0 ) THEN
*
*        Do Insertion sort on D( START:ENDD )
*
         IF( dir.EQ.0 ) THEN
*
*           Sort into decreasing order
*
            DO 30 i = start + 1, endd
               DO 20 j = i, start + 1, -1
                  IF( d( j ).GT.d( j-1 ) ) THEN
                     dmnmx = d( j )
                     d( j ) = d( j-1 )
                     d( j-1 ) = dmnmx
                  ELSE
                     GO TO 30
                  END IF
   20          CONTINUE
   30       CONTINUE
*
         ELSE
*
*           Sort into increasing order
*
            DO 50 i = start + 1, endd
               DO 40 j = i, start + 1, -1
                  IF( d( j ).LT.d( j-1 ) ) THEN
                     dmnmx = d( j )
                     d( j ) = d( j-1 )
                     d( j-1 ) = dmnmx
                  ELSE
                     GO TO 50
                  END IF
   40          CONTINUE
   50       CONTINUE
*
         END IF
*
      ELSE IF( endd-start.GT.SELECT ) THEN
*
*        Partition D( START:ENDD ) and stack parts, largest one first
*
*        Choose partition entry as median of 3
*
         d1 = d( start )
         d2 = d( endd )
         i = ( start+endd ) / 2
         d3 = d( i )
         IF( d1.LT.d2 ) THEN
            IF( d3.LT.d1 ) THEN
               dmnmx = d1
            ELSE IF( d3.LT.d2 ) THEN
               dmnmx = d3
            ELSE
               dmnmx = d2
            END IF
         ELSE
            IF( d3.LT.d2 ) THEN
               dmnmx = d2
            ELSE IF( d3.LT.d1 ) THEN
               dmnmx = d3
            ELSE
               dmnmx = d1
            END IF
         END IF
*
         IF( dir.EQ.0 ) THEN
*
*           Sort into decreasing order
*
            i = start - 1
            j = endd + 1
   60       CONTINUE
   70       CONTINUE
            j = j - 1
            IF( d( j ).LT.dmnmx )
     $         GO TO 70
   80       CONTINUE
            i = i + 1
            IF( d( i ).GT.dmnmx )
     $         GO TO 80
            IF( i.LT.j ) THEN
               tmp = d( i )
               d( i ) = d( j )
               d( j ) = tmp
               GO TO 60
            END IF
            IF( j-start.GT.endd-j-1 ) THEN
               stkpnt = stkpnt + 1
               stack( 1, stkpnt ) = start
               stack( 2, stkpnt ) = j
               stkpnt = stkpnt + 1
               stack( 1, stkpnt ) = j + 1
               stack( 2, stkpnt ) = endd
            ELSE
               stkpnt = stkpnt + 1
               stack( 1, stkpnt ) = j + 1
               stack( 2, stkpnt ) = endd
               stkpnt = stkpnt + 1
               stack( 1, stkpnt ) = start
               stack( 2, stkpnt ) = j
            END IF
         ELSE
*
*           Sort into increasing order
*
            i = start - 1
            j = endd + 1
   90       CONTINUE
  100       CONTINUE
            j = j - 1
            IF( d( j ).GT.dmnmx )
     $         GO TO 100
  110       CONTINUE
            i = i + 1
            IF( d( i ).LT.dmnmx )
     $         GO TO 110
            IF( i.LT.j ) THEN
               tmp = d( i )
               d( i ) = d( j )
               d( j ) = tmp
               GO TO 90
            END IF
            IF( j-start.GT.endd-j-1 ) THEN
               stkpnt = stkpnt + 1
               stack( 1, stkpnt ) = start
               stack( 2, stkpnt ) = j
               stkpnt = stkpnt + 1
               stack( 1, stkpnt ) = j + 1
               stack( 2, stkpnt ) = endd
            ELSE
               stkpnt = stkpnt + 1
               stack( 1, stkpnt ) = j + 1
               stack( 2, stkpnt ) = endd
               stkpnt = stkpnt + 1
               stack( 1, stkpnt ) = start
               stack( 2, stkpnt ) = j
            END IF
         END IF
      END IF
      IF( stkpnt.GT.0 )
     $   GO TO 10
      RETURN
*
*     End of SLASRT
*
      SUBROUTINE slasrt( ID, N, D, INFO ) …
      END