![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SDRVRF3 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 SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, 00012 * + S_WORK_SLANGE, S_WORK_SGEQRF, TAU ) 00013 * 00014 * .. Scalar Arguments .. 00015 * INTEGER LDA, NN, NOUT 00016 * REAL THRESH 00017 * .. 00018 * .. Array Arguments .. 00019 * INTEGER NVAL( NN ) 00020 * REAL A( LDA, * ), ARF( * ), B1( LDA, * ), 00021 * + B2( LDA, * ), S_WORK_SGEQRF( * ), 00022 * + S_WORK_SLANGE( * ), TAU( * ) 00023 * .. 00024 * 00025 * 00026 *> \par Purpose: 00027 * ============= 00028 *> 00029 *> \verbatim 00030 *> 00031 *> SDRVRF3 tests the LAPACK RFP routines: 00032 *> STFSM 00033 *> \endverbatim 00034 * 00035 * Arguments: 00036 * ========== 00037 * 00038 *> \param[in] NOUT 00039 *> \verbatim 00040 *> NOUT is INTEGER 00041 *> The unit number for output. 00042 *> \endverbatim 00043 *> 00044 *> \param[in] NN 00045 *> \verbatim 00046 *> NN is INTEGER 00047 *> The number of values of N contained in the vector NVAL. 00048 *> \endverbatim 00049 *> 00050 *> \param[in] NVAL 00051 *> \verbatim 00052 *> NVAL is INTEGER array, dimension (NN) 00053 *> The values of the matrix dimension N. 00054 *> \endverbatim 00055 *> 00056 *> \param[in] THRESH 00057 *> \verbatim 00058 *> THRESH is REAL 00059 *> The threshold value for the test ratios. A result is 00060 *> included in the output file if RESULT >= THRESH. To have 00061 *> every test ratio printed, use THRESH = 0. 00062 *> \endverbatim 00063 *> 00064 *> \param[out] A 00065 *> \verbatim 00066 *> A is REAL array, dimension (LDA,NMAX) 00067 *> \endverbatim 00068 *> 00069 *> \param[in] LDA 00070 *> \verbatim 00071 *> LDA is INTEGER 00072 *> The leading dimension of the array A. LDA >= max(1,NMAX). 00073 *> \endverbatim 00074 *> 00075 *> \param[out] ARF 00076 *> \verbatim 00077 *> ARF is REAL array, dimension ((NMAX*(NMAX+1))/2). 00078 *> \endverbatim 00079 *> 00080 *> \param[out] B1 00081 *> \verbatim 00082 *> B1 is REAL array, dimension (LDA,NMAX) 00083 *> \endverbatim 00084 *> 00085 *> \param[out] B2 00086 *> \verbatim 00087 *> B2 is REAL array, dimension (LDA,NMAX) 00088 *> \endverbatim 00089 *> 00090 *> \param[out] S_WORK_SLANGE 00091 *> \verbatim 00092 *> S_WORK_SLANGE is REAL array, dimension (NMAX) 00093 *> \endverbatim 00094 *> 00095 *> \param[out] S_WORK_SGEQRF 00096 *> \verbatim 00097 *> S_WORK_SGEQRF is REAL array, dimension (NMAX) 00098 *> \endverbatim 00099 *> 00100 *> \param[out] TAU 00101 *> \verbatim 00102 *> TAU is REAL array, dimension (NMAX) 00103 *> \endverbatim 00104 * 00105 * Authors: 00106 * ======== 00107 * 00108 *> \author Univ. of Tennessee 00109 *> \author Univ. of California Berkeley 00110 *> \author Univ. of Colorado Denver 00111 *> \author NAG Ltd. 00112 * 00113 *> \date November 2011 00114 * 00115 *> \ingroup single_lin 00116 * 00117 * ===================================================================== 00118 SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, 00119 + S_WORK_SLANGE, S_WORK_SGEQRF, TAU ) 00120 * 00121 * -- LAPACK test routine (version 3.4.0) -- 00122 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00123 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00124 * November 2011 00125 * 00126 * .. Scalar Arguments .. 00127 INTEGER LDA, NN, NOUT 00128 REAL THRESH 00129 * .. 00130 * .. Array Arguments .. 00131 INTEGER NVAL( NN ) 00132 REAL A( LDA, * ), ARF( * ), B1( LDA, * ), 00133 + B2( LDA, * ), S_WORK_SGEQRF( * ), 00134 + S_WORK_SLANGE( * ), TAU( * ) 00135 * .. 00136 * 00137 * ===================================================================== 00138 * .. 00139 * .. Parameters .. 00140 REAL ZERO, ONE 00141 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) , 00142 + ONE = ( 1.0E+0, 0.0E+0 ) ) 00143 INTEGER NTESTS 00144 PARAMETER ( NTESTS = 1 ) 00145 * .. 00146 * .. Local Scalars .. 00147 CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE 00148 INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA, 00149 + NFAIL, NRUN, ISIDE, IDIAG, IALPHA, ITRANS 00150 REAL EPS, ALPHA 00151 * .. 00152 * .. Local Arrays .. 00153 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ), 00154 + DIAGS( 2 ), SIDES( 2 ) 00155 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00156 REAL RESULT( NTESTS ) 00157 * .. 00158 * .. External Functions .. 00159 REAL SLAMCH, SLANGE, SLARND 00160 EXTERNAL SLAMCH, SLANGE, SLARND 00161 * .. 00162 * .. External Subroutines .. 00163 EXTERNAL STRTTF, SGEQRF, SGEQLF, STFSM, STRSM 00164 * .. 00165 * .. Intrinsic Functions .. 00166 INTRINSIC MAX, SQRT 00167 * .. 00168 * .. Scalars in Common .. 00169 CHARACTER*32 SRNAMT 00170 * .. 00171 * .. Common blocks .. 00172 COMMON / SRNAMC / SRNAMT 00173 * .. 00174 * .. Data statements .. 00175 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00176 DATA UPLOS / 'U', 'L' / 00177 DATA FORMS / 'N', 'T' / 00178 DATA SIDES / 'L', 'R' / 00179 DATA TRANSS / 'N', 'T' / 00180 DATA DIAGS / 'N', 'U' / 00181 * .. 00182 * .. Executable Statements .. 00183 * 00184 * Initialize constants and the random number seed. 00185 * 00186 NRUN = 0 00187 NFAIL = 0 00188 INFO = 0 00189 DO 10 I = 1, 4 00190 ISEED( I ) = ISEEDY( I ) 00191 10 CONTINUE 00192 EPS = SLAMCH( 'Precision' ) 00193 * 00194 DO 170 IIM = 1, NN 00195 * 00196 M = NVAL( IIM ) 00197 * 00198 DO 160 IIN = 1, NN 00199 * 00200 N = NVAL( IIN ) 00201 * 00202 DO 150 IFORM = 1, 2 00203 * 00204 CFORM = FORMS( IFORM ) 00205 * 00206 DO 140 IUPLO = 1, 2 00207 * 00208 UPLO = UPLOS( IUPLO ) 00209 * 00210 DO 130 ISIDE = 1, 2 00211 * 00212 SIDE = SIDES( ISIDE ) 00213 * 00214 DO 120 ITRANS = 1, 2 00215 * 00216 TRANS = TRANSS( ITRANS ) 00217 * 00218 DO 110 IDIAG = 1, 2 00219 * 00220 DIAG = DIAGS( IDIAG ) 00221 * 00222 DO 100 IALPHA = 1, 3 00223 * 00224 IF ( IALPHA.EQ. 1) THEN 00225 ALPHA = ZERO 00226 ELSE IF ( IALPHA.EQ. 1) THEN 00227 ALPHA = ONE 00228 ELSE 00229 ALPHA = SLARND( 2, ISEED ) 00230 END IF 00231 * 00232 * All the parameters are set: 00233 * CFORM, SIDE, UPLO, TRANS, DIAG, M, N, 00234 * and ALPHA 00235 * READY TO TEST! 00236 * 00237 NRUN = NRUN + 1 00238 * 00239 IF ( ISIDE.EQ.1 ) THEN 00240 * 00241 * The case ISIDE.EQ.1 is when SIDE.EQ.'L' 00242 * -> A is M-by-M ( B is M-by-N ) 00243 * 00244 NA = M 00245 * 00246 ELSE 00247 * 00248 * The case ISIDE.EQ.2 is when SIDE.EQ.'R' 00249 * -> A is N-by-N ( B is M-by-N ) 00250 * 00251 NA = N 00252 * 00253 END IF 00254 * 00255 * Generate A our NA--by--NA triangular 00256 * matrix. 00257 * Our test is based on forward error so we 00258 * do want A to be well conditionned! To get 00259 * a well-conditionned triangular matrix, we 00260 * take the R factor of the QR/LQ factorization 00261 * of a random matrix. 00262 * 00263 DO J = 1, NA 00264 DO I = 1, NA 00265 A( I, J) = SLARND( 2, ISEED ) 00266 END DO 00267 END DO 00268 * 00269 IF ( IUPLO.EQ.1 ) THEN 00270 * 00271 * The case IUPLO.EQ.1 is when SIDE.EQ.'U' 00272 * -> QR factorization. 00273 * 00274 SRNAMT = 'SGEQRF' 00275 CALL SGEQRF( NA, NA, A, LDA, TAU, 00276 + S_WORK_SGEQRF, LDA, 00277 + INFO ) 00278 ELSE 00279 * 00280 * The case IUPLO.EQ.2 is when SIDE.EQ.'L' 00281 * -> QL factorization. 00282 * 00283 SRNAMT = 'SGELQF' 00284 CALL SGELQF( NA, NA, A, LDA, TAU, 00285 + S_WORK_SGEQRF, LDA, 00286 + INFO ) 00287 END IF 00288 * 00289 * Store a copy of A in RFP format (in ARF). 00290 * 00291 SRNAMT = 'STRTTF' 00292 CALL STRTTF( CFORM, UPLO, NA, A, LDA, ARF, 00293 + INFO ) 00294 * 00295 * Generate B1 our M--by--N right-hand side 00296 * and store a copy in B2. 00297 * 00298 DO J = 1, N 00299 DO I = 1, M 00300 B1( I, J) = SLARND( 2, ISEED ) 00301 B2( I, J) = B1( I, J) 00302 END DO 00303 END DO 00304 * 00305 * Solve op( A ) X = B or X op( A ) = B 00306 * with STRSM 00307 * 00308 SRNAMT = 'STRSM' 00309 CALL STRSM( SIDE, UPLO, TRANS, DIAG, M, N, 00310 + ALPHA, A, LDA, B1, LDA ) 00311 * 00312 * Solve op( A ) X = B or X op( A ) = B 00313 * with STFSM 00314 * 00315 SRNAMT = 'STFSM' 00316 CALL STFSM( CFORM, SIDE, UPLO, TRANS, 00317 + DIAG, M, N, ALPHA, ARF, B2, 00318 + LDA ) 00319 * 00320 * Check that the result agrees. 00321 * 00322 DO J = 1, N 00323 DO I = 1, M 00324 B1( I, J) = B2( I, J ) - B1( I, J ) 00325 END DO 00326 END DO 00327 * 00328 RESULT(1) = SLANGE( 'I', M, N, B1, LDA, 00329 + S_WORK_SLANGE ) 00330 * 00331 RESULT(1) = RESULT(1) / SQRT( EPS ) 00332 + / MAX ( MAX( M, N), 1 ) 00333 * 00334 IF( RESULT(1).GE.THRESH ) THEN 00335 IF( NFAIL.EQ.0 ) THEN 00336 WRITE( NOUT, * ) 00337 WRITE( NOUT, FMT = 9999 ) 00338 END IF 00339 WRITE( NOUT, FMT = 9997 ) 'STFSM', 00340 + CFORM, SIDE, UPLO, TRANS, DIAG, M, 00341 + N, RESULT(1) 00342 NFAIL = NFAIL + 1 00343 END IF 00344 * 00345 100 CONTINUE 00346 110 CONTINUE 00347 120 CONTINUE 00348 130 CONTINUE 00349 140 CONTINUE 00350 150 CONTINUE 00351 160 CONTINUE 00352 170 CONTINUE 00353 * 00354 * Print a summary of the results. 00355 * 00356 IF ( NFAIL.EQ.0 ) THEN 00357 WRITE( NOUT, FMT = 9996 ) 'STFSM', NRUN 00358 ELSE 00359 WRITE( NOUT, FMT = 9995 ) 'STFSM', NFAIL, NRUN 00360 END IF 00361 * 00362 9999 FORMAT( 1X, 00363 ' *** Error(s) or Failure(s) while testing STFSM + ***') 00364 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', 00365 + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',', 00366 + ' DIAG=''',A1,''',',' M=',I3,', N =', I3,', test=',G12.5) 00367 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ', 00368 + 'threshold ( ',I5,' tests run)') 00369 9995 FORMAT( 1X, A6, ' auxiliary routine: ',I5,' out of ',I5, 00370 + ' tests failed to pass the threshold') 00371 * 00372 RETURN 00373 * 00374 * End of SDRVRF3 00375 * 00376 END