dlasrt.f

Go to the documentation of this file.

      SUBROUTINE dlasrt( ID, N, D, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          ID
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * )
*     ..
*
*  Purpose
*  =======
*
*  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.
*
*  Arguments
*  =========
*
*  ID      (input) CHARACTER*1
*          = 'I': sort D in increasing order;
*          = 'D': sort D in decreasing order.
*
*  N       (input) INTEGER
*          The length of the array D.
*
*  D       (input/output) DOUBLE PRECISION 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.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            SELECT
      parameter( SELECT = 20 )
*     ..
*     .. Local Scalars ..
      INTEGER            DIR, ENDD, I, J, START, STKPNT
      DOUBLE PRECISION   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 paramters.
*
      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( 'DLASRT', -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 DLASRT
*
      END