slapst.f

Go to the documentation of this file.

      SUBROUTINE slapst( ID, N, D, INDX, INFO )
*
*  -- ScaLAPACK auxiliary routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     December 31, 1998
*
*     .. Scalar Arguments ..
      CHARACTER          ID
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      INTEGER            INDX( * )
      REAL               D( * )
*     ..
*
*  Purpose
*  =======
*  SLAPST is a modified version of the LAPACK routine SLASRT.
*
*  Define a permutation INDX that sorts 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)  REAL array, dimension (N)
*          The array to be sorted.
*
*  INDX    (ouput) INTEGER array, dimension (N).
*          The permutation which sorts the array D.
*
*  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, ITMP, J, START, STKPNT
      REAL               D1, D2, D3, DMNMX
*     ..
*     .. 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( 'SLAPST', -info )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( n.LE.1 )
     $   RETURN
*
      DO 10 i = 1, n
         indx( i ) = i
   10 CONTINUE
*
      stkpnt = 1
      stack( 1, 1 ) = 1
      stack( 2, 1 ) = n
   20 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 40 i = start + 1, endd
               DO 30 j = i, start + 1, -1
                  IF( d( indx( j ) ).GT.d( indx( j-1 ) ) ) THEN
                     itmp = indx( j )
                     indx( j ) = indx( j-1 )
                     indx( j-1 ) = itmp
                  ELSE
                     GO TO 40
                  END IF
   30          CONTINUE
   40       CONTINUE
*
         ELSE
*
*           Sort into increasing order
*
            DO 60 i = start + 1, endd
               DO 50 j = i, start + 1, -1
                  IF( d( indx( j ) ).LT.d( indx( j-1 ) ) ) THEN
                     itmp = indx( j )
                     indx( j ) = indx( j-1 )
                     indx( j-1 ) = itmp
                  ELSE
                     GO TO 60
                  END IF
   50          CONTINUE
   60       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( indx( start ) )
         d2 = d( indx( endd ) )
         i = ( start+endd ) / 2
         d3 = d( indx( 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
   70       CONTINUE
   80       CONTINUE
            j = j - 1
            IF( d( indx( j ) ).LT.dmnmx )
     $         GO TO 80
   90       CONTINUE
            i = i + 1
            IF( d( indx( i ) ).GT.dmnmx )
     $         GO TO 90
            IF( i.LT.j ) THEN
               itmp = indx( i )
               indx( i ) = indx( j )
               indx( j ) = itmp
               GO TO 70
            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
  100       CONTINUE
  110       CONTINUE
            j = j - 1
            IF( d( indx( j ) ).GT.dmnmx )
     $         GO TO 110
  120       CONTINUE
            i = i + 1
            IF( d( indx( i ) ).LT.dmnmx )
     $         GO TO 120
            IF( i.LT.j ) THEN
               itmp = indx( i )
               indx( i ) = indx( j )
               indx( j ) = itmp
               GO TO 100
            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 20
      RETURN
*
*     End of SLAPST
*
      END