cget24.f

来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 832 行 · 第 1/2 页

      SUBROUTINE CGET24( COMP, JTYPE, THRESH, ISEED, NOUNIT, N, A, LDA,
     $                   H, HT, W, WT, WTMP, VS, LDVS, VS1, RCDEIN,
     $                   RCDVIN, NSLCT, ISLCT, ISRT, RESULT, WORK,
     $                   LWORK, RWORK, BWORK, INFO )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      LOGICAL            COMP
      INTEGER            INFO, ISRT, JTYPE, LDA, LDVS, LWORK, N, NOUNIT,
     $                   NSLCT
      REAL               RCDEIN, RCDVIN, THRESH
*     ..
*     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            ISEED( 4 ), ISLCT( * )
      REAL               RESULT( 17 ), RWORK( * )
      COMPLEX            A( LDA, * ), H( LDA, * ), HT( LDA, * ),
     $                   VS( LDVS, * ), VS1( LDVS, * ), W( * ),
     $                   WORK( * ), WT( * ), WTMP( * )
*     ..
*
*  Purpose
*  =======
*
*     CGET24 checks the nonsymmetric eigenvalue (Schur form) problem
*     expert driver CGEESX.
*
*     If COMP = .FALSE., the first 13 of the following tests will be
*     be performed on the input matrix A, and also tests 14 and 15
*     if LWORK is sufficiently large.
*     If COMP = .TRUE., all 17 test will be performed.
*
*     (1)     0 if T is in Schur form, 1/ulp otherwise
*            (no sorting of eigenvalues)
*
*     (2)     | A - VS T VS' | / ( n |A| ulp )
*
*       Here VS is the matrix of Schur eigenvectors, and T is in Schur
*       form  (no sorting of eigenvalues).
*
*     (3)     | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
*
*     (4)     0     if W are eigenvalues of T
*             1/ulp otherwise
*             (no sorting of eigenvalues)
*
*     (5)     0     if T(with VS) = T(without VS),
*             1/ulp otherwise
*             (no sorting of eigenvalues)
*
*     (6)     0     if eigenvalues(with VS) = eigenvalues(without VS),
*             1/ulp otherwise
*             (no sorting of eigenvalues)
*
*     (7)     0 if T is in Schur form, 1/ulp otherwise
*             (with sorting of eigenvalues)
*
*     (8)     | A - VS T VS' | / ( n |A| ulp )
*
*       Here VS is the matrix of Schur eigenvectors, and T is in Schur
*       form  (with sorting of eigenvalues).
*
*     (9)     | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
*
*     (10)    0     if W are eigenvalues of T
*             1/ulp otherwise
*             If workspace sufficient, also compare W with and
*             without reciprocal condition numbers
*             (with sorting of eigenvalues)
*
*     (11)    0     if T(with VS) = T(without VS),
*             1/ulp otherwise
*             If workspace sufficient, also compare T with and without
*             reciprocal condition numbers
*             (with sorting of eigenvalues)
*
*     (12)    0     if eigenvalues(with VS) = eigenvalues(without VS),
*             1/ulp otherwise
*             If workspace sufficient, also compare VS with and without
*             reciprocal condition numbers
*             (with sorting of eigenvalues)
*
*     (13)    if sorting worked and SDIM is the number of
*             eigenvalues which were SELECTed
*             If workspace sufficient, also compare SDIM with and
*             without reciprocal condition numbers
*
*     (14)    if RCONDE the same no matter if VS and/or RCONDV computed
*
*     (15)    if RCONDV the same no matter if VS and/or RCONDE computed
*
*     (16)  |RCONDE - RCDEIN| / cond(RCONDE)
*
*        RCONDE is the reciprocal average eigenvalue condition number
*        computed by CGEESX and RCDEIN (the precomputed true value)
*        is supplied as input.  cond(RCONDE) is the condition number
*        of RCONDE, and takes errors in computing RCONDE into account,
*        so that the resulting quantity should be O(ULP). cond(RCONDE)
*        is essentially given by norm(A)/RCONDV.
*
*     (17)  |RCONDV - RCDVIN| / cond(RCONDV)
*
*        RCONDV is the reciprocal right invariant subspace condition
*        number computed by CGEESX and RCDVIN (the precomputed true
*        value) is supplied as input. cond(RCONDV) is the condition
*        number of RCONDV, and takes errors in computing RCONDV into
*        account, so that the resulting quantity should be O(ULP).
*        cond(RCONDV) is essentially given by norm(A)/RCONDE.
*
*  Arguments
*  =========
*
*  COMP    (input) LOGICAL
*          COMP describes which input tests to perform:
*            = .FALSE. if the computed condition numbers are not to
*                      be tested against RCDVIN and RCDEIN
*            = .TRUE.  if they are to be compared
*
*  JTYPE   (input) INTEGER
*          Type of input matrix. Used to label output if error occurs.
*
*  ISEED   (input) INTEGER array, dimension (4)
*          If COMP = .FALSE., the random number generator seed
*          used to produce matrix.
*          If COMP = .TRUE., ISEED(1) = the number of the example.
*          Used to label output if error occurs.
*
*  THRESH  (input) REAL
*          A test will count as "failed" if the "error", computed as
*          described above, exceeds THRESH.  Note that the error
*          is scaled to be O(1), so THRESH should be a reasonably
*          small multiple of 1, e.g., 10 or 100.  In particular,
*          it should not depend on the precision (single vs. double)
*          or the size of the matrix.  It must be at least zero.
*
*  NOUNIT  (input) INTEGER
*          The FORTRAN unit number for printing out error messages
*          (e.g., if a routine returns INFO not equal to 0.)
*
*  N       (input) INTEGER
*          The dimension of A. N must be at least 0.
*
*  A       (input/output) COMPLEX array, dimension (LDA, N)
*          Used to hold the matrix whose eigenvalues are to be
*          computed.
*
*  LDA     (input) INTEGER
*          The leading dimension of A, and H. LDA must be at
*          least 1 and at least N.
*
*  H       (workspace) COMPLEX array, dimension (LDA, N)
*          Another copy of the test matrix A, modified by CGEESX.
*
*  HT      (workspace) COMPLEX array, dimension (LDA, N)
*          Yet another copy of the test matrix A, modified by CGEESX.
*
*  W       (workspace) COMPLEX array, dimension (N)
*          The computed eigenvalues of A.
*
*  WT      (workspace) COMPLEX array, dimension (N)
*          Like W, this array contains the eigenvalues of A,
*          but those computed when CGEESX only computes a partial
*          eigendecomposition, i.e. not Schur vectors
*
*  WTMP    (workspace) COMPLEX array, dimension (N)
*          Like W, this array contains the eigenvalues of A,
*          but sorted by increasing real or imaginary part.
*
*  VS      (workspace) COMPLEX array, dimension (LDVS, N)
*          VS holds the computed Schur vectors.
*
*  LDVS    (input) INTEGER
*          Leading dimension of VS. Must be at least max(1, N).
*
*  VS1     (workspace) COMPLEX array, dimension (LDVS, N)
*          VS1 holds another copy of the computed Schur vectors.
*
*  RCDEIN  (input) REAL
*          When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
*          condition number for the average of selected eigenvalues.
*
*  RCDVIN  (input) REAL
*          When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
*          condition number for the selected right invariant subspace.
*
*  NSLCT   (input) INTEGER
*          When COMP = .TRUE. the number of selected eigenvalues
*          corresponding to the precomputed values RCDEIN and RCDVIN.
*
*  ISLCT   (input) INTEGER array, dimension (NSLCT)
*          When COMP = .TRUE. ISLCT selects the eigenvalues of the
*          input matrix corresponding to the precomputed values RCDEIN
*          and RCDVIN. For I=1, ... ,NSLCT, if ISLCT(I) = J, then the
*          eigenvalue with the J-th largest real or imaginary part is
*          selected. The real part is used if ISRT = 0, and the
*          imaginary part if ISRT = 1.
*          Not referenced if COMP = .FALSE.
*
*  ISRT    (input) INTEGER
*          When COMP = .TRUE., ISRT describes how ISLCT is used to
*          choose a subset of the spectrum.
*          Not referenced if COMP = .FALSE.
*
*  RESULT  (output) REAL array, dimension (17)
*          The values computed by the 17 tests described above.
*          The values are currently limited to 1/ulp, to avoid
*          overflow.
*
*  WORK    (workspace) COMPLEX array, dimension (2*N*N)
*
*  LWORK   (input) INTEGER
*          The number of entries in WORK to be passed to CGEESX. This
*          must be at least 2*N, and N*(N+1)/2 if tests 14--16 are to
*          be performed.
*
*  RWORK   (workspace) REAL array, dimension (N)
*
*  BWORK   (workspace) LOGICAL array, dimension (N)
*
*  INFO    (output) INTEGER
*          If 0,  successful exit.
*          If <0, input parameter -INFO had an incorrect value.
*          If >0, CGEESX returned an error code, the absolute
*                 value of which is returned.
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      REAL               EPSIN
      PARAMETER          ( EPSIN = 5.9605E-8 )
