slatm6.f

Go to the documentation of this file.

*> \brief \b SLATM6
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA,
*                          BETA, WX, WY, S, DIF )
*
*       .. Scalar Arguments ..
*       INTEGER            LDA, LDX, LDY, N, TYPE
*       REAL               ALPHA, BETA, WX, WY
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), B( LDA, * ), DIF( * ), S( * ),
*      $                   X( LDX, * ), Y( LDY, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLATM6 generates test matrices for the generalized eigenvalue
*> problem, their corresponding right and left eigenvector matrices,
*> and also reciprocal condition numbers for all eigenvalues and
*> the reciprocal condition numbers of eigenvectors corresponding to
*> the 1th and 5th eigenvalues.
*>
*> Test Matrices
*> =============
*>
*> Two kinds of test matrix pairs
*>
*>       (A, B) = inverse(YH) * (Da, Db) * inverse(X)
*>
*> are used in the tests:
*>
*> Type 1:
*>    Da = 1+a   0    0    0    0    Db = 1   0   0   0   0
*>          0   2+a   0    0    0         0   1   0   0   0
*>          0    0   3+a   0    0         0   0   1   0   0
*>          0    0    0   4+a   0         0   0   0   1   0
*>          0    0    0    0   5+a ,      0   0   0   0   1 , and
*>
*> Type 2:
*>    Da =  1   -1    0    0    0    Db = 1   0   0   0   0
*>          1    1    0    0    0         0   1   0   0   0
*>          0    0    1    0    0         0   0   1   0   0
*>          0    0    0   1+a  1+b        0   0   0   1   0
*>          0    0    0  -1-b  1+a ,      0   0   0   0   1 .
*>
*> In both cases the same inverse(YH) and inverse(X) are used to compute
*> (A, B), giving the exact eigenvectors to (A,B) as (YH, X):
*>
*> YH:  =  1    0   -y    y   -y    X =  1   0  -x  -x   x
*>         0    1   -y    y   -y         0   1   x  -x  -x
*>         0    0    1    0    0         0   0   1   0   0
*>         0    0    0    1    0         0   0   0   1   0
*>         0    0    0    0    1,        0   0   0   0   1 ,
*>
*> where a, b, x and y will have all values independently of each other.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TYPE
*> \verbatim
*>          TYPE is INTEGER
*>          Specifies the problem type (see further details).
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          Size of the matrices A and B.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*>          A is REAL array, dimension (LDA, N).
*>          On exit A N-by-N is initialized according to TYPE.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of A and of B.
*> \endverbatim
*>
*> \param[out] B
*> \verbatim
*>          B is REAL array, dimension (LDA, N).
*>          On exit B N-by-N is initialized according to TYPE.
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*>          X is REAL array, dimension (LDX, N).
*>          On exit X is the N-by-N matrix of right eigenvectors.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*>          LDX is INTEGER
*>          The leading dimension of X.
*> \endverbatim
*>
*> \param[out] Y
*> \verbatim
*>          Y is REAL array, dimension (LDY, N).
*>          On exit Y is the N-by-N matrix of left eigenvectors.
*> \endverbatim
*>
*> \param[in] LDY
*> \verbatim
*>          LDY is INTEGER
*>          The leading dimension of Y.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*>          ALPHA is REAL
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*>          BETA is REAL
*>
*>          Weighting constants for matrix A.
*> \endverbatim
*>
*> \param[in] WX
*> \verbatim
*>          WX is REAL
*>          Constant for right eigenvector matrix.
*> \endverbatim
*>
*> \param[in] WY
*> \verbatim
*>          WY is REAL
*>          Constant for left eigenvector matrix.
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*>          S is REAL array, dimension (N)
*>          S(i) is the reciprocal condition number for eigenvalue i.
*> \endverbatim
*>
*> \param[out] DIF
*> \verbatim
*>          DIF is REAL array, dimension (N)
*>          DIF(i) is the reciprocal condition number for eigenvector i.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup real_matgen
*
*  =====================================================================
      SUBROUTINE slatm6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA,
     $                   BETA, WX, WY, S, DIF )
