LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
cget36.f
Go to the documentation of this file.
00001 *> \brief \b CGET36
00002 *
00003 *  =========== DOCUMENTATION ===========
00004 *
00005 * Online html documentation available at 
00006 *            http://www.netlib.org/lapack/explore-html/ 
00007 *
00008 *  Definition:
00009 *  ===========
00010 *
00011 *       SUBROUTINE CGET36( RMAX, LMAX, NINFO, KNT, NIN )
00012 * 
00013 *       .. Scalar Arguments ..
00014 *       INTEGER            KNT, LMAX, NIN, NINFO
00015 *       REAL               RMAX
00016 *       ..
00017 *  
00018 *
00019 *> \par Purpose:
00020 *  =============
00021 *>
00022 *> \verbatim
00023 *>
00024 *> CGET36 tests CTREXC, a routine for reordering diagonal entries of a
00025 *> matrix in complex Schur form. Thus, CLAEXC computes a unitary matrix
00026 *> Q such that
00027 *>
00028 *>    Q' * T1 * Q  = T2
00029 *>
00030 *> and where one of the diagonal blocks of T1 (the one at row IFST) has
00031 *> been moved to position ILST.
00032 *>
00033 *> The test code verifies that the residual Q'*T1*Q-T2 is small, that T2
00034 *> is in Schur form, and that the final position of the IFST block is
00035 *> ILST.
00036 *>
00037 *> The test matrices are read from a file with logical unit number NIN.
00038 *> \endverbatim
00039 *
00040 *  Arguments:
00041 *  ==========
00042 *
00043 *> \param[out] RMAX
00044 *> \verbatim
00045 *>          RMAX is REAL
00046 *>          Value of the largest test ratio.
00047 *> \endverbatim
00048 *>
00049 *> \param[out] LMAX
00050 *> \verbatim
00051 *>          LMAX is INTEGER
00052 *>          Example number where largest test ratio achieved.
00053 *> \endverbatim
00054 *>
00055 *> \param[out] NINFO
00056 *> \verbatim
00057 *>          NINFO is INTEGER
00058 *>          Number of examples where INFO is nonzero.
00059 *> \endverbatim
00060 *>
00061 *> \param[out] KNT
00062 *> \verbatim
00063 *>          KNT is INTEGER
00064 *>          Total number of examples tested.
00065 *> \endverbatim
00066 *>
00067 *> \param[in] NIN
00068 *> \verbatim
00069 *>          NIN is INTEGER
00070 *>          Input logical unit number.
00071 *> \endverbatim
00072 *
00073 *  Authors:
00074 *  ========
00075 *
00076 *> \author Univ. of Tennessee 
00077 *> \author Univ. of California Berkeley 
00078 *> \author Univ. of Colorado Denver 
00079 *> \author NAG Ltd. 
00080 *
00081 *> \date November 2011
00082 *
00083 *> \ingroup complex_eig
00084 *
00085 *  =====================================================================
00086       SUBROUTINE CGET36( RMAX, LMAX, NINFO, KNT, NIN )
00087 *
00088 *  -- LAPACK test routine (version 3.4.0) --
00089 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00090 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00091 *     November 2011
00092 *
00093 *     .. Scalar Arguments ..
00094       INTEGER            KNT, LMAX, NIN, NINFO
00095       REAL               RMAX
00096 *     ..
00097 *
00098 *  =====================================================================
00099 *
00100 *     .. Parameters ..
00101       REAL               ZERO, ONE
00102       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
00103       COMPLEX            CZERO, CONE
00104       PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
00105      $                   CONE = ( 1.0E+0, 0.0E+0 ) )
00106       INTEGER            LDT, LWORK
00107       PARAMETER          ( LDT = 10, LWORK = 2*LDT*LDT )
00108 *     ..
00109 *     .. Local Scalars ..
00110       INTEGER            I, IFST, ILST, INFO1, INFO2, J, N
00111       REAL               EPS, RES
00112       COMPLEX            CTEMP
00113 *     ..
00114 *     .. Local Arrays ..
00115       REAL               RESULT( 2 ), RWORK( LDT )
00116       COMPLEX            DIAG( LDT ), Q( LDT, LDT ), T1( LDT, LDT ),
00117      $                   T2( LDT, LDT ), TMP( LDT, LDT ), WORK( LWORK )
00118 *     ..
00119 *     .. External Functions ..
00120       REAL               SLAMCH
00121       EXTERNAL           SLAMCH
00122 *     ..
00123 *     .. External Subroutines ..
00124       EXTERNAL           CCOPY, CHST01, CLACPY, CLASET, CTREXC
00125 *     ..
00126 *     .. Executable Statements ..
00127 *
00128       EPS = SLAMCH( 'P' )
00129       RMAX = ZERO
00130       LMAX = 0
00131       KNT = 0
00132       NINFO = 0
00133 *
00134 *     Read input data until N=0
00135 *
00136    10 CONTINUE
00137       READ( NIN, FMT = * )N, IFST, ILST
00138       IF( N.EQ.0 )
00139      $   RETURN
00140       KNT = KNT + 1
00141       DO 20 I = 1, N
00142          READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
00143    20 CONTINUE
00144       CALL CLACPY( 'F', N, N, TMP, LDT, T1, LDT )
00145       CALL CLACPY( 'F', N, N, TMP, LDT, T2, LDT )
00146       RES = ZERO
00147 *
00148 *     Test without accumulating Q
00149 *
00150       CALL CLASET( 'Full', N, N, CZERO, CONE, Q, LDT )
00151       CALL CTREXC( 'N', N, T1, LDT, Q, LDT, IFST, ILST, INFO1 )
00152       DO 40 I = 1, N
00153          DO 30 J = 1, N
00154             IF( I.EQ.J .AND. Q( I, J ).NE.CONE )
00155      $         RES = RES + ONE / EPS
00156             IF( I.NE.J .AND. Q( I, J ).NE.CZERO )
00157      $         RES = RES + ONE / EPS
00158    30    CONTINUE
00159    40 CONTINUE
00160 *
00161 *     Test with accumulating Q
00162 *
00163       CALL CLASET( 'Full', N, N, CZERO, CONE, Q, LDT )
00164       CALL CTREXC( 'V', N, T2, LDT, Q, LDT, IFST, ILST, INFO2 )
00165 *
00166 *     Compare T1 with T2
00167 *
00168       DO 60 I = 1, N
00169          DO 50 J = 1, N
00170             IF( T1( I, J ).NE.T2( I, J ) )
00171      $         RES = RES + ONE / EPS
00172    50    CONTINUE
00173    60 CONTINUE
00174       IF( INFO1.NE.0 .OR. INFO2.NE.0 )
00175      $   NINFO = NINFO + 1
00176       IF( INFO1.NE.INFO2 )
00177      $   RES = RES + ONE / EPS
00178 *
00179 *     Test for successful reordering of T2
00180 *
00181       CALL CCOPY( N, TMP, LDT+1, DIAG, 1 )
00182       IF( IFST.LT.ILST ) THEN
00183          DO 70 I = IFST + 1, ILST
00184             CTEMP = DIAG( I )
00185             DIAG( I ) = DIAG( I-1 )
00186             DIAG( I-1 ) = CTEMP
00187    70    CONTINUE
00188       ELSE IF( IFST.GT.ILST ) THEN
00189          DO 80 I = IFST - 1, ILST, -1
00190             CTEMP = DIAG( I+1 )
00191             DIAG( I+1 ) = DIAG( I )
00192             DIAG( I ) = CTEMP
00193    80    CONTINUE
00194       END IF
00195       DO 90 I = 1, N
00196          IF( T2( I, I ).NE.DIAG( I ) )
00197      $      RES = RES + ONE / EPS
00198    90 CONTINUE
00199 *
00200 *     Test for small residual, and orthogonality of Q
00201 *
00202       CALL CHST01( N, 1, N, TMP, LDT, T2, LDT, Q, LDT, WORK, LWORK,
00203      $             RWORK, RESULT )
00204       RES = RES + RESULT( 1 ) + RESULT( 2 )
00205 *
00206 *     Test for T2 being in Schur form
00207 *
00208       DO 110 J = 1, N - 1
00209          DO 100 I = J + 1, N
00210             IF( T2( I, J ).NE.CZERO )
00211      $         RES = RES + ONE / EPS
00212   100    CONTINUE
00213   110 CONTINUE
00214       IF( RES.GT.RMAX ) THEN
00215          RMAX = RES
00216          LMAX = KNT
00217       END IF
00218       GO TO 10
00219 *
00220 *     End of CGET36
00221 *
00222       END
 All Files Functions