zget36.f

Go to the documentation of this file.

*> \brief \b ZGET36
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZGET36( RMAX, LMAX, NINFO, KNT, NIN )
*
*       .. Scalar Arguments ..
*       INTEGER            KNT, LMAX, NIN, NINFO
*       DOUBLE PRECISION   RMAX
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> 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.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[out] RMAX
*> \verbatim
*>          RMAX is DOUBLE PRECISION
*>          Value of the largest test ratio.
*> \endverbatim
*>
*> \param[out] LMAX
*> \verbatim
*>          LMAX is INTEGER
*>          Example number where largest test ratio achieved.
*> \endverbatim
*>
*> \param[out] NINFO
*> \verbatim
*>          NINFO is INTEGER
*>          Number of examples where INFO is nonzero.
*> \endverbatim
*>
*> \param[out] KNT
*> \verbatim
*>          KNT is INTEGER
*>          Total number of examples tested.
*> \endverbatim
*>
*> \param[in] NIN
*> \verbatim
*>          NIN is INTEGER
*>          Input logical unit number.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex16_eig
*
*  =====================================================================
      SUBROUTINE zget36( RMAX, LMAX, NINFO, KNT, NIN )
*
*  -- 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, 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
.EQ..AND..NE.            IF( IJ  Q( I, J )CONE )
     $         RES = RES + ONE / EPS
.NE..AND..NE.            IF( IJ  Q( I, J )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
.NE.            IF( T1( I, J )T2( I, J ) )
     $         RES = RES + ONE / EPS
   50    CONTINUE
   60 CONTINUE
.NE..OR..NE.      IF( INFO10  INFO20 )
     $   NINFO = NINFO + 1
.NE.      IF( INFO1INFO2 )
     $   RES = RES + ONE / EPS
*
*     Test for successful reordering of T2
*
      CALL ZCOPY( N, TMP, LDT+1, DIAG, 1 )
.LT.      IF( IFSTILST ) THEN
         DO 70 I = IFST + 1, ILST
            CTEMP = DIAG( I )
            DIAG( I ) = DIAG( I-1 )
            DIAG( I-1 ) = CTEMP
   70    CONTINUE
.GT.      ELSE IF( IFSTILST ) 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
.NE.         IF( T2( I, I )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
.NE.            IF( T2( I, J )CZERO )
     $         RES = RES + ONE / EPS
  100    CONTINUE
  110 CONTINUE
.GT.      IF( RESRMAX ) THEN
         RMAX = RES
         LMAX = KNT
      END IF
      GO TO 10
*
*     End of ZGET36
*
      END