ctrevc3.f

Go to the documentation of this file.

*> \brief \b CTREVC3
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> Download CTREVC3 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ctrevc3.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ctrevc3.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ctrevc3.f">
*> [TXT]</a>
*
*  Definition:
*  ===========
*
*       SUBROUTINE CTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
*                           LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO)
*
*       .. Scalar Arguments ..
*       CHARACTER          HOWMNY, SIDE
*       INTEGER            INFO, LDT, LDVL, LDVR, LWORK, M, MM, N
*       ..
*       .. Array Arguments ..
*       LOGICAL            SELECT( * )
*       REAL               RWORK( * )
*       COMPLEX            T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
*      $                   WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CTREVC3 computes some or all of the right and/or left eigenvectors of
*> a complex upper triangular matrix T.
*> Matrices of this type are produced by the Schur factorization of
*> a complex general matrix:  A = Q*T*Q**H, as computed by CHSEQR.
*>
*> The right eigenvector x and the left eigenvector y of T corresponding
*> to an eigenvalue w are defined by:
*>
*>              T*x = w*x,     (y**H)*T = w*(y**H)
*>
*> where y**H denotes the conjugate transpose of the vector y.
*> The eigenvalues are not input to this routine, but are read directly
*> from the diagonal of T.
*>
*> This routine returns the matrices X and/or Y of right and left
*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
*> input matrix. If Q is the unitary factor that reduces a matrix A to
*> Schur form T, then Q*X and Q*Y are the matrices of right and left
*> eigenvectors of A.
*>
*> This uses a Level 3 BLAS version of the back transformation.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] SIDE
*> \verbatim
*>          SIDE is CHARACTER*1
*>          = 'R':  compute right eigenvectors only;
*>          = 'L':  compute left eigenvectors only;
*>          = 'B':  compute both right and left eigenvectors.
*> \endverbatim
*>
*> \param[in] HOWMNY
*> \verbatim
*>          HOWMNY is CHARACTER*1
*>          = 'A':  compute all right and/or left eigenvectors;
*>          = 'B':  compute all right and/or left eigenvectors,
*>                  backtransformed using the matrices supplied in
*>                  VR and/or VL;
*>          = 'S':  compute selected right and/or left eigenvectors,
*>                  as indicated by the logical array SELECT.
*> \endverbatim
*>
*> \param[in] SELECT
*> \verbatim
*>          SELECT is LOGICAL array, dimension (N)
*>          If HOWMNY = 'S', SELECT specifies the eigenvectors to be
*>          computed.
*>          The eigenvector corresponding to the j-th eigenvalue is
*>          computed if SELECT(j) = .TRUE..
*>          Not referenced if HOWMNY = 'A' or 'B'.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix T. N >= 0.
*> \endverbatim
*>
*> \param[in,out] T
*> \verbatim
*>          T is COMPLEX array, dimension (LDT,N)
*>          The upper triangular matrix T.  T is modified, but restored
*>          on exit.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*>          LDT is INTEGER
*>          The leading dimension of the array T. LDT >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] VL
*> \verbatim
*>          VL is COMPLEX array, dimension (LDVL,MM)
*>          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
*>          contain an N-by-N matrix Q (usually the unitary matrix Q of
*>          Schur vectors returned by CHSEQR).
*>          On exit, if SIDE = 'L' or 'B', VL contains:
*>          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
*>          if HOWMNY = 'B', the matrix Q*Y;
*>          if HOWMNY = 'S', the left eigenvectors of T specified by
*>                           SELECT, stored consecutively in the columns
*>                           of VL, in the same order as their
*>                           eigenvalues.
*>          Not referenced if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDVL
*> \verbatim
*>          LDVL is INTEGER
*>          The leading dimension of the array VL.
*>          LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N.
*> \endverbatim
*>
*> \param[in,out] VR
*> \verbatim
*>          VR is COMPLEX array, dimension (LDVR,MM)
*>          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
*>          contain an N-by-N matrix Q (usually the unitary matrix Q of
*>          Schur vectors returned by CHSEQR).
*>          On exit, if SIDE = 'R' or 'B', VR contains:
*>          if HOWMNY = 'A', the matrix X of right eigenvectors of T;
*>          if HOWMNY = 'B', the matrix Q*X;
*>          if HOWMNY = 'S', the right eigenvectors of T specified by
*>                           SELECT, stored consecutively in the columns
*>                           of VR, in the same order as their
*>                           eigenvalues.
*>          Not referenced if SIDE = 'L'.
*> \endverbatim
*>
*> \param[in] LDVR
*> \verbatim
*>          LDVR is INTEGER
*>          The leading dimension of the array VR.
*>          LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N.
*> \endverbatim
*>
*> \param[in] MM
*> \verbatim
*>          MM is INTEGER
*>          The number of columns in the arrays VL and/or VR. MM >= M.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*>          M is INTEGER
*>          The number of columns in the arrays VL and/or VR actually
*>          used to store the eigenvectors.
*>          If HOWMNY = 'A' or 'B', M is set to N.
*>          Each selected eigenvector occupies one column.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of array WORK. LWORK >= max(1,2*N).
*>          For optimum performance, LWORK >= N + 2*N*NB, where NB is
*>          the optimal blocksize.
*>
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension (LRWORK)
*> \endverbatim
*>
*> \param[in] LRWORK
*> \verbatim
*>          LRWORK is INTEGER
*>          The dimension of array RWORK. LRWORK >= max(1,N).
*>
*>          If LRWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the RWORK array, returns
*>          this value as the first entry of the RWORK array, and no error
*>          message related to LRWORK is issued by XERBLA.
*> \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 trevc3
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The algorithm used in this program is basically backward (forward)
*>  substitution, with scaling to make the the code robust against
*>  possible overflow.
*>
*>  Each eigenvector is normalized so that the element of largest
*>  magnitude has magnitude 1; here the magnitude of a complex number
*>  (x,y) is taken to be |x| + |y|.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE ctrevc3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL,
     $                    VR,
     $                    LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO)
      IMPLICIT NONE
*
*  -- 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          HOWMNY, SIDE
      INTEGER            INFO, LDT, LDVL, LDVR, LWORK, LRWORK, M, MM, N
*     ..
*     .. Array Arguments ..
      LOGICAL            SELECT( * )
      REAL               RWORK( * )
      COMPLEX            T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
     $                   work( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0e+0, one = 1.0e+0 )
      COMPLEX            CZERO, CONE
      parameter( czero = ( 0.0e+0, 0.0e+0 ),
     $                     cone  = ( 1.0e+0, 0.0e+0 ) )
      INTEGER            NBMIN, NBMAX
      PARAMETER          ( NBMIN = 8, nbmax = 128 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ALLV, BOTHV, LEFTV, LQUERY, OVER, RIGHTV, SOMEV
      INTEGER            I, II, IS, J, K, KI, IV, MAXWRK, NB
      REAL               OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
      COMPLEX            CDUM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV, ICAMAX
      REAL               SLAMCH, SCASUM, SROUNDUP_LWORK
      EXTERNAL           lsame, ilaenv, icamax, slamch, scasum,
     $                   sroundup_lwork
*     ..
*     .. External Subroutines ..
      EXTERNAL           xerbla, ccopy, claset, csscal, cgemm,
     $                   cgemv,
     $                   clatrs, clacpy
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, real, cmplx, conjg, aimag, max
*     ..
*     .. Statement Functions ..
      REAL   CABS1
*     ..
*     .. Statement Function definitions ..
      cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) )
*     ..
*     .. Executable Statements ..
*
*     Decode and test the input parameters
*
      bothv  = lsame( side, 'B' )
      rightv = lsame( side, 'R' ) .OR. bothv
      leftv  = lsame( side, 'L' ) .OR. bothv
*
      allv  = lsame( howmny, 'A' )
      over  = lsame( howmny, 'B' )
      somev = lsame( howmny, 'S' )
*
*     Set M to the number of columns required to store the selected
*     eigenvectors.
*
      IF( somev ) THEN
         m = 0
         DO 10 j = 1, n
            IF( SELECT( j ) )
     $         m = m + 1
   10    CONTINUE
      ELSE
         m = n
      END IF
