subroutine cget36	(	real	RMAX,
		integer	LMAX,
		integer	NINFO,
		integer	KNT,
		integer	NIN
	)

CGET36

Purpose:

 CGET36 tests CTREXC, a routine for reordering diagonal entries of a
 matrix in complex Schur form. Thus, CLAEXC computes a unitary 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.

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

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 Number of examples where INFO is 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.

Date

November 2011

Definition at line 87 of file cget36.f.

*
*  -- 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, nin, ninfo
      REAL               rmax
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               zero, one
      parameter                ( zero = 0.0e+0, one = 1.0e+0 )
      COMPLEX            czero, cone
      parameter                ( czero = ( 0.0e+0, 0.0e+0 ),
     $                   cone = ( 1.0e+0, 0.0e+0 ) )
      INTEGER            ldt, lwork
      parameter                ( ldt = 10, lwork = 2*ldt*ldt )
*     ..
*     .. Local Scalars ..
      INTEGER            i, ifst, ilst, info1, info2, j, n
      REAL               eps, res
      COMPLEX            ctemp
*     ..
*     .. Local Arrays ..
      REAL               result( 2 ), rwork( ldt )
      COMPLEX            diag( ldt ), q( ldt, ldt ), t1( ldt, ldt ),
     $                   t2( ldt, ldt ), tmp( ldt, ldt ), work( lwork )
*     ..
*     .. External Functions ..
      REAL               slamch
      EXTERNAL           slamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           ccopy, chst01, clacpy, claset, ctrexc
*     ..
*     .. Executable Statements ..
*
      eps = slamch( 'P' )
      rmax = zero
      lmax = 0
      knt = 0
      ninfo = 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 clacpy( 'F', n, n, tmp, ldt, t1, ldt )
      CALL clacpy( 'F', n, n, tmp, ldt, t2, ldt )
      res = zero
*
*     Test without accumulating Q
*
      CALL claset( 'Full', n, n, czero, cone, q, ldt )
      CALL ctrexc( 'N', n, t1, ldt, q, ldt, ifst, ilst, info1 )
      DO 40 i = 1, n
         DO 30 j = 1, n
            IF( i.EQ.j .AND. q( i, j ).NE.cone )
     $         res = res + one / eps
            IF( i.NE.j .AND. q( i, j ).NE.czero )
     $         res = res + one / eps
   30    CONTINUE
   40 CONTINUE
*
*     Test with accumulating Q
*
      CALL claset( 'Full', n, n, czero, cone, q, ldt )
      CALL ctrexc( 'V', n, t2, ldt, q, ldt, ifst, ilst, 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( info1.NE.0 .OR. info2.NE.0 )
     $   ninfo = ninfo + 1
      IF( info1.NE.info2 )
     $   res = res + one / eps
*
*     Test for successful reordering of T2
*
      CALL ccopy( n, tmp, ldt+1, diag, 1 )
      IF( ifst.LT.ilst ) THEN
         DO 70 i = ifst + 1, ilst
            ctemp = diag( i )
            diag( i ) = diag( i-1 )
            diag( i-1 ) = ctemp
   70    CONTINUE
      ELSE IF( ifst.GT.ilst ) THEN
         DO 80 i = ifst - 1, ilst, -1
            ctemp = diag( i+1 )
            diag( i+1 ) = diag( i )
            diag( i ) = ctemp
   80    CONTINUE
      END IF
      DO 90 i = 1, n
         IF( t2( i, i ).NE.diag( i ) )
     $      res = res + one / eps
   90 CONTINUE
*
*     Test for small residual, and orthogonality of Q
*
      CALL chst01( n, 1, n, tmp, ldt, t2, ldt, q, ldt, work, lwork,
     $             rwork, result )
      res = res + result( 1 ) + result( 2 )
*
*     Test for T2 being in Schur form
*
      DO 110 j = 1, n - 1
         DO 100 i = j + 1, n
            IF( t2( i, j ).NE.czero )
     $         res = res + one / eps
  100    CONTINUE
  110 CONTINUE
      IF( res.GT.rmax ) THEN
         rmax = res
         lmax = knt
      END IF
      GO TO 10
*
*     End of CGET36
*

Here is the call graph for this function:

Here is the caller graph for this function: