zget36()

subroutine zget36	(	double precision	RMAX,
		integer	LMAX,
		integer	NINFO,
		integer	KNT,
		integer	NIN
	)

ZGET36

Purpose:

 ZGET36 tests ZTREXC, a routine for reordering diagonal entries of a
 matrix in complex Schur form. Thus, ZLAEXC 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 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 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

December 2016

Definition at line 87 of file zget36.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, NINFO
      DOUBLE PRECISION   RMAX
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      parameter( zero = 0.0d+0, one = 1.0d+0 )
      COMPLEX*16         CZERO, CONE
      parameter( czero = ( 0.0d+0, 0.0d+0 ),
     $                   cone = ( 1.0d+0, 0.0d+0 ) )
      INTEGER            LDT, LWORK
      parameter( ldt = 10, lwork = 2*ldt*ldt )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IFST, ILST, INFO1, INFO2, J, N
      DOUBLE PRECISION   EPS, RES
      COMPLEX*16         CTEMP
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   RESULT( 2 ), RWORK( LDT )
      COMPLEX*16         DIAG( LDT ), Q( LDT, LDT ), T1( LDT, LDT ),
     $                   T2( LDT, LDT ), TMP( LDT, LDT ), WORK( LWORK )
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           dlamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           zcopy, zhst01, zlacpy, zlaset, ztrexc
*     ..
*     .. Executable Statements ..
*
      eps = dlamch( '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 zlacpy( 'F', n, n, tmp, ldt, t1, ldt )
      CALL zlacpy( 'F', n, n, tmp, ldt, t2, ldt )
      res = zero
*
*     Test without accumulating Q
*
      CALL zlaset( 'Full', n, n, czero, cone, q, ldt )
      CALL ztrexc( '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 zlaset( 'Full', n, n, czero, cone, q, ldt )
      CALL ztrexc( '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 zcopy( 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 zhst01( 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 ZGET36
*

Here is the call graph for this function:

Here is the caller graph for this function: