![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SGET35 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 SGET35( RMAX, LMAX, NINFO, KNT ) 00012 * 00013 * .. Scalar Arguments .. 00014 * INTEGER KNT, LMAX, NINFO 00015 * REAL RMAX 00016 * .. 00017 * 00018 * 00019 *> \par Purpose: 00020 * ============= 00021 *> 00022 *> \verbatim 00023 *> 00024 *> SGET35 tests STRSYL, a routine for solving the Sylvester matrix 00025 *> equation 00026 *> 00027 *> op(A)*X + ISGN*X*op(B) = scale*C, 00028 *> 00029 *> A and B are assumed to be in Schur canonical form, op() represents an 00030 *> optional transpose, and ISGN can be -1 or +1. Scale is an output 00031 *> less than or equal to 1, chosen to avoid overflow in X. 00032 *> 00033 *> The test code verifies that the following residual is order 1: 00034 *> 00035 *> norm(op(A)*X + ISGN*X*op(B) - scale*C) / 00036 *> (EPS*max(norm(A),norm(B))*norm(X)) 00037 *> \endverbatim 00038 * 00039 * Arguments: 00040 * ========== 00041 * 00042 *> \param[out] RMAX 00043 *> \verbatim 00044 *> RMAX is REAL 00045 *> Value of the largest test ratio. 00046 *> \endverbatim 00047 *> 00048 *> \param[out] LMAX 00049 *> \verbatim 00050 *> LMAX is INTEGER 00051 *> Example number where largest test ratio achieved. 00052 *> \endverbatim 00053 *> 00054 *> \param[out] NINFO 00055 *> \verbatim 00056 *> NINFO is INTEGER 00057 *> Number of examples where INFO is nonzero. 00058 *> \endverbatim 00059 *> 00060 *> \param[out] KNT 00061 *> \verbatim 00062 *> KNT is INTEGER 00063 *> Total number of examples tested. 00064 *> \endverbatim 00065 * 00066 * Authors: 00067 * ======== 00068 * 00069 *> \author Univ. of Tennessee 00070 *> \author Univ. of California Berkeley 00071 *> \author Univ. of Colorado Denver 00072 *> \author NAG Ltd. 00073 * 00074 *> \date November 2011 00075 * 00076 *> \ingroup single_eig 00077 * 00078 * ===================================================================== 00079 SUBROUTINE SGET35( RMAX, LMAX, NINFO, KNT ) 00080 * 00081 * -- LAPACK test routine (version 3.4.0) -- 00082 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00083 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00084 * November 2011 00085 * 00086 * .. Scalar Arguments .. 00087 INTEGER KNT, LMAX, NINFO 00088 REAL RMAX 00089 * .. 00090 * 00091 * ===================================================================== 00092 * 00093 * .. Parameters .. 00094 REAL ZERO, ONE 00095 PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) 00096 REAL TWO, FOUR 00097 PARAMETER ( TWO = 2.0E0, FOUR = 4.0E0 ) 00098 * .. 00099 * .. Local Scalars .. 00100 CHARACTER TRANA, TRANB 00101 INTEGER I, IMA, IMB, IMLDA1, IMLDA2, IMLDB1, IMLOFF, 00102 $ INFO, ISGN, ITRANA, ITRANB, J, M, N 00103 REAL BIGNUM, CNRM, EPS, RES, RES1, RMUL, SCALE, 00104 $ SMLNUM, TNRM, XNRM 00105 * .. 00106 * .. Local Arrays .. 00107 INTEGER IDIM( 8 ), IVAL( 6, 6, 8 ) 00108 REAL A( 6, 6 ), B( 6, 6 ), C( 6, 6 ), CC( 6, 6 ), 00109 $ DUM( 1 ), VM1( 3 ), VM2( 3 ) 00110 * .. 00111 * .. External Functions .. 00112 REAL SLAMCH, SLANGE 00113 EXTERNAL SLAMCH, SLANGE 00114 * .. 00115 * .. External Subroutines .. 00116 EXTERNAL SGEMM, STRSYL 00117 * .. 00118 * .. Intrinsic Functions .. 00119 INTRINSIC ABS, MAX, REAL, SIN, SQRT 00120 * .. 00121 * .. Data statements .. 00122 DATA IDIM / 1, 2, 3, 4, 3, 3, 6, 4 / 00123 DATA IVAL / 1, 35*0, 1, 2, 4*0, -2, 0, 28*0, 1, 5*0, 00124 $ 5, 1, 2, 3*0, -8, -2, 1, 21*0, 3, 4, 4*0, -5, 00125 $ 3, 4*0, 1, 2, 1, 4, 2*0, -3, -9, -1, 1, 14*0, 00126 $ 1, 5*0, 2, 3, 4*0, 5, 6, 7, 21*0, 1, 5*0, 1, 3, 00127 $ -4, 3*0, 2, 5, 2, 21*0, 1, 2, 4*0, -2, 0, 4*0, 00128 $ 5, 6, 3, 4, 2*0, -1, -9, -5, 2, 2*0, 4*8, 5, 6, 00129 $ 4*9, -7, 5, 1, 5*0, 1, 5, 2, 3*0, 2, -21, 5, 00130 $ 3*0, 1, 2, 3, 4, 14*0 / 00131 * .. 00132 * .. Executable Statements .. 00133 * 00134 * Get machine parameters 00135 * 00136 EPS = SLAMCH( 'P' ) 00137 SMLNUM = SLAMCH( 'S' )*FOUR / EPS 00138 BIGNUM = ONE / SMLNUM 00139 CALL SLABAD( SMLNUM, BIGNUM ) 00140 * 00141 * Set up test case parameters 00142 * 00143 VM1( 1 ) = SQRT( SMLNUM ) 00144 VM1( 2 ) = ONE 00145 VM1( 3 ) = SQRT( BIGNUM ) 00146 VM2( 1 ) = ONE 00147 VM2( 2 ) = ONE + TWO*EPS 00148 VM2( 3 ) = TWO 00149 * 00150 KNT = 0 00151 NINFO = 0 00152 LMAX = 0 00153 RMAX = ZERO 00154 * 00155 * Begin test loop 00156 * 00157 DO 150 ITRANA = 1, 2 00158 DO 140 ITRANB = 1, 2 00159 DO 130 ISGN = -1, 1, 2 00160 DO 120 IMA = 1, 8 00161 DO 110 IMLDA1 = 1, 3 00162 DO 100 IMLDA2 = 1, 3 00163 DO 90 IMLOFF = 1, 2 00164 DO 80 IMB = 1, 8 00165 DO 70 IMLDB1 = 1, 3 00166 IF( ITRANA.EQ.1 ) 00167 $ TRANA = 'N' 00168 IF( ITRANA.EQ.2 ) 00169 $ TRANA = 'T' 00170 IF( ITRANB.EQ.1 ) 00171 $ TRANB = 'N' 00172 IF( ITRANB.EQ.2 ) 00173 $ TRANB = 'T' 00174 M = IDIM( IMA ) 00175 N = IDIM( IMB ) 00176 TNRM = ZERO 00177 DO 20 I = 1, M 00178 DO 10 J = 1, M 00179 A( I, J ) = IVAL( I, J, IMA ) 00180 IF( ABS( I-J ).LE.1 ) THEN 00181 A( I, J ) = A( I, J )* 00182 $ VM1( IMLDA1 ) 00183 A( I, J ) = A( I, J )* 00184 $ VM2( IMLDA2 ) 00185 ELSE 00186 A( I, J ) = A( I, J )* 00187 $ VM1( IMLOFF ) 00188 END IF 00189 TNRM = MAX( TNRM, 00190 $ ABS( A( I, J ) ) ) 00191 10 CONTINUE 00192 20 CONTINUE 00193 DO 40 I = 1, N 00194 DO 30 J = 1, N 00195 B( I, J ) = IVAL( I, J, IMB ) 00196 IF( ABS( I-J ).LE.1 ) THEN 00197 B( I, J ) = B( I, J )* 00198 $ VM1( IMLDB1 ) 00199 ELSE 00200 B( I, J ) = B( I, J )* 00201 $ VM1( IMLOFF ) 00202 END IF 00203 TNRM = MAX( TNRM, 00204 $ ABS( B( I, J ) ) ) 00205 30 CONTINUE 00206 40 CONTINUE 00207 CNRM = ZERO 00208 DO 60 I = 1, M 00209 DO 50 J = 1, N 00210 C( I, J ) = SIN( REAL( I*J ) ) 00211 CNRM = MAX( CNRM, C( I, J ) ) 00212 CC( I, J ) = C( I, J ) 00213 50 CONTINUE 00214 60 CONTINUE 00215 KNT = KNT + 1 00216 CALL STRSYL( TRANA, TRANB, ISGN, M, N, 00217 $ A, 6, B, 6, C, 6, SCALE, 00218 $ INFO ) 00219 IF( INFO.NE.0 ) 00220 $ NINFO = NINFO + 1 00221 XNRM = SLANGE( 'M', M, N, C, 6, DUM ) 00222 RMUL = ONE 00223 IF( XNRM.GT.ONE .AND. TNRM.GT.ONE ) 00224 $ THEN 00225 IF( XNRM.GT.BIGNUM / TNRM ) THEN 00226 RMUL = ONE / MAX( XNRM, TNRM ) 00227 END IF 00228 END IF 00229 CALL SGEMM( TRANA, 'N', M, N, M, RMUL, 00230 $ A, 6, C, 6, -SCALE*RMUL, 00231 $ CC, 6 ) 00232 CALL SGEMM( 'N', TRANB, M, N, N, 00233 $ REAL( ISGN )*RMUL, C, 6, B, 00234 $ 6, ONE, CC, 6 ) 00235 RES1 = SLANGE( 'M', M, N, CC, 6, DUM ) 00236 RES = RES1 / MAX( SMLNUM, SMLNUM*XNRM, 00237 $ ( ( RMUL*TNRM )*EPS )*XNRM ) 00238 IF( RES.GT.RMAX ) THEN 00239 LMAX = KNT 00240 RMAX = RES 00241 END IF 00242 70 CONTINUE 00243 80 CONTINUE 00244 90 CONTINUE 00245 100 CONTINUE 00246 110 CONTINUE 00247 120 CONTINUE 00248 130 CONTINUE 00249 140 CONTINUE 00250 150 CONTINUE 00251 * 00252 RETURN 00253 * 00254 * End of SGET35 00255 * 00256 END