|
- *> \brief \b DGET40
- *
- * =========== DOCUMENTATION ===========
- *
- * Online html documentation available at
- * http://www.netlib.org/lapack/explore-html/
- *
- * Definition:
- * ===========
- *
- * SUBROUTINE DGET40( RMAX, LMAX, NINFO, KNT, NIN )
- *
- * .. Scalar Arguments ..
- * INTEGER KNT, LMAX, NIN
- * DOUBLE PRECISION RMAX
- * ..
- * .. Array Arguments ..
- * INTEGER NINFO( 3 )
- *
- *
- *> \par Purpose:
- * =============
- *>
- *> \verbatim
- *>
- *> DGET40 tests DTGEXC, 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, DTGEXC 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.
- *> \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(3)
- *> Number of examples where INFO is nonzero.
- *> \endverbatim
- *>
- *> \param[out] KNT
- *> \verbatim
- *> KNT is INTEGER
- *> Total number of examples tested.
- *> \endverbatim
- *>
- *> \param[out] NIN
- *> \verbatim
- *> NINFO is INTEGER
- *> \endverbatim
- *
- * Authors:
- * ========
- *
- *> \author Univ. of Tennessee
- *> \author Univ. of California Berkeley
- *> \author Univ. of Colorado Denver
- *> \author NAG Ltd.
- *
- *> \ingroup double_eig
- *
- * =====================================================================
- SUBROUTINE DGET40( 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
- 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 = 100 + 4*LDT + 16 )
- * ..
- * .. 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 ), 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 ..
- DOUBLE PRECISION DLAMCH
- EXTERNAL DLAMCH
- * ..
- * .. External Subroutines ..
- EXTERNAL DHST01, DLACPY, DLASET, DTGEXC
- * ..
- * .. 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, T, LDT )
- CALL DLACPY( 'F', N, N, TMP, LDT, T1, LDT )
- CALL DLACPY( 'F', N, N, TMP, LDT, T2, LDT )
- DO 25 I = 1, N
- READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
- 25 CONTINUE
- CALL DLACPY( 'F', N, N, TMP, LDT, S, LDT )
- CALL DLACPY( 'F', N, N, TMP, LDT, S1, LDT )
- CALL DLACPY( '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 DLASET( 'Full', N, N, ZERO, ONE, Q, LDT )
- CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDT )
- CALL DTGEXC( .FALSE., .FALSE., N, T1, LDT, S1, LDT, Q, LDT,
- $ Z, LDT, IFST1, ILST1, WORK, LWORK, 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
- 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 DLASET( 'Full', N, N, ZERO, ONE, Q, LDT )
- CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDT )
- CALL DTGEXC( .TRUE., .TRUE., N, T2, LDT, S2, LDT, Q, LDT,
- $ Z, LDT, IFST2, ILST2, WORK, LWORK, INFO2 )
- *
- * 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( INFO1.NE.INFO2 )
- $ RES = RES + ONE / EPS
- *
- * Test orthogonality of Q and Z and backward error on T2 and S2
- *
- CALL DGET51( 1, N, T, LDT, T2, LDT, Q, LDT, Z, LDT, WORK,
- $ RESULT( 1 ) )
- CALL DGET51( 1, N, S, LDT, S2, LDT, Q, LDT, Z, LDT, WORK,
- $ RESULT( 2 ) )
- CALL DGET51( 3, N, T, LDT, T2, LDT, Q, LDT, Q, LDT, WORK,
- $ RESULT( 3 ) )
- CALL DGET51( 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 DGET40
- *
- END
|
