cget38.f

Go to the documentation of this file.

*> \brief \b CGET38
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CGET38( RMAX, LMAX, NINFO, KNT, NIN )
*
*       .. Scalar Arguments ..
*       INTEGER            KNT, NIN
*       ..
*       .. Array Arguments ..
*       INTEGER            LMAX( 3 ), NINFO( 3 )
*       REAL               RMAX( 3 )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CGET38 tests CTRSEN, a routine for estimating condition numbers of a
*> cluster of eigenvalues and/or its associated right invariant subspace
*>
*> 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)
*>          Values of the largest test ratios.
*>          RMAX(1) = largest residuals from CHST01 or comparing
*>                    different calls to CTRSEN
*>          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 CGEHRD returns INFO nonzero on example i, LMAX(1)=i
*>          If CHSEQR returns INFO nonzero on example i, LMAX(2)=i
*>          If CTRSEN 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 CGEHRD returned INFO nonzero
*>          NINFO(2) = No. of times CHSEQR returned INFO nonzero
*>          NINFO(3) = No. of times CTRSEN 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 December 2016
*
*> \ingroup complex_eig
*
*  =====================================================================
      SUBROUTINE cget38( RMAX, LMAX, NINFO, KNT, NIN )
*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER            KNT, NIN
*     ..
*     .. Array Arguments ..
      INTEGER            LMAX( 3 ), NINFO( 3 )
      REAL               RMAX( 3 )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            LDT, LWORK
      parameter( ldt = 20, lwork = 2*ldt*( 10+ldt ) )
      REAL               ZERO, ONE, TWO
      parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0 )
      REAL               EPSIN
      parameter( epsin = 5.9605e-8 )
      COMPLEX            CZERO
      parameter( czero = ( 0.0e+0, 0.0e+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            I, INFO, ISCL, ISRT, ITMP, J, KMIN, M, N, NDIM
      REAL               BIGNUM, EPS, S, SEP, SEPIN, SEPTMP, SIN,
     $                   smlnum, stmp, tnrm, tol, tolin, v, vmax, vmin,
     $                   vmul
*     ..
*     .. Local Arrays ..
      LOGICAL            SELECT( ldt )
      INTEGER            IPNT( ldt ), ISELEC( ldt )
      REAL               RESULT( 2 ), RWORK( ldt ), VAL( 3 ),
     $                   wsrt( ldt )
      COMPLEX            Q( ldt, ldt ), QSAV( ldt, ldt ),
     $                   qtmp( ldt, ldt ), t( ldt, ldt ),
     $                   tmp( ldt, ldt ), tsav( ldt, ldt ),
     $                   tsav1( ldt, ldt ), ttmp( ldt, ldt ), w( ldt ),
     $                   work( lwork ), wtmp( ldt )
*     ..
*     .. External Functions ..
      REAL               CLANGE, SLAMCH
      EXTERNAL           clange, slamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           cgehrd, chseqr, chst01, clacpy, csscal, ctrsen,
     $                   cunghr, slabad
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          aimag, 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( 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, ndim, isrt
      IF( n.EQ.0 )
     $   RETURN
      READ( nin, fmt = * )( iselec( i ), i = 1, ndim )
      DO 20 i = 1, n
         READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
   20 CONTINUE
      READ( nin, fmt = * )sin, sepin
*
      tnrm = clange( 'M', n, n, tmp, ldt, rwork )
      DO 200 iscl = 1, 3
*
*        Scale input matrix
*
         knt = knt + 1
         CALL clacpy( 'F', n, n, tmp, ldt, t, ldt )
         vmul = val( iscl )
         DO 30 i = 1, n
            CALL csscal( n, vmul, t( 1, i ), 1 )
   30    CONTINUE
         IF( tnrm.EQ.zero )
     $      vmul = one
         CALL clacpy( 'F', n, n, t, ldt, tsav, ldt )
*
*        Compute Schur form
*
         CALL cgehrd( 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 200
         END IF
*
*        Generate unitary matrix
*
         CALL clacpy( 'L', n, n, t, ldt, q, ldt )
         CALL cunghr( n, 1, n, q, ldt, work( 1 ), work( n+1 ), lwork-n,
     $                info )
*
*        Compute Schur form
*
         DO 50 j = 1, n - 2
            DO 40 i = j + 2, n
               t( i, j ) = czero
   40       CONTINUE
   50    CONTINUE
         CALL chseqr( 'S', 'V', n, 1, n, t, ldt, w, q, ldt, work, lwork,
     $                info )
         IF( info.NE.0 ) THEN
            lmax( 2 ) = knt
            ninfo( 2 ) = ninfo( 2 ) + 1
            GO TO 200
         END IF
*
*        Sort, select eigenvalues
*
         DO 60 i = 1, n
            ipnt( i ) = i
            SELECT( i ) = .false.
   60    CONTINUE
         IF( isrt.EQ.0 ) THEN
            DO 70 i = 1, n
               wsrt( i ) = REAL( W( I ) )
   70       CONTINUE
         ELSE
            DO 80 i = 1, n
               wsrt( i ) = aimag( w( i ) )
   80       CONTINUE
         END IF
         DO 100 i = 1, n - 1
            kmin = i
            vmin = wsrt( i )
            DO 90 j = i + 1, n
               IF( wsrt( j ).LT.vmin ) THEN
                  kmin = j
                  vmin = wsrt( j )
               END IF
   90       CONTINUE
            wsrt( kmin ) = wsrt( i )
            wsrt( i ) = vmin
            itmp = ipnt( i )
            ipnt( i ) = ipnt( kmin )
            ipnt( kmin ) = itmp
  100    CONTINUE
         DO 110 i = 1, ndim
            SELECT( ipnt( iselec( i ) ) ) = .true.
  110    CONTINUE
*
*        Compute condition numbers
*
         CALL clacpy( 'F', n, n, q, ldt, qsav, ldt )
         CALL clacpy( 'F', n, n, t, ldt, tsav1, ldt )
         CALL ctrsen( 'B', 'V', SELECT, n, t, ldt, q, ldt, wtmp, m, s,
     $                sep, work, lwork, info )
         IF( info.NE.0 ) THEN
            lmax( 3 ) = knt
            ninfo( 3 ) = ninfo( 3 ) + 1
            GO TO 200
         END IF
         septmp = sep / vmul
         stmp = s
*
*        Compute residuals
*
         CALL chst01( n, 1, n, tsav, ldt, t, ldt, q, ldt, work, lwork,
     $                rwork, result )
         vmax = max( result( 1 ), result( 2 ) )
         IF( vmax.GT.rmax( 1 ) ) THEN
            rmax( 1 ) = vmax
            IF( ninfo( 1 ).EQ.0 )
     $         lmax( 1 ) = knt
         END IF
*
*        Compare condition number for eigenvalue cluster
*        taking its condition number into account
*
         v = max( two*REAL( n )*EPS*TNRM, SMLNUM )
         IF( tnrm.EQ.zero )
     $      v = one
         IF( v.GT.septmp ) THEN
            tol = one
         ELSE
            tol = v / septmp
         END IF
         IF( v.GT.sepin ) THEN
            tolin = one
         ELSE
            tolin = v / sepin
         END IF
         tol = max( tol, smlnum / eps )
         tolin = max( tolin, smlnum / eps )
         IF( eps*( sin-tolin ).GT.stmp+tol ) THEN
            vmax = one / eps
         ELSE IF( sin-tolin.GT.stmp+tol ) THEN
            vmax = ( sin-tolin ) / ( stmp+tol )
         ELSE IF( sin+tolin.LT.eps*( stmp-tol ) ) THEN
            vmax = one / eps
         ELSE IF( sin+tolin.LT.stmp-tol ) THEN
            vmax = ( stmp-tol ) / ( sin+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
*
*        Compare condition numbers for invariant subspace
*        taking its condition number into account
*
         IF( v.GT.septmp*stmp ) THEN
            tol = septmp
         ELSE
            tol = v / stmp
         END IF
         IF( v.GT.sepin*sin ) THEN
            tolin = sepin
         ELSE
            tolin = v / sin
         END IF
         tol = max( tol, smlnum / eps )
         tolin = max( tolin, smlnum / eps )
         IF( eps*( sepin-tolin ).GT.septmp+tol ) THEN
            vmax = one / eps
         ELSE IF( sepin-tolin.GT.septmp+tol ) THEN
            vmax = ( sepin-tolin ) / ( septmp+tol )
         ELSE IF( sepin+tolin.LT.eps*( septmp-tol ) ) THEN
            vmax = one / eps
         ELSE IF( sepin+tolin.LT.septmp-tol ) THEN
            vmax = ( septmp-tol ) / ( sepin+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
*
*        Compare condition number for eigenvalue cluster
*        without taking its condition number into account
*
         IF( sin.LE.REAL( 2*n )*EPS .AND. STMP.LE.REAL( 2*n )*EPS ) then
            vmax = one
         ELSE IF( eps*sin.GT.stmp ) THEN
            vmax = one / eps
         ELSE IF( sin.GT.stmp ) THEN
            vmax = sin / stmp
         ELSE IF( sin.LT.eps*stmp ) THEN
            vmax = one / eps
         ELSE IF( sin.LT.stmp ) THEN
            vmax = stmp / sin
         ELSE
            vmax = one
         END IF
         IF( vmax.GT.rmax( 3 ) ) THEN
            rmax( 3 ) = vmax
            IF( ninfo( 3 ).EQ.0 )
     $         lmax( 3 ) = knt
         END IF
*
*        Compare condition numbers for invariant subspace
*        without taking its condition number into account
*
         IF( sepin.LE.v .AND. septmp.LE.v ) THEN
            vmax = one
         ELSE IF( eps*sepin.GT.septmp ) THEN
            vmax = one / eps
         ELSE IF( sepin.GT.septmp ) THEN
            vmax = sepin / septmp
         ELSE IF( sepin.LT.eps*septmp ) THEN
            vmax = one / eps
         ELSE IF( sepin.LT.septmp ) THEN
            vmax = septmp / sepin
         ELSE
            vmax = one
         END IF
         IF( vmax.GT.rmax( 3 ) ) THEN
            rmax( 3 ) = vmax
            IF( ninfo( 3 ).EQ.0 )
     $         lmax( 3 ) = knt
         END IF
*
*        Compute eigenvalue condition number only and compare
*        Update Q
*
         vmax = zero
         CALL clacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
         CALL clacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
         septmp = -one
         stmp = -one
         CALL ctrsen( 'E', 'V', SELECT, n, ttmp, ldt, qtmp, ldt, wtmp,
     $                m, stmp, septmp, work, lwork, info )
         IF( info.NE.0 ) THEN
            lmax( 3 ) = knt
            ninfo( 3 ) = ninfo( 3 ) + 1
            GO TO 200
         END IF
         IF( s.NE.stmp )
     $      vmax = one / eps
         IF( -one.NE.septmp )
     $      vmax = one / eps
         DO 130 i = 1, n
            DO 120 j = 1, n
               IF( ttmp( i, j ).NE.t( i, j ) )
     $            vmax = one / eps
               IF( qtmp( i, j ).NE.q( i, j ) )
     $            vmax = one / eps
  120       CONTINUE
  130    CONTINUE
*
*        Compute invariant subspace condition number only and compare
*        Update Q
*
         CALL clacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
         CALL clacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
         septmp = -one
         stmp = -one
         CALL ctrsen( 'V', 'V', SELECT, n, ttmp, ldt, qtmp, ldt, wtmp,
     $                m, stmp, septmp, work, lwork, info )
         IF( info.NE.0 ) THEN
            lmax( 3 ) = knt
            ninfo( 3 ) = ninfo( 3 ) + 1
            GO TO 200
         END IF
         IF( -one.NE.stmp )
     $      vmax = one / eps
         IF( sep.NE.septmp )
     $      vmax = one / eps
         DO 150 i = 1, n
            DO 140 j = 1, n
               IF( ttmp( i, j ).NE.t( i, j ) )
     $            vmax = one / eps
               IF( qtmp( i, j ).NE.q( i, j ) )
     $            vmax = one / eps
  140       CONTINUE
  150    CONTINUE
*
*        Compute eigenvalue condition number only and compare
*        Do not update Q
*
         CALL clacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
         CALL clacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
         septmp = -one
         stmp = -one
         CALL ctrsen( 'E', 'N', SELECT, n, ttmp, ldt, qtmp, ldt, wtmp,
     $                m, stmp, septmp, work, lwork, info )
         IF( info.NE.0 ) THEN
            lmax( 3 ) = knt
            ninfo( 3 ) = ninfo( 3 ) + 1
            GO TO 200
         END IF
         IF( s.NE.stmp )
     $      vmax = one / eps
         IF( -one.NE.septmp )
     $      vmax = one / eps
         DO 170 i = 1, n
            DO 160 j = 1, n
               IF( ttmp( i, j ).NE.t( i, j ) )
     $            vmax = one / eps
               IF( qtmp( i, j ).NE.qsav( i, j ) )
     $            vmax = one / eps
  160       CONTINUE
  170    CONTINUE
*
*        Compute invariant subspace condition number only and compare
*        Do not update Q
*
         CALL clacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
         CALL clacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
         septmp = -one
         stmp = -one
         CALL ctrsen( 'V', 'N', SELECT, n, ttmp, ldt, qtmp, ldt, wtmp,
     $                m, stmp, septmp, work, lwork, info )
         IF( info.NE.0 ) THEN
            lmax( 3 ) = knt
            ninfo( 3 ) = ninfo( 3 ) + 1
            GO TO 200
         END IF
         IF( -one.NE.stmp )
     $      vmax = one / eps
         IF( sep.NE.septmp )
     $      vmax = one / eps
         DO 190 i = 1, n
            DO 180 j = 1, n
               IF( ttmp( i, j ).NE.t( i, j ) )
     $            vmax = one / eps
               IF( qtmp( i, j ).NE.qsav( i, j ) )
     $            vmax = one / eps
  180       CONTINUE
  190    CONTINUE
         IF( vmax.GT.rmax( 1 ) ) THEN
            rmax( 1 ) = vmax
            IF( ninfo( 1 ).EQ.0 )
     $         lmax( 1 ) = knt
         END IF
  200 CONTINUE
      GO TO 10
*
*     End of CGET38
*
      END