*
      info = 0
      nb = ilaenv( 1, 'CTREVC', side // howmny, n, -1, -1, -1 )
      maxwrk = max( 1, n + 2*n*nb )
      work(1) = sroundup_lwork(maxwrk)
      rwork(1) = real( max( 1, n ) )
      lquery = ( lwork.EQ.-1 .OR. lrwork.EQ.-1 )
      IF( .NOT.rightv .AND. .NOT.leftv ) THEN
         info = -1
      ELSE IF( .NOT.allv .AND. .NOT.over .AND. .NOT.somev ) THEN
         info = -2
      ELSE IF( n.LT.0 ) THEN
         info = -4
      ELSE IF( ldt.LT.max( 1, n ) ) THEN
         info = -6
      ELSE IF( ldvl.LT.1 .OR. ( leftv .AND. ldvl.LT.n ) ) THEN
         info = -8
      ELSE IF( ldvr.LT.1 .OR. ( rightv .AND. ldvr.LT.n ) ) THEN
         info = -10
      ELSE IF( mm.LT.m ) THEN
         info = -11
      ELSE IF( lwork.LT.max( 1, 2*n ) .AND. .NOT.lquery ) THEN
         info = -14
      ELSE IF ( lrwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
         info = -16
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'CTREVC3', -info )
         RETURN
      ELSE IF( lquery ) THEN
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( n.EQ.0 )
     $   RETURN
*
*     Use blocked version of back-transformation if sufficient workspace.
*     Zero-out the workspace to avoid potential NaN propagation.
*
      IF( over .AND. lwork .GE. n + 2*n*nbmin ) THEN
         nb = (lwork - n) / (2*n)
         nb = min( nb, nbmax )
         CALL claset( 'F', n, 1+2*nb, czero, czero, work, n )
      ELSE
         nb = 1
      END IF
*
*     Set the constants to control overflow.
*
      unfl = slamch( 'Safe minimum' )
      ovfl = one / unfl
      ulp = slamch( 'Precision' )
      smlnum = unfl*( real( n ) / ulp )
*
*     Store the diagonal elements of T in working array WORK.
*
      DO 20 i = 1, n
         work( i ) = t( i, i )
   20 CONTINUE
*
*     Compute 1-norm of each column of strictly upper triangular
*     part of T to control overflow in triangular solver.
*
      rwork( 1 ) = zero
      DO 30 j = 2, n
         rwork( j ) = scasum( j-1, t( 1, j ), 1 )
   30 CONTINUE
*
      IF( rightv ) THEN
*
*        ============================================================
*        Compute right eigenvectors.
*
*        IV is index of column in current block.
*        Non-blocked version always uses IV=NB=1;
*        blocked     version starts with IV=NB, goes down to 1.
*        (Note the "0-th" column is used to store the original diagonal.)
         iv = nb
         is = m
         DO 80 ki = n, 1, -1
            IF( somev ) THEN
               IF( .NOT.SELECT( ki ) )
     $            GO TO 80
            END IF
            smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
*
*           --------------------------------------------------------
*           Complex right eigenvector
*
            work( ki + iv*n ) = cone
*
*           Form right-hand side.
*
            DO 40 k = 1, ki - 1
               work( k + iv*n ) = -t( k, ki )
   40       CONTINUE
*
*           Solve upper triangular system:
*           [ T(1:KI-1,1:KI-1) - T(KI,KI) ]*X = SCALE*WORK.
*
            DO 50 k = 1, ki - 1
               t( k, k ) = t( k, k ) - t( ki, ki )
               IF( cabs1( t( k, k ) ).LT.smin )
     $            t( k, k ) = smin
   50       CONTINUE
*
            IF( ki.GT.1 ) THEN
               CALL clatrs( 'Upper', 'No transpose', 'Non-unit', 'Y',
     $                      ki-1, t, ldt, work( 1 + iv*n ), scale,
     $                      rwork, info )
               work( ki + iv*n ) = scale
            END IF
*
*           Copy the vector x or Q*x to VR and normalize.
*
            IF( .NOT.over ) THEN
*              ------------------------------
*              no back-transform: copy x to VR and normalize.
               CALL ccopy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 )
*
               ii = icamax( ki, vr( 1, is ), 1 )
               remax = one / cabs1( vr( ii, is ) )
               CALL csscal( ki, remax, vr( 1, is ), 1 )
*
               DO 60 k = ki + 1, n
                  vr( k, is ) = czero
   60          CONTINUE
*
            ELSE IF( nb.EQ.1 ) THEN
*              ------------------------------
*              version 1: back-transform each vector with GEMV, Q*x.
               IF( ki.GT.1 )
     $            CALL cgemv( 'N', n, ki-1, cone, vr, ldvr,
     $                        work( 1 + iv*n ), 1, cmplx( scale ),
     $                        vr( 1, ki ), 1 )
*
               ii = icamax( n, vr( 1, ki ), 1 )
               remax = one / cabs1( vr( ii, ki ) )
               CALL csscal( n, remax, vr( 1, ki ), 1 )
*
            ELSE
*              ------------------------------
*              version 2: back-transform block of vectors with GEMM
*              zero out below vector
               DO k = ki + 1, n
                  work( k + iv*n ) = czero
               END DO
*
*              Columns IV:NB of work are valid vectors.
*              When the number of vectors stored reaches NB,
*              or if this was last vector, do the GEMM
               IF( (iv.EQ.1) .OR. (ki.EQ.1) ) THEN
                  CALL cgemm( 'N', 'N', n, nb-iv+1, ki+nb-iv, cone,
     $                        vr, ldvr,
     $                        work( 1 + (iv)*n    ), n,
     $                        czero,
     $                        work( 1 + (nb+iv)*n ), n )
*                 normalize vectors
                  DO k = iv, nb
                     ii = icamax( n, work( 1 + (nb+k)*n ), 1 )
                     remax = one / cabs1( work( ii + (nb+k)*n ) )
                     CALL csscal( n, remax, work( 1 + (nb+k)*n ), 1 )
                  END DO
                  CALL clacpy( 'F', n, nb-iv+1,
     $                         work( 1 + (nb+iv)*n ), n,
     $                         vr( 1, ki ), ldvr )
                  iv = nb
               ELSE
                  iv = iv - 1
               END IF
            END IF
