dget33()

subroutine dget33	(	double precision	RMAX,
		integer	LMAX,
		integer	NINFO,
		integer	KNT
	)

DGET33

Purpose:

 DGET33 tests DLANV2, 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.

Parameters

[out]	RMAX	RMAX is DOUBLE PRECISION Value of the largest test ratio.
[out]	LMAX	LMAX is INTEGER Example number where largest test ratio achieved.
[out]	NINFO	NINFO is INTEGER Number of examples returned with INFO .NE. 0.
[out]	KNT	KNT is INTEGER Total number of examples tested.

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 75 of file dget33.f.

*
*  -- LAPACK test 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            KNT, LMAX, NINFO
      DOUBLE PRECISION   RMAX
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      parameter( zero = 0.0d0, one = 1.0d0 )
      DOUBLE PRECISION   TWO, FOUR
      parameter( two = 2.0d0, four = 4.0d0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I1, I2, I3, I4, IM1, IM2, IM3, IM4, J1, J2, J3
      DOUBLE PRECISION   BIGNUM, CS, EPS, RES, SMLNUM, SN, SUM, TNRM,
     $                   WI1, WI2, WR1, WR2
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   Q( 2, 2 ), T( 2, 2 ), T1( 2, 2 ), T2( 2, 2 ),
     $                   VAL( 4 ), VM( 3 )
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           dlamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           dlabad, dlanv2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, sign
*     ..
*     .. Executable Statements ..
*
*     Get machine parameters
*
      eps = dlamch( 'P' )
      smlnum = dlamch( 'S' ) / eps
      bignum = one / smlnum
      CALL dlabad( 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 dlanv2( 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 DGET33
*

Here is the call graph for this function:

Here is the caller graph for this function: