sget40()

subroutine sget40	(	real	rmax,
		integer	lmax,
		integer, dimension( 2 )	ninfo,
		integer	knt,
		integer	nin )

SGET40

Purpose:

!>
!> SGET40 tests STGEXC, a routine for swapping adjacent blocks (either
!> 1 by 1 or 2 by 2) on the diagonal of a pencil in real generalized Schur form.
!> Thus, STGEXC computes an orthogonal matrices Q and Z such that
!>
!>     Q' * ( [ A B ], [ D E ] ) * Z  = ( [ C1 B1 ], [ F1 E1 ] )
!>          ( [ 0 C ]  [   F ] )        ( [ 0  A1 ]  [    D1]  )
!>
!> where (C1,F1) is similar to (C,F) and (A1,D1) is similar to (A,D).
!> Both (A,D) and (C,F) are assumed to be in standard form
!> and (A1,D1) and (C1,F1) are returned with the
!> same properties.
!> 

Parameters

[out]	RMAX	!> RMAX is REAL !> Value of the largest test ratio. !>
[out]	LMAX	!> LMAX is INTEGER !> Example number where largest test ratio achieved. !>
[out]	NINFO	!> NINFO is INTEGER array, dimension (2) !> NINFO( 1 ) = STGEXC without accumulation returned INFO nonzero !> NINFO( 2 ) = STGEXC with accumulation returned INFO nonzero !>
[out]	KNT	!> KNT is INTEGER !> Total number of examples tested. !>
[in]	NIN	!> NIN is INTEGER !> Input logical unit number. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 84 of file sget40.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, NIN
      REAL               RMAX
*     ..
*     .. Array Arguments ..
      INTEGER            NINFO( 2 )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      parameter( zero = 0.0, one = 1.0 )
      INTEGER            LDT, LWORK
      parameter( ldt = 10, lwork = 100 + 4*ldt + 16 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IFST, IFST1, IFST2, IFSTSV, ILST, ILST1,
     $                   ILST2, ILSTSV, J, LOC, N
      REAL               EPS, RES
*     ..
*     .. Local Arrays ..
      REAL               Q( LDT, LDT ), Z( LDT, LDT ), RESULT( 4 ),
     $                   T( LDT, LDT ), T1( LDT, LDT ), T2( LDT, LDT ),
     $                   S( LDT, LDT ), S1( LDT, LDT ), S2( LDT, LDT ),
     $                   TMP( LDT, LDT ), WORK( LWORK )
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           slamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           sget51, slacpy, slaset, stgexc
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sign
*     ..
*     .. Executable Statements ..
*
      eps = slamch( 'P' )
      rmax = zero
      lmax = 0
      knt = 0
      ninfo( 1 ) = 0
      ninfo( 2 ) = 0
*
*     Read input data until N=0
*
   10 CONTINUE
      READ( nin, fmt = * )n, ifst, ilst
      IF( n.EQ.0 )
     $   RETURN
      knt = knt + 1
      DO 20 i = 1, n
         READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
   20 CONTINUE
      CALL slacpy( 'F', n, n, tmp, ldt, t, ldt )
      CALL slacpy( 'F', n, n, tmp, ldt, t1, ldt )
      CALL slacpy( 'F', n, n, tmp, ldt, t2, ldt )
      DO 25 i = 1, n
         READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
   25 CONTINUE
      CALL slacpy( 'F', n, n, tmp, ldt, s, ldt )
      CALL slacpy( 'F', n, n, tmp, ldt, s1, ldt )
      CALL slacpy( 'F', n, n, tmp, ldt, s2, ldt )
      ifstsv = ifst
      ilstsv = ilst
      ifst1 = ifst
      ilst1 = ilst
      ifst2 = ifst
      ilst2 = ilst
      res = zero
*
*     Test without accumulating Q and Z
*
      CALL slaset( 'Full', n, n, zero, one, q, ldt )
      CALL slaset( 'Full', n, n, zero, one, z, ldt )
      CALL stgexc( .false., .false., n, t1, ldt, s1, ldt, q, ldt,
     $             z, ldt, ifst1, ilst1, work, lwork, ninfo( 1 ) )
      DO 40 i = 1, n
         DO 30 j = 1, n
            IF( i.EQ.j .AND. q( i, j ).NE.one )
     $         res = res + one / eps
            IF( i.NE.j .AND. q( i, j ).NE.zero )
     $         res = res + one / eps
            IF( i.EQ.j .AND. z( i, j ).NE.one )
     $         res = res + one / eps
            IF( i.NE.j .AND. z( i, j ).NE.zero )
     $         res = res + one / eps
   30    CONTINUE
   40 CONTINUE
*
*     Test with accumulating Q
*
      CALL slaset( 'Full', n, n, zero, one, q, ldt )
      CALL slaset( 'Full', n, n, zero, one, z, ldt )
      CALL stgexc( .true., .true., n, t2, ldt, s2, ldt, q, ldt,
     $             z, ldt, ifst2, ilst2, work, lwork, ninfo( 2 ) )
*
*     Compare T1 with T2 and S1 with S2
*
      DO 60 i = 1, n
         DO 50 j = 1, n
            IF( t1( i, j ).NE.t2( i, j ) )
     $         res = res + one / eps
            IF( s1( i, j ).NE.s2( i, j ) )
     $         res = res + one / eps
   50    CONTINUE
   60 CONTINUE
      IF( ifst1.NE.ifst2 )
     $   res = res + one / eps
      IF( ilst1.NE.ilst2 )
     $   res = res + one / eps
      IF( ninfo( 1 ).NE.ninfo( 2 ) )
     $   res = res + one / eps
*
*     Test orthogonality of Q and Z and backward error on T2 and S2
*
      CALL sget51( 1, n, t, ldt, t2, ldt, q, ldt, z, ldt, work,
     $             result( 1 ) )
      CALL sget51( 1, n, s, ldt, s2, ldt, q, ldt, z, ldt, work,
     $             result( 2 ) )
      CALL sget51( 3, n, t, ldt, t2, ldt, q, ldt, q, ldt, work,
     $             result( 3 ) )
      CALL sget51( 3, n, t, ldt, t2, ldt, z, ldt, z, ldt, work,
     $             result( 4 ) )
      res = res + result( 1 ) + result( 2 ) + result( 3 ) + result( 4 )
*
*     Read next matrix pair
*
      GO TO 10
*
*     End of SGET40
*

Here is the call graph for this function:

Here is the caller graph for this function: