![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
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