*
*  -- 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 ..
      INTEGER            LDA, LDX, LDY, N, TYPE
      REAL               ALPHA, BETA, WX, WY
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), B( LDA, * ), DIF( * ), S( * ),
     $                   x( ldx, * ), y( ldy, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TWO, THREE
      parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
     $                   three = 3.0e+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, INFO, J
*     ..
*     .. Local Arrays ..
      REAL               WORK( 100 ), Z( 12, 12 )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          real, sqrt
*     ..
*     .. External Subroutines ..
      EXTERNAL           sgesvd, slacpy, slakf2
*     ..
*     .. Executable Statements ..
*
*     Generate test problem ...
*     (Da, Db) ...
*
      DO 20 i = 1, n
         DO 10 j = 1, n
*
            IF( i.EQ.j ) THEN
               a( i, i ) = real( i ) + alpha
               b( i, i ) = one
            ELSE
               a( i, j ) = zero
               b( i, j ) = zero
            END IF
*
   10    CONTINUE
   20 CONTINUE
*
*     Form X and Y
*
      CALL slacpy( 'F', n, n, b, lda, y, ldy )
      y( 3, 1 ) = -wy
      y( 4, 1 ) = wy
      y( 5, 1 ) = -wy
      y( 3, 2 ) = -wy
      y( 4, 2 ) = wy
      y( 5, 2 ) = -wy
*
      CALL slacpy( 'F', n, n, b, lda, x, ldx )
      x( 1, 3 ) = -wx
      x( 1, 4 ) = -wx
      x( 1, 5 ) = wx
      x( 2, 3 ) = wx
      x( 2, 4 ) = -wx
      x( 2, 5 ) = -wx
*
*     Form (A, B)
*
      b( 1, 3 ) = wx + wy
      b( 2, 3 ) = -wx + wy
      b( 1, 4 ) = wx - wy
      b( 2, 4 ) = wx - wy
      b( 1, 5 ) = -wx + wy
      b( 2, 5 ) = wx + wy
      IF( type.EQ.1 ) THEN
         a( 1, 3 ) = wx*a( 1, 1 ) + wy*a( 3, 3 )
         a( 2, 3 ) = -wx*a( 2, 2 ) + wy*a( 3, 3 )
         a( 1, 4 ) = wx*a( 1, 1 ) - wy*a( 4, 4 )
         a( 2, 4 ) = wx*a( 2, 2 ) - wy*a( 4, 4 )
         a( 1, 5 ) = -wx*a( 1, 1 ) + wy*a( 5, 5 )
         a( 2, 5 ) = wx*a( 2, 2 ) + wy*a( 5, 5 )
      ELSE IF( type.EQ.2 ) THEN
         a( 1, 3 ) = two*wx + wy
         a( 2, 3 ) = wy
         a( 1, 4 ) = -wy*( two+alpha+beta )
         a( 2, 4 ) = two*wx - wy*( two+alpha+beta )
         a( 1, 5 ) = -two*wx + wy*( alpha-beta )
         a( 2, 5 ) = wy*( alpha-beta )
         a( 1, 1 ) = one
         a( 1, 2 ) = -one
         a( 2, 1 ) = one
         a( 2, 2 ) = a( 1, 1 )
         a( 3, 3 ) = one
         a( 4, 4 ) = one + alpha
         a( 4, 5 ) = one + beta
         a( 5, 4 ) = -a( 4, 5 )
         a( 5, 5 ) = a( 4, 4 )
      END IF
*
*     Compute condition numbers
*
      IF( type.EQ.1 ) THEN
*
         s( 1 ) = one / sqrt( ( one+three*wy*wy ) /
     $            ( one+a( 1, 1 )*a( 1, 1 ) ) )
         s( 2 ) = one / sqrt( ( one+three*wy*wy ) /
     $            ( one+a( 2, 2 )*a( 2, 2 ) ) )
         s( 3 ) = one / sqrt( ( one+two*wx*wx ) /
     $            ( one+a( 3, 3 )*a( 3, 3 ) ) )
         s( 4 ) = one / sqrt( ( one+two*wx*wx ) /
     $            ( one+a( 4, 4 )*a( 4, 4 ) ) )
         s( 5 ) = one / sqrt( ( one+two*wx*wx ) /
     $            ( one+a( 5, 5 )*a( 5, 5 ) ) )
*
         CALL slakf2( 1, 4, a, lda, a( 2, 2 ), b, b( 2, 2 ), z, 12 )
         CALL sgesvd( 'N', 'N', 8, 8, z, 12, work, work( 9 ), 1,
     $                work( 10 ), 1, work( 11 ), 40, info )
         dif( 1 ) = work( 8 )
*
         CALL slakf2( 4, 1, a, lda, a( 5, 5 ), b, b( 5, 5 ), z, 12 )
         CALL sgesvd( 'N', 'N', 8, 8, z, 12, work, work( 9 ), 1,
     $                work( 10 ), 1, work( 11 ), 40, info )
         dif( 5 ) = work( 8 )
*
      ELSE IF( type.EQ.2 ) THEN
*
         s( 1 ) = one / sqrt( one / three+wy*wy )
         s( 2 ) = s( 1 )
         s( 3 ) = one / sqrt( one / two+wx*wx )
         s( 4 ) = one / sqrt( ( one+two*wx*wx ) /
     $            ( one+( one+alpha )*( one+alpha )+( one+beta )*( one+
     $            beta ) ) )
         s( 5 ) = s( 4 )
*
         CALL slakf2( 2, 3, a, lda, a( 3, 3 ), b, b( 3, 3 ), z, 12 )
         CALL sgesvd( 'N', 'N', 12, 12, z, 12, work, work( 13 ), 1,
     $                work( 14 ), 1, work( 15 ), 60, info )
         dif( 1 ) = work( 12 )
*
         CALL slakf2( 3, 2, a, lda, a( 4, 4 ), b, b( 4, 4 ), z, 12 )
         CALL sgesvd( 'N', 'N', 12, 12, z, 12, work, work( 13 ), 1,
     $                work( 14 ), 1, work( 15 ), 60, info )
         dif( 5 ) = work( 12 )
*
      END IF
*
      RETURN
*
*     End of SLATM6
*
      END