sget37.f

Go to the documentation of this file.

*> \brief \b SGET37
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at 
*            http://www.netlib.org/lapack/explore-html/ 
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGET37( RMAX, LMAX, NINFO, KNT, NIN )
* 
*       .. Scalar Arguments ..
*       INTEGER            KNT, NIN
*       ..
*       .. Array Arguments ..
*       INTEGER            LMAX( 3 ), NINFO( 3 )
*       REAL               RMAX( 3 )
*       ..
*  
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGET37 tests STRSNA, a routine for estimating condition numbers of
*> eigenvalues and/or right eigenvectors of a matrix.
*>
*> The test matrices are read from a file with logical unit number NIN.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[out] RMAX
*> \verbatim
*>          RMAX is REAL array, dimension (3)
*>          Value of the largest test ratio.
*>          RMAX(1) = largest ratio comparing different calls to STRSNA
*>          RMAX(2) = largest error in reciprocal condition
*>                    numbers taking their conditioning into account
*>          RMAX(3) = largest error in reciprocal condition
*>                    numbers not taking their conditioning into
*>                    account (may be larger than RMAX(2))
*> \endverbatim
*>
*> \param[out] LMAX
*> \verbatim
*>          LMAX is INTEGER array, dimension (3)
*>          LMAX(i) is example number where largest test ratio
*>          RMAX(i) is achieved. Also:
*>          If SGEHRD returns INFO nonzero on example i, LMAX(1)=i
*>          If SHSEQR returns INFO nonzero on example i, LMAX(2)=i
*>          If STRSNA returns INFO nonzero on example i, LMAX(3)=i
*> \endverbatim
*>
*> \param[out] NINFO
*> \verbatim
*>          NINFO is INTEGER array, dimension (3)
*>          NINFO(1) = No. of times SGEHRD returned INFO nonzero
*>          NINFO(2) = No. of times SHSEQR returned INFO nonzero
*>          NINFO(3) = No. of times STRSNA returned INFO nonzero
*> \endverbatim
*>
*> \param[out] KNT
*> \verbatim
*>          KNT is INTEGER
*>          Total number of examples tested.
*> \endverbatim
*>
*> \param[in] NIN
*> \verbatim
*>          NIN is INTEGER
*>          Input logical unit number
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee 
*> \author Univ. of California Berkeley 
*> \author Univ. of Colorado Denver 
*> \author NAG Ltd. 
*
*> \date November 2011
*
*> \ingroup single_eig
*
*  =====================================================================
      SUBROUTINE sget37( RMAX, LMAX, NINFO, KNT, NIN )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            KNT, NIN