*     ..
*     .. Local Scalars ..
      CHARACTER          SORT
      INTEGER            I, IINFO, ISORT, ITMP, J, KMIN, KNTEIG, RSUB,
     $                   SDIM, SDIM1
      REAL               ANORM, EPS, RCNDE1, RCNDV1, RCONDE, RCONDV,
     $                   SMLNUM, TOL, TOLIN, ULP, ULPINV, V, VRICMP,
     $                   VRIMIN, WNORM
      COMPLEX            CTMP
*     ..
*     .. Local Arrays ..
      INTEGER            IPNT( 20 )
*     ..
*     .. External Functions ..
      LOGICAL            CSLECT
      REAL               CLANGE, SLAMCH
      EXTERNAL           CSLECT, CLANGE, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           CCOPY, CGEESX, CGEMM, CLACPY, CUNT01, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, AIMAG, MAX, MIN, REAL
*     ..
*     .. Arrays in Common ..
      LOGICAL            SELVAL( 20 )
      REAL               SELWI( 20 ), SELWR( 20 )
*     ..
*     .. Scalars in Common ..
      INTEGER            SELDIM, SELOPT
*     ..
*     .. Common blocks ..
      COMMON             / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
*     ..
*     .. Executable Statements ..
*
*     Check for errors
*
      INFO = 0
      IF( THRESH.LT.ZERO ) THEN
         INFO = -3
      ELSE IF( NOUNIT.LE.0 ) THEN
         INFO = -5
      ELSE IF( N.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.1 .OR. LDA.LT.N ) THEN
         INFO = -8
      ELSE IF( LDVS.LT.1 .OR. LDVS.LT.N ) THEN
         INFO = -15
      ELSE IF( LWORK.LT.2*N ) THEN
         INFO = -24
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGET24', -INFO )
         RETURN
      END IF