*
*           Restore the original diagonal elements of T.
*
            DO 70 k = 1, ki - 1
               t( k, k ) = work( k )
   70       CONTINUE
*
            is = is - 1
   80    CONTINUE
      END IF
*
      IF( leftv ) THEN
*
*        ============================================================
*        Compute left eigenvectors.
*
*        IV is index of column in current block.
*        Non-blocked version always uses IV=1;
*        blocked     version starts with IV=1, goes up to NB.
*        (Note the "0-th" column is used to store the original diagonal.)
         iv = 1
         is = 1
         DO 130 ki = 1, n
*
            IF( somev ) THEN
               IF( .NOT.SELECT( ki ) )
     $            GO TO 130
            END IF
            smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
*
*           --------------------------------------------------------
*           Complex left eigenvector
*
            work( ki + iv*n ) = cone
*
*           Form right-hand side.
*
            DO 90 k = ki + 1, n
               work( k + iv*n ) = -conjg( t( ki, k ) )
   90       CONTINUE
*
*           Solve conjugate-transposed triangular system:
*           [ T(KI+1:N,KI+1:N) - T(KI,KI) ]**H * X = SCALE*WORK.
*
            DO 100 k = ki + 1, n
               t( k, k ) = t( k, k ) - t( ki, ki )
               IF( cabs1( t( k, k ) ).LT.smin )
     $            t( k, k ) = smin
  100       CONTINUE
*
            IF( ki.LT.n ) THEN
               CALL clatrs( 'Upper', 'Conjugate transpose',
     $                      'Non-unit',
     $                      'Y', n-ki, t( ki+1, ki+1 ), ldt,
     $                      work( ki+1 + iv*n ), scale, rwork, info )
               work( ki + iv*n ) = scale
            END IF
*
*           Copy the vector x or Q*x to VL and normalize.
*
            IF( .NOT.over ) THEN
*              ------------------------------
*              no back-transform: copy x to VL and normalize.
               CALL ccopy( n-ki+1, work( ki + iv*n ), 1, vl(ki,is),
     $                     1 )
*
               ii = icamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1
               remax = one / cabs1( vl( ii, is ) )
               CALL csscal( n-ki+1, remax, vl( ki, is ), 1 )
*
               DO 110 k = 1, ki - 1
                  vl( k, is ) = czero
  110          CONTINUE
*
            ELSE IF( nb.EQ.1 ) THEN
*              ------------------------------
*              version 1: back-transform each vector with GEMV, Q*x.
               IF( ki.LT.n )
     $            CALL cgemv( 'N', n, n-ki, cone, vl( 1, ki+1 ),
     $                        ldvl,
     $                        work( ki+1 + iv*n ), 1, cmplx( scale ),
     $                        vl( 1, ki ), 1 )
*
               ii = icamax( n, vl( 1, ki ), 1 )
               remax = one / cabs1( vl( ii, ki ) )
               CALL csscal( n, remax, vl( 1, ki ), 1 )
*
            ELSE
*              ------------------------------
*              version 2: back-transform block of vectors with GEMM
*              zero out above vector
*              could go from KI-NV+1 to KI-1
               DO k = 1, ki - 1
                  work( k + iv*n ) = czero
               END DO
*
*              Columns 1:IV of work are valid vectors.
*              When the number of vectors stored reaches NB,
*              or if this was last vector, do the GEMM
               IF( (iv.EQ.nb) .OR. (ki.EQ.n) ) THEN
                  CALL cgemm( 'N', 'N', n, iv, n-ki+iv, cone,
     $                        vl( 1, ki-iv+1 ), ldvl,
     $                        work( ki-iv+1 + (1)*n ), n,
     $                        czero,
     $                        work( 1 + (nb+1)*n ), n )
*                 normalize vectors
                  DO k = 1, iv
                     ii = icamax( n, work( 1 + (nb+k)*n ), 1 )
                     remax = one / cabs1( work( ii + (nb+k)*n ) )
                     CALL csscal( n, remax, work( 1 + (nb+k)*n ), 1 )
                  END DO
                  CALL clacpy( 'F', n, iv,
     $                         work( 1 + (nb+1)*n ), n,
     $                         vl( 1, ki-iv+1 ), ldvl )
                  iv = 1
               ELSE
                  iv = iv + 1
               END IF
            END IF
*
*           Restore the original diagonal elements of T.
*
            DO 120 k = ki + 1, n
               t( k, k ) = work( k )
  120       CONTINUE
*
            is = is + 1
  130    CONTINUE
      END IF
*
      RETURN
*
*     End of CTREVC3
*
      END