*     ..
*     .. Array Arguments ..
      INTEGER            LMAX( 3 ), NINFO( 3 )
      REAL               RMAX( 3 )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TWO
      parameter                ( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
      REAL               EPSIN
      parameter                ( epsin = 5.9605e-8 )
      INTEGER            LDT, LWORK
      parameter                ( ldt = 20, lwork = 2*ldt*( 10+ldt ) )
*     ..
*     .. Local Scalars ..
      INTEGER            I, ICMP, IFND, INFO, ISCL, J, KMIN, M, N
      REAL               BIGNUM, EPS, SMLNUM, TNRM, TOL, TOLIN, V,
     $                   vimin, vmax, vmul, vrmin
*     ..
*     .. Local Arrays ..
      LOGICAL            SELECT( ldt )
      INTEGER            IWORK( 2*ldt ), LCMP( 3 )
      REAL               DUM( 1 ), LE( ldt, ldt ), RE( ldt, ldt ),
     $                   s( ldt ), sep( ldt ), sepin( ldt ),
     $                   septmp( ldt ), sin( ldt ), stmp( ldt ),
     $                   t( ldt, ldt ), tmp( ldt, ldt ), val( 3 ),
     $                   wi( ldt ), wiin( ldt ), witmp( ldt ),
     $                   work( lwork ), wr( ldt ), wrin( ldt ),
     $                   wrtmp( ldt )
*     ..
*     .. External Functions ..
      REAL               SLAMCH, SLANGE
      EXTERNAL           slamch, slange
*     ..
*     .. External Subroutines ..
      EXTERNAL           scopy, sgehrd, shseqr, slabad, slacpy, sscal,
     $                   strevc, strsna
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max, REAL, SQRT
*     ..
*     .. Executable Statements ..
*
      eps = slamch( 'P' )
      smlnum = slamch( 'S' ) / eps
      bignum = one / smlnum
      CALL slabad( smlnum, bignum )
*
*     EPSIN = 2**(-24) = precision to which input data computed
*
      eps = max( eps, epsin )
      rmax( 1 ) = zero
      rmax( 2 ) = zero
      rmax( 3 ) = zero
      lmax( 1 ) = 0
      lmax( 2 ) = 0
      lmax( 3 ) = 0
      knt = 0
      ninfo( 1 ) = 0
      ninfo( 2 ) = 0
      ninfo( 3 ) = 0
*
      val( 1 ) = sqrt( smlnum )
      val( 2 ) = one
      val( 3 ) = sqrt( bignum )
*
*     Read input data until N=0.  Assume input eigenvalues are sorted
*     lexicographically (increasing by real part, then decreasing by
*     imaginary part)
*
   10 CONTINUE
      READ( nin, fmt = * )n
      IF( n.EQ.0 )
     $   RETURN
      DO 20 i = 1, n
         READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
   20 CONTINUE
      DO 30 i = 1, n
         READ( nin, fmt = * )wrin( i ), wiin( i ), sin( i ), sepin( i )
   30 CONTINUE
      tnrm = slange( 'M', n, n, tmp, ldt, work )
*
*     Begin test
*
      DO 240 iscl = 1, 3
*
*        Scale input matrix
*
         knt = knt + 1
         CALL slacpy( 'F', n, n, tmp, ldt, t, ldt )
         vmul = val( iscl )
         DO 40 i = 1, n
            CALL sscal( n, vmul, t( 1, i ), 1 )
   40    CONTINUE
         IF( tnrm.EQ.zero )
     $      vmul = one
*
*        Compute eigenvalues and eigenvectors
*
         CALL sgehrd( n, 1, n, t, ldt, work( 1 ), work( n+1 ), lwork-n,
     $                info )
         IF( info.NE.0 ) THEN
            lmax( 1 ) = knt
            ninfo( 1 ) = ninfo( 1 ) + 1
            GO TO 240
         END IF
         DO 60 j = 1, n - 2
            DO 50 i = j + 2, n
               t( i, j ) = zero
   50       CONTINUE
   60    CONTINUE
*
*        Compute Schur form
*
         CALL shseqr( 'S', 'N', n, 1, n, t, ldt, wr, wi, dum, 1, work,
     $                lwork, info )
         IF( info.NE.0 ) THEN
            lmax( 2 ) = knt
            ninfo( 2 ) = ninfo( 2 ) + 1
            GO TO 240
         END IF
*
*        Compute eigenvectors
*
         CALL strevc( 'Both', 'All', SELECT, n, t, ldt, le, ldt, re,
     $                ldt, n, m, work, info )
*
*        Compute condition numbers
*
         CALL strsna( 'Both', 'All', SELECT, n, t, ldt, le, ldt, re,
     $                ldt, s, sep, n, m, work, n, iwork, info )
         IF( info.NE.0 ) THEN
            lmax( 3 ) = knt
            ninfo( 3 ) = ninfo( 3 ) + 1
            GO TO 240
         END IF
*
*        Sort eigenvalues and condition numbers lexicographically
*        to compare with inputs
*
         CALL scopy( n, wr, 1, wrtmp, 1 )
         CALL scopy( n, wi, 1, witmp, 1 )
         CALL scopy( n, s, 1, stmp, 1 )
         CALL scopy( n, sep, 1, septmp, 1 )
         CALL sscal( n, one / vmul, septmp, 1 )
         DO 80 i = 1, n - 1
            kmin = i
            vrmin = wrtmp( i )
            vimin = witmp( i )
            DO 70 j = i + 1, n
               IF( wrtmp( j ).LT.vrmin ) THEN
                  kmin = j
                  vrmin = wrtmp( j )
                  vimin = witmp( j )
               END IF
   70       CONTINUE
            wrtmp( kmin ) = wrtmp( i )
            witmp( kmin ) = witmp( i )
            wrtmp( i ) = vrmin
            witmp( i ) = vimin
            vrmin = stmp( kmin )
            stmp( kmin ) = stmp( i )
            stmp( i ) = vrmin
            vrmin = septmp( kmin )
            septmp( kmin ) = septmp( i )
            septmp( i ) = vrmin
   80    CONTINUE
*
*        Compare condition numbers for eigenvalues
*        taking their condition numbers into account
*
         v = max( two*REAL( n )*EPS*TNRM, SMLNUM )
         IF( tnrm.EQ.zero )
     $      v = one
         DO 90 i = 1, n
            IF( v.GT.septmp( i ) ) THEN
               tol = one
            ELSE
               tol = v / septmp( i )
            END IF
            IF( v.GT.sepin( i ) ) THEN
               tolin = one
            ELSE
               tolin = v / sepin( i )
            END IF
            tol = max( tol, smlnum / eps )
            tolin = max( tolin, smlnum / eps )
            IF( eps*( sin( i )-tolin ).GT.stmp( i )+tol ) THEN
               vmax = one / eps
            ELSE IF( sin( i )-tolin.GT.stmp( i )+tol ) THEN
               vmax = ( sin( i )-tolin ) / ( stmp( i )+tol )
            ELSE IF( sin( i )+tolin.LT.eps*( stmp( i )-tol ) ) THEN
               vmax = one / eps
            ELSE IF( sin( i )+tolin.LT.stmp( i )-tol ) THEN
               vmax = ( stmp( i )-tol ) / ( sin( i )+tolin )
            ELSE
               vmax = one
            END IF
            IF( vmax.GT.rmax( 2 ) ) THEN
               rmax( 2 ) = vmax
               IF( ninfo( 2 ).EQ.0 )
     $            lmax( 2 ) = knt
            END IF
   90    CONTINUE
*
*        Compare condition numbers for eigenvectors
*        taking their condition numbers into account
*
         DO 100 i = 1, n
            IF( v.GT.septmp( i )*stmp( i ) ) THEN
               tol = septmp( i )
            ELSE
               tol = v / stmp( i )
            END IF
            IF( v.GT.sepin( i )*sin( i ) ) THEN
               tolin = sepin( i )
            ELSE
               tolin = v / sin( i )
            END IF
            tol = max( tol, smlnum / eps )
            tolin = max( tolin, smlnum / eps )
            IF( eps*( sepin( i )-tolin ).GT.septmp( i )+tol ) THEN
               vmax = one / eps
            ELSE IF( sepin( i )-tolin.GT.septmp( i )+tol ) THEN
               vmax = ( sepin( i )-tolin ) / ( septmp( i )+tol )
            ELSE IF( sepin( i )+tolin.LT.eps*( septmp( i )-tol ) ) THEN
               vmax = one / eps
            ELSE IF( sepin( i )+tolin.LT.septmp( i )-tol ) THEN
               vmax = ( septmp( i )-tol ) / ( sepin( i )+tolin )
            ELSE
               vmax = one
            END IF
            IF( vmax.GT.rmax( 2 ) ) THEN
               rmax( 2 ) = vmax
               IF( ninfo( 2 ).EQ.0 )
     $            lmax( 2 ) = knt
            END IF
  100    CONTINUE
*
*        Compare condition numbers for eigenvalues
*        without taking their condition numbers into account
*
         DO 110 i = 1, n
            IF( sin( i ).LE.REAL( 2*n )*EPS .AND. STMP( i ).LE.
     $          REAL( 2*n )*EPS ) then
               vmax = one
            ELSE IF( eps*sin( i ).GT.stmp( i ) ) THEN
               vmax = one / eps
            ELSE IF( sin( i ).GT.stmp( i ) ) THEN
               vmax = sin( i ) / stmp( i )
            ELSE IF( sin( i ).LT.eps*stmp( i ) ) THEN
               vmax = one / eps
            ELSE IF( sin( i ).LT.stmp( i ) ) THEN
               vmax = stmp( i ) / sin( i )
            ELSE
               vmax = one
            END IF
            IF( vmax.GT.rmax( 3 ) ) THEN
               rmax( 3 ) = vmax
               IF( ninfo( 3 ).EQ.0 )
     $            lmax( 3 ) = knt
            END IF
  110    CONTINUE
*
*        Compare condition numbers for eigenvectors
*        without taking their condition numbers into account
*
         DO 120 i = 1, n
            IF( sepin( i ).LE.v .AND. septmp( i ).LE.v ) THEN
               vmax = one
            ELSE IF( eps*sepin( i ).GT.septmp( i ) ) THEN
               vmax = one / eps
            ELSE IF( sepin( i ).GT.septmp( i ) ) THEN
               vmax = sepin( i ) / septmp( i )
            ELSE IF( sepin( i ).LT.eps*septmp( i ) ) THEN
               vmax = one / eps
            ELSE IF( sepin( i ).LT.septmp( i ) ) THEN
               vmax = septmp( i ) / sepin( i )
            ELSE
               vmax = one
            END IF
            IF( vmax.GT.rmax( 3 ) ) THEN
               rmax( 3 ) = vmax
               IF( ninfo( 3 ).EQ.0 )
     $            lmax( 3 ) = knt
            END IF
  120    CONTINUE
*
*        Compute eigenvalue condition numbers only and compare
*
         vmax = zero
         dum( 1 ) = -one
         CALL scopy( n, dum, 0, stmp, 1 )
         CALL scopy( n, dum, 0, septmp, 1 )
         CALL strsna( 'Eigcond', 'All', SELECT, n, t, ldt, le, ldt, re,
     $                ldt, stmp, septmp, n, m, work, n, iwork, info )
         IF( info.NE.0 ) THEN
            lmax( 3 ) = knt
            ninfo( 3 ) = ninfo( 3 ) + 1
            GO TO 240
         END IF
         DO 130 i = 1, n
            IF( stmp( i ).NE.s( i ) )
     $         vmax = one / eps
            IF( septmp( i ).NE.dum( 1 ) )
     $         vmax = one / eps
  130    CONTINUE
*
*        Compute eigenvector condition numbers only and compare
*
         CALL scopy( n, dum, 0, stmp, 1 )
         CALL scopy( n, dum, 0, septmp, 1 )
         CALL strsna( 'Veccond', 'All', SELECT, n, t, ldt, le, ldt, re,
     $                ldt, stmp, septmp, n, m, work, n, iwork, info )
         IF( info.NE.0 ) THEN
            lmax( 3 ) = knt
            ninfo( 3 ) = ninfo( 3 ) + 1
            GO TO 240
         END IF
         DO 140 i = 1, n
            IF( stmp( i ).NE.dum( 1 ) )
     $         vmax = one / eps
            IF( septmp( i ).NE.sep( i ) )
     $         vmax = one / eps
  140    CONTINUE
*
*        Compute all condition numbers using SELECT and compare
*
         DO 150 i = 1, n
            SELECT( i ) = .true.
  150    CONTINUE
         CALL scopy( n, dum, 0, stmp, 1 )
         CALL scopy( n, dum, 0, septmp, 1 )
         CALL strsna( 'Bothcond', 'Some', SELECT, n, t, ldt, le, ldt,
     $                re, ldt, stmp, septmp, n, m, work, n, iwork,
     $                info )
         IF( info.NE.0 ) THEN
            lmax( 3 ) = knt
            ninfo( 3 ) = ninfo( 3 ) + 1
            GO TO 240
         END IF
         DO 160 i = 1, n
            IF( septmp( i ).NE.sep( i ) )
     $         vmax = one / eps
            IF( stmp( i ).NE.s( i ) )
     $         vmax = one / eps
  160    CONTINUE
*
*        Compute eigenvalue condition numbers using SELECT and compare
*
         CALL scopy( n, dum, 0, stmp, 1 )
         CALL scopy( n, dum, 0, septmp, 1 )
         CALL strsna( 'Eigcond', 'Some', SELECT, n, t, ldt, le, ldt, re,
     $                ldt, stmp, septmp, n, m, work, n, iwork, info )
         IF( info.NE.0 ) THEN
            lmax( 3 ) = knt
            ninfo( 3 ) = ninfo( 3 ) + 1
            GO TO 240
         END IF
         DO 170 i = 1, n
            IF( stmp( i ).NE.s( i ) )
     $         vmax = one / eps
            IF( septmp( i ).NE.dum( 1 ) )
     $         vmax = one / eps
  170    CONTINUE
*
*        Compute eigenvector condition numbers using SELECT and compare
*
         CALL scopy( n, dum, 0, stmp, 1 )
         CALL scopy( n, dum, 0, septmp, 1 )
         CALL strsna( 'Veccond', 'Some', SELECT, n, t, ldt, le, ldt, re,
     $                ldt, stmp, septmp, n, m, work, n, iwork, info )
         IF( info.NE.0 ) THEN
            lmax( 3 ) = knt
            ninfo( 3 ) = ninfo( 3 ) + 1
            GO TO 240
         END IF
         DO 180 i = 1, n
            IF( stmp( i ).NE.dum( 1 ) )
     $         vmax = one / eps
            IF( septmp( i ).NE.sep( i ) )
     $         vmax = one / eps
  180    CONTINUE
         IF( vmax.GT.rmax( 1 ) ) THEN
            rmax( 1 ) = vmax
            IF( ninfo( 1 ).EQ.0 )
     $         lmax( 1 ) = knt
         END IF
*
*        Select first real and first complex eigenvalue
*
         IF( wi( 1 ).EQ.zero ) THEN
            lcmp( 1 ) = 1
            ifnd = 0
            DO 190 i = 2, n
               IF( ifnd.EQ.1 .OR. wi( i ).EQ.zero ) THEN
                  SELECT( i ) = .false.
               ELSE
                  ifnd = 1
                  lcmp( 2 ) = i
                  lcmp( 3 ) = i + 1
                  CALL scopy( n, re( 1, i ), 1, re( 1, 2 ), 1 )
                  CALL scopy( n, re( 1, i+1 ), 1, re( 1, 3 ), 1 )
                  CALL scopy( n, le( 1, i ), 1, le( 1, 2 ), 1 )
                  CALL scopy( n, le( 1, i+1 ), 1, le( 1, 3 ), 1 )
               END IF
  190       CONTINUE
            IF( ifnd.EQ.0 ) THEN
               icmp = 1
            ELSE
               icmp = 3
            END IF
         ELSE
            lcmp( 1 ) = 1
            lcmp( 2 ) = 2
            ifnd = 0
            DO 200 i = 3, n
               IF( ifnd.EQ.1 .OR. wi( i ).NE.zero ) THEN
                  SELECT( i ) = .false.
               ELSE
                  lcmp( 3 ) = i
                  ifnd = 1
                  CALL scopy( n, re( 1, i ), 1, re( 1, 3 ), 1 )
                  CALL scopy( n, le( 1, i ), 1, le( 1, 3 ), 1 )
               END IF
  200       CONTINUE
            IF( ifnd.EQ.0 ) THEN
               icmp = 2
            ELSE
               icmp = 3
            END IF
         END IF
*
*        Compute all selected condition numbers
*
         CALL scopy( icmp, dum, 0, stmp, 1 )
         CALL scopy( icmp, dum, 0, septmp, 1 )
         CALL strsna( 'Bothcond', 'Some', SELECT, n, t, ldt, le, ldt,
     $                re, ldt, stmp, septmp, n, m, work, n, iwork,
     $                info )
         IF( info.NE.0 ) THEN
            lmax( 3 ) = knt
            ninfo( 3 ) = ninfo( 3 ) + 1
            GO TO 240
         END IF
         DO 210 i = 1, icmp
            j = lcmp( i )
            IF( septmp( i ).NE.sep( j ) )
     $         vmax = one / eps
            IF( stmp( i ).NE.s( j ) )
     $         vmax = one / eps
  210    CONTINUE
*
*        Compute selected eigenvalue condition numbers
*
         CALL scopy( icmp, dum, 0, stmp, 1 )
         CALL scopy( icmp, dum, 0, septmp, 1 )
         CALL strsna( 'Eigcond', 'Some', SELECT, n, t, ldt, le, ldt, re,
     $                ldt, stmp, septmp, n, m, work, n, iwork, info )
         IF( info.NE.0 ) THEN
            lmax( 3 ) = knt
            ninfo( 3 ) = ninfo( 3 ) + 1
            GO TO 240
         END IF
         DO 220 i = 1, icmp
            j = lcmp( i )
            IF( stmp( i ).NE.s( j ) )
     $         vmax = one / eps
            IF( septmp( i ).NE.dum( 1 ) )
     $         vmax = one / eps
  220    CONTINUE
*
*        Compute selected eigenvector condition numbers
*
         CALL scopy( icmp, dum, 0, stmp, 1 )
         CALL scopy( icmp, dum, 0, septmp, 1 )
         CALL strsna( 'Veccond', 'Some', SELECT, n, t, ldt, le, ldt, re,
     $                ldt, stmp, septmp, n, m, work, n, iwork, info )
         IF( info.NE.0 ) THEN
            lmax( 3 ) = knt
            ninfo( 3 ) = ninfo( 3 ) + 1
            GO TO 240
         END IF
         DO 230 i = 1, icmp
            j = lcmp( i )
            IF( stmp( i ).NE.dum( 1 ) )
     $         vmax = one / eps
            IF( septmp( i ).NE.sep( j ) )
     $         vmax = one / eps
  230    CONTINUE
         IF( vmax.GT.rmax( 1 ) ) THEN
            rmax( 1 ) = vmax
            IF( ninfo( 1 ).EQ.0 )
     $         lmax( 1 ) = knt
         END IF
  240 CONTINUE
      GO TO 10
*
*     End of SGET37
*
      END