slasorte.f

Go to the documentation of this file.

      SUBROUTINE slasorte( S, LDS, J, OUT, INFO )
*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     December 31, 1998
*
*     .. Scalar Arguments ..
      INTEGER            INFO, J, LDS
*     ..
*     .. Array Arguments ..
      REAL               OUT( J, * ), S( LDS, * )
*     ..
*
*  Purpose
*  =======
*
*  SLASORTE sorts eigenpairs so that real eigenpairs are together and
*    complex are together.  This way one can employ 2x2 shifts easily
*    since every 2nd subdiagonal is guaranteed to be zero.
*  This routine does no parallel work.
*
*  Arguments
*  =========
*
*  S       (local input/output) REAL array, dimension LDS
*          On entry, a matrix already in Schur form.
*          On exit, the diagonal blocks of S have been rewritten to pair
*             the eigenvalues.  The resulting matrix is no longer
*             similar to the input.
*
*  LDS     (local input) INTEGER
*          On entry, the leading dimension of the local array S.
*          Unchanged on exit.
*
*  J       (local input) INTEGER
*          On entry, the order of the matrix S.
*          Unchanged on exit.
*
*  OUT     (local input/output) REAL array, dimension Jx2
*          This is the work buffer required by this routine.
*
*  INFO    (local input) INTEGER
*          This is set if the input matrix had an odd number of real
*          eigenvalues and things couldn't be paired or if the input
*           matrix S was not originally in Schur form.
*          0 indicates successful completion.
*
*  Implemented by:  G. Henry, November 17, 1996
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      parameter( zero = 0.0e+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            BOT, I, LAST, TOP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          mod
*     ..
*     .. Executable Statements ..
*
      last = j
      top = 1
      bot = j
      info = 0
      DO 10 i = j - 1, 1, -1
         IF( s( i+1, i ).EQ.zero ) THEN
            IF( last-i.EQ.2 ) THEN
               out( bot-1, 1 ) = s( i+1, i+1 )
               out( bot, 2 ) = s( i+2, i+2 )
               out( bot-1, 2 ) = s( i+1, i+2 )
               out( bot, 1 ) = s( i+2, i+1 )
               bot = bot - 2
            END IF
            IF( last-i.EQ.1 ) THEN
               IF( mod( top, 2 ).EQ.1 ) THEN
*
*                 FIRST OF A PAIR
*
                  IF( ( i.EQ.j-1 ) .OR. ( i.EQ.1 ) ) THEN
                     out( top, 1 ) = s( i+1, i+1 )
                  ELSE
                     out( top, 1 ) = s( i+1, i+1 )
                  END IF
                  out( top, 2 ) = zero
               ELSE
*
*                 SECOND OF A PAIR
*
                  IF( ( i.EQ.j-1 ) .OR. ( i.EQ.1 ) ) THEN
                     out( top, 2 ) = s( i+1, i+1 )
                  ELSE
                     out( top, 2 ) = s( i+1, i+1 )
                  END IF
                  out( top, 1 ) = zero
               END IF
               top = top + 1
            END IF
            IF( last-i.GT.2 ) THEN
               info = i
               RETURN
            END IF
            last = i
         END IF
   10 CONTINUE
      IF( last.EQ.2 ) THEN
*
*        GRAB LAST DOUBLE PAIR
*
         out( bot-1, 1 ) = s( 1, 1 )
         out( bot, 2 ) = s( 2, 2 )
         out( bot-1, 2 ) = s( 1, 2 )
         out( bot, 1 ) = s( 2, 1 )
         bot = bot - 2
      END IF
      IF( last.EQ.1 .and. mod(top, 2) .eq. 0 ) THEN
*
*        GRAB SECOND PART OF LAST PAIR
*
         out(top, 2) = s(1,1)
         out(top, 1) = zero
         top = top + 1
      END IF
      IF( top-1.NE.bot ) THEN
         info = -bot
         RETURN
      END IF
*
*     Overwrite the S diagonals
*
      DO 20 i = 1, j, 2
         s( i, i ) = out( i, 1 )
         s( i+1, i ) = out( i+1, 1 )
         s( i, i+1 ) = out( i, 2 )
         s( i+1, i+1 ) = out( i+1, 2 )
   20 CONTINUE
*
      RETURN
*
*     End of SLASORTE
*
      END