sget33.f

Go to the documentation of this file.

*> \brief \b SGET33
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at 
*            http://www.netlib.org/lapack/explore-html/ 
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGET33( RMAX, LMAX, NINFO, KNT )
* 
*       .. Scalar Arguments ..
*       INTEGER            KNT, LMAX, NINFO
*       REAL               RMAX
*       ..
*  
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGET33 tests SLANV2, a routine for putting 2 by 2 blocks into
*> standard form.  In other words, it computes a two by two rotation
*> [[C,S];[-S,C]] where in
*>
*>    [ C S ][T(1,1) T(1,2)][ C -S ] = [ T11 T12 ]
*>    [-S C ][T(2,1) T(2,2)][ S  C ]   [ T21 T22 ]
*>
*> either
*>    1) T21=0 (real eigenvalues), or
*>    2) T11=T22 and T21*T12<0 (complex conjugate eigenvalues).
*> We also  verify that the residual is small.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[out] RMAX
*> \verbatim
*>          RMAX is REAL
*>          Value of the largest test ratio.
*> \endverbatim
*>
*> \param[out] LMAX
*> \verbatim
*>          LMAX is INTEGER
*>          Example number where largest test ratio achieved.
*> \endverbatim
*>
*> \param[out] NINFO
*> \verbatim
*>          NINFO is INTEGER
*>          Number of examples returned with INFO .NE. 0.
*> \endverbatim
*>
*> \param[out] KNT
*> \verbatim
*>          KNT is INTEGER
*>          Total number of examples tested.
*> \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 sget33( RMAX, LMAX, NINFO, KNT )
*
*  -- 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, LMAX, NINFO
      REAL               RMAX
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      parameter                ( zero = 0.0e0, one = 1.0e0 )
      REAL               TWO, FOUR
      parameter                ( two = 2.0e0, four = 4.0e0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I1, I2, I3, I4, IM1, IM2, IM3, IM4, J1, J2, J3
      REAL               BIGNUM, CS, EPS, RES, SMLNUM, SN, SUM, TNRM,
     $                   wi1, wi2, wr1, wr2
*     ..
*     .. Local Arrays ..
      REAL               Q( 2, 2 ), T( 2, 2 ), T1( 2, 2 ), T2( 2, 2 ),
     $                   val( 4 ), vm( 3 )
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           slamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           slabad, slanv2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, sign
*     ..
*     .. Executable Statements ..
*
*     Get machine parameters
*
      eps = slamch( 'P' )
      smlnum = slamch( 'S' ) / eps
      bignum = one / smlnum
      CALL slabad( smlnum, bignum )
*
*     Set up test case parameters
*
      val( 1 ) = one
      val( 2 ) = one + two*eps
      val( 3 ) = two
      val( 4 ) = two - four*eps
      vm( 1 ) = smlnum
      vm( 2 ) = one
      vm( 3 ) = bignum
*
      knt = 0
      ninfo = 0
      lmax = 0
      rmax = zero
*
*     Begin test loop
*
      DO 150 i1 = 1, 4
         DO 140 i2 = 1, 4
            DO 130 i3 = 1, 4
               DO 120 i4 = 1, 4
                  DO 110 im1 = 1, 3
                     DO 100 im2 = 1, 3
                        DO 90 im3 = 1, 3
                           DO 80 im4 = 1, 3
                              t( 1, 1 ) = val( i1 )*vm( im1 )
                              t( 1, 2 ) = val( i2 )*vm( im2 )
                              t( 2, 1 ) = -val( i3 )*vm( im3 )
                              t( 2, 2 ) = val( i4 )*vm( im4 )
                              tnrm = max( abs( t( 1, 1 ) ),
     $                               abs( t( 1, 2 ) ), abs( t( 2, 1 ) ),
     $                               abs( t( 2, 2 ) ) )
                              t1( 1, 1 ) = t( 1, 1 )
                              t1( 1, 2 ) = t( 1, 2 )
                              t1( 2, 1 ) = t( 2, 1 )
                              t1( 2, 2 ) = t( 2, 2 )
                              q( 1, 1 ) = one
                              q( 1, 2 ) = zero
                              q( 2, 1 ) = zero
                              q( 2, 2 ) = one
*
                              CALL slanv2( t( 1, 1 ), t( 1, 2 ),
     $                                     t( 2, 1 ), t( 2, 2 ), wr1,
     $                                     wi1, wr2, wi2, cs, sn )
                              DO 10 j1 = 1, 2
                                 res = q( j1, 1 )*cs + q( j1, 2 )*sn
                                 q( j1, 2 ) = -q( j1, 1 )*sn +
     $                                        q( j1, 2 )*cs
                                 q( j1, 1 ) = res
   10                         CONTINUE
*
                              res = zero
                              res = res + abs( q( 1, 1 )**2+
     $                              q( 1, 2 )**2-one ) / eps
                              res = res + abs( q( 2, 2 )**2+
     $                              q( 2, 1 )**2-one ) / eps
                              res = res + abs( q( 1, 1 )*q( 2, 1 )+
     $                              q( 1, 2 )*q( 2, 2 ) ) / eps
                              DO 40 j1 = 1, 2
                                 DO 30 j2 = 1, 2
                                    t2( j1, j2 ) = zero
                                    DO 20 j3 = 1, 2
                                       t2( j1, j2 ) = t2( j1, j2 ) +
     $                                                t1( j1, j3 )*
     $                                                q( j3, j2 )
   20                               CONTINUE
   30                            CONTINUE
   40                         CONTINUE
                              DO 70 j1 = 1, 2
                                 DO 60 j2 = 1, 2
                                    sum = t( j1, j2 )
                                    DO 50 j3 = 1, 2
                                       sum = sum - q( j3, j1 )*
     $                                       t2( j3, j2 )
   50                               CONTINUE
                                    res = res + abs( sum ) / eps / tnrm
   60                            CONTINUE
   70                         CONTINUE
                              IF( t( 2, 1 ).NE.zero .AND.
     $                            ( t( 1, 1 ).NE.t( 2,
     $                            2 ) .OR. sign( one, t( 1,
     $                            2 ) )*sign( one, t( 2,
     $                            1 ) ).GT.zero ) )res = res + one / eps
                              knt = knt + 1
                              IF( res.GT.rmax ) THEN
                                 lmax = knt
                                 rmax = res
                              END IF
   80                      CONTINUE
   90                   CONTINUE
  100                CONTINUE
  110             CONTINUE
  120          CONTINUE
  130       CONTINUE
  140    CONTINUE
  150 CONTINUE
*
      RETURN
*
*     End of SGET33
*
      END