*
*     Quick return if nothing to do
*
      DO 10 I = 1, 17
         RESULT( I ) = -ONE
   10 CONTINUE
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Important constants
*
      SMLNUM = SLAMCH( 'Safe minimum' )
      ULP = SLAMCH( 'Precision' )
      ULPINV = ONE / ULP
*
*     Perform tests (1)-(13)
*
      SELOPT = 0
      DO 90 ISORT = 0, 1
         IF( ISORT.EQ.0 ) THEN
            SORT = 'N'
            RSUB = 0
         ELSE
            SORT = 'S'
            RSUB = 6
         END IF
*
*        Compute Schur form and Schur vectors, and test them
*
         CALL CLACPY( 'F', N, N, A, LDA, H, LDA )
         CALL CGEESX( 'V', SORT, CSLECT, 'N', N, H, LDA, SDIM, W, VS,
     $                LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, BWORK,
     $                IINFO )
         IF( IINFO.NE.0 ) THEN
            RESULT( 1+RSUB ) = ULPINV
            IF( JTYPE.NE.22 ) THEN
               WRITE( NOUNIT, FMT = 9998 )'CGEESX1', IINFO, N, JTYPE,
     $            ISEED
            ELSE
               WRITE( NOUNIT, FMT = 9999 )'CGEESX1', IINFO, N,
     $            ISEED( 1 )
            END IF
            INFO = ABS( IINFO )
            RETURN
         END IF
         IF( ISORT.EQ.0 ) THEN
            CALL CCOPY( N, W, 1, WTMP, 1 )
         END IF
*
*        Do Test (1) or Test (7)
*
         RESULT( 1+RSUB ) = ZERO
         DO 30 J = 1, N - 1
            DO 20 I = J + 1, N
               IF( H( I, J ).NE.CZERO )
     $            RESULT( 1+RSUB ) = ULPINV
   20       CONTINUE
   30    CONTINUE
*
*        Test (2) or (8): Compute norm(A - Q*H*Q') / (norm(A) * N * ULP)
*
*        Copy A to VS1, used as workspace
*
         CALL CLACPY( ' ', N, N, A, LDA, VS1, LDVS )
*
*        Compute Q*H and store in HT.
*
         CALL CGEMM( 'No transpose', 'No transpose', N, N, N, CONE, VS,
     $               LDVS, H, LDA, CZERO, HT, LDA )
*
*        Compute A - Q*H*Q'
*
         CALL CGEMM( 'No transpose', 'Conjugate transpose', N, N, N,
     $               -CONE, HT, LDA, VS, LDVS, CONE, VS1, LDVS )
*
         ANORM = MAX( CLANGE( '1', N, N, A, LDA, RWORK ), SMLNUM )
         WNORM = CLANGE( '1', N, N, VS1, LDVS, RWORK )
*
         IF( ANORM.GT.WNORM ) THEN
            RESULT( 2+RSUB ) = ( WNORM / ANORM ) / ( N*ULP )
         ELSE
            IF( ANORM.LT.ONE ) THEN
               RESULT( 2+RSUB ) = ( MIN( WNORM, N*ANORM ) / ANORM ) /
     $                            ( N*ULP )
            ELSE
               RESULT( 2+RSUB ) = MIN( WNORM / ANORM, REAL( N ) ) /
     $                            ( N*ULP )
            END IF
         END IF
*
*        Test (3) or (9):  Compute norm( I - Q'*Q ) / ( N * ULP )
*
         CALL CUNT01( 'Columns', N, N, VS, LDVS, WORK, LWORK, RWORK,
     $                RESULT( 3+RSUB ) )
*
*        Do Test (4) or Test (10)
*
         RESULT( 4+RSUB ) = ZERO
         DO 40 I = 1, N
            IF( H( I, I ).NE.W( I ) )
     $         RESULT( 4+RSUB ) = ULPINV
   40    CONTINUE
*
*        Do Test (5) or Test (11)
*
         CALL CLACPY( 'F', N, N, A, LDA, HT, LDA )
         CALL CGEESX( 'N', SORT, CSLECT, 'N', N, HT, LDA, SDIM, WT, VS,
     $                LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, BWORK,
     $                IINFO )
         IF( IINFO.NE.0 ) THEN
            RESULT( 5+RSUB ) = ULPINV
            IF( JTYPE.NE.22 ) THEN
               WRITE( NOUNIT, FMT = 9998 )'CGEESX2', IINFO, N, JTYPE,
     $            ISEED
            ELSE
               WRITE( NOUNIT, FMT = 9999 )'CGEESX2', IINFO, N,
     $            ISEED( 1 )
            END IF
            INFO = ABS( IINFO )
            GO TO 220