dget36()

subroutine dget36	(	double precision	RMAX,
		integer	LMAX,
		integer, dimension( 3 )	NINFO,
		integer	KNT,
		integer	NIN
	)

DGET36

Purpose:

 DGET36 tests DTREXC, a routine for moving blocks (either 1 by 1 or
 2 by 2) on the diagonal of a matrix in real Schur form.  Thus, DLAEXC
 computes an orthogonal matrix Q such that

    Q' * T1 * Q  = T2

 and where one of the diagonal blocks of T1 (the one at row IFST) has
 been moved to position ILST.

 The test code verifies that the residual Q'*T1*Q-T2 is small, that T2
 is in Schur form, and that the final position of the IFST block is
 ILST (within +-1).

 The test matrices are read from a file with logical unit number NIN.

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 array, dimension (3) NINFO(J) is the number of examples where INFO=J.
[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.

Date

December 2016

Definition at line 90 of file dget36.f.

*
*  -- 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, LMAX, NIN
      DOUBLE PRECISION   RMAX
*     ..
*     .. Array Arguments ..
      INTEGER            NINFO( 3 )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      parameter( zero = 0.0d0, one = 1.0d0 )
      INTEGER            LDT, LWORK
      parameter( ldt = 10, lwork = 2*ldt*ldt )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IFST, IFST1, IFST2, IFSTSV, ILST, ILST1,
     $                   ILST2, ILSTSV, INFO1, INFO2, J, LOC, N
      DOUBLE PRECISION   EPS, RES
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   Q( LDT, LDT ), RESULT( 2 ), T1( LDT, LDT ),
     $                   T2( LDT, LDT ), TMP( LDT, LDT ), WORK( LWORK )
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           dlamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           dhst01, dlacpy, dlaset, dtrexc
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sign
*     ..
*     .. Executable Statements ..
*
      eps = dlamch( 'P' )
      rmax = zero
      lmax = 0
      knt = 0
      ninfo( 1 ) = 0
      ninfo( 2 ) = 0
      ninfo( 3 ) = 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 dlacpy( 'F', n, n, tmp, ldt, t1, ldt )
      CALL dlacpy( 'F', n, n, tmp, ldt, t2, ldt )
      ifstsv = ifst
      ilstsv = ilst
      ifst1 = ifst
      ilst1 = ilst
      ifst2 = ifst
      ilst2 = ilst
      res = zero
*
*     Test without accumulating Q
*
      CALL dlaset( 'Full', n, n, zero, one, q, ldt )
      CALL dtrexc( 'N', n, t1, ldt, q, ldt, ifst1, ilst1, work, info1 )
      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
   30    CONTINUE
   40 CONTINUE
*
*     Test with accumulating Q
*
      CALL dlaset( 'Full', n, n, zero, one, q, ldt )
      CALL dtrexc( 'V', n, t2, ldt, q, ldt, ifst2, ilst2, work, info2 )
*
*     Compare T1 with T2
*
      DO 60 i = 1, n
         DO 50 j = 1, n
            IF( t1( i, j ).NE.t2( 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( info1.NE.info2 )
     $   res = res + one / eps
*
*     Test for successful reordering of T2
*
      IF( info2.NE.0 ) THEN
         ninfo( info2 ) = ninfo( info2 ) + 1
      ELSE
         IF( abs( ifst2-ifstsv ).GT.1 )
     $      res = res + one / eps
         IF( abs( ilst2-ilstsv ).GT.1 )
     $      res = res + one / eps
      END IF
*
*     Test for small residual, and orthogonality of Q
*
      CALL dhst01( n, 1, n, tmp, ldt, t2, ldt, q, ldt, work, lwork,
     $             result )
      res = res + result( 1 ) + result( 2 )
*
*     Test for T2 being in Schur form
*
      loc = 1
   70 CONTINUE
      IF( t2( loc+1, loc ).NE.zero ) THEN
*
*        2 by 2 block
*
         IF( t2( loc, loc+1 ).EQ.zero .OR. t2( loc, loc ).NE.
     $       t2( loc+1, loc+1 ) .OR. sign( one, t2( loc, loc+1 ) ).EQ.
     $       sign( one, t2( loc+1, loc ) ) )res = res + one / eps
         DO 80 i = loc + 2, n
            IF( t2( i, loc ).NE.zero )
     $         res = res + one / res
            IF( t2( i, loc+1 ).NE.zero )
     $         res = res + one / res
   80    CONTINUE
         loc = loc + 2
      ELSE
*
*        1 by 1 block
*
         DO 90 i = loc + 1, n
            IF( t2( i, loc ).NE.zero )
     $         res = res + one / res
   90    CONTINUE
         loc = loc + 1
      END IF
      IF( loc.LT.n )
     $   GO TO 70
      IF( res.GT.rmax ) THEN
         rmax = res
         lmax = knt
      END IF
      GO TO 10
*
*     End of DGET36
*

Here is the call graph for this function:

Here is the caller graph for this function: