1*> \brief \b SDRVRF3 2* 3* =========== DOCUMENTATION =========== 4* 5* Online html documentation available at 6* http://www.netlib.org/lapack/explore-html/ 7* 8* Definition: 9* =========== 10* 11* SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, 12* + S_WORK_SLANGE, S_WORK_SGEQRF, TAU ) 13* 14* .. Scalar Arguments .. 15* INTEGER LDA, NN, NOUT 16* REAL THRESH 17* .. 18* .. Array Arguments .. 19* INTEGER NVAL( NN ) 20* REAL A( LDA, * ), ARF( * ), B1( LDA, * ), 21* + B2( LDA, * ), S_WORK_SGEQRF( * ), 22* + S_WORK_SLANGE( * ), TAU( * ) 23* .. 24* 25* 26*> \par Purpose: 27* ============= 28*> 29*> \verbatim 30*> 31*> SDRVRF3 tests the LAPACK RFP routines: 32*> STFSM 33*> \endverbatim 34* 35* Arguments: 36* ========== 37* 38*> \param[in] NOUT 39*> \verbatim 40*> NOUT is INTEGER 41*> The unit number for output. 42*> \endverbatim 43*> 44*> \param[in] NN 45*> \verbatim 46*> NN is INTEGER 47*> The number of values of N contained in the vector NVAL. 48*> \endverbatim 49*> 50*> \param[in] NVAL 51*> \verbatim 52*> NVAL is INTEGER array, dimension (NN) 53*> The values of the matrix dimension N. 54*> \endverbatim 55*> 56*> \param[in] THRESH 57*> \verbatim 58*> THRESH is REAL 59*> The threshold value for the test ratios. A result is 60*> included in the output file if RESULT >= THRESH. To have 61*> every test ratio printed, use THRESH = 0. 62*> \endverbatim 63*> 64*> \param[out] A 65*> \verbatim 66*> A is REAL array, dimension (LDA,NMAX) 67*> \endverbatim 68*> 69*> \param[in] LDA 70*> \verbatim 71*> LDA is INTEGER 72*> The leading dimension of the array A. LDA >= max(1,NMAX). 73*> \endverbatim 74*> 75*> \param[out] ARF 76*> \verbatim 77*> ARF is REAL array, dimension ((NMAX*(NMAX+1))/2). 78*> \endverbatim 79*> 80*> \param[out] B1 81*> \verbatim 82*> B1 is REAL array, dimension (LDA,NMAX) 83*> \endverbatim 84*> 85*> \param[out] B2 86*> \verbatim 87*> B2 is REAL array, dimension (LDA,NMAX) 88*> \endverbatim 89*> 90*> \param[out] S_WORK_SLANGE 91*> \verbatim 92*> S_WORK_SLANGE is REAL array, dimension (NMAX) 93*> \endverbatim 94*> 95*> \param[out] S_WORK_SGEQRF 96*> \verbatim 97*> S_WORK_SGEQRF is REAL array, dimension (NMAX) 98*> \endverbatim 99*> 100*> \param[out] TAU 101*> \verbatim 102*> TAU is REAL array, dimension (NMAX) 103*> \endverbatim 104* 105* Authors: 106* ======== 107* 108*> \author Univ. of Tennessee 109*> \author Univ. of California Berkeley 110*> \author Univ. of Colorado Denver 111*> \author NAG Ltd. 112* 113*> \ingroup single_lin 114* 115* ===================================================================== 116 SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, 117 + S_WORK_SLANGE, S_WORK_SGEQRF, TAU ) 118* 119* -- LAPACK test routine -- 120* -- LAPACK is a software package provided by Univ. of Tennessee, -- 121* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 122* 123* .. Scalar Arguments .. 124 INTEGER LDA, NN, NOUT 125 REAL THRESH 126* .. 127* .. Array Arguments .. 128 INTEGER NVAL( NN ) 129 REAL A( LDA, * ), ARF( * ), B1( LDA, * ), 130 + B2( LDA, * ), S_WORK_SGEQRF( * ), 131 + S_WORK_SLANGE( * ), TAU( * ) 132* .. 133* 134* ===================================================================== 135* .. 136* .. Parameters .. 137 REAL ZERO, ONE 138 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) , 139 + ONE = ( 1.0E+0, 0.0E+0 ) ) 140 INTEGER NTESTS 141 PARAMETER ( NTESTS = 1 ) 142* .. 143* .. Local Scalars .. 144 CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE 145 INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA, 146 + NFAIL, NRUN, ISIDE, IDIAG, IALPHA, ITRANS 147 REAL EPS, ALPHA 148* .. 149* .. Local Arrays .. 150 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ), 151 + DIAGS( 2 ), SIDES( 2 ) 152 INTEGER ISEED( 4 ), ISEEDY( 4 ) 153 REAL RESULT( NTESTS ) 154* .. 155* .. External Functions .. 156 REAL SLAMCH, SLANGE, SLARND 157 EXTERNAL SLAMCH, SLANGE, SLARND 158* .. 159* .. External Subroutines .. 160 EXTERNAL STRTTF, SGEQRF, SGEQLF, STFSM, STRSM 161* .. 162* .. Intrinsic Functions .. 163 INTRINSIC MAX, SQRT 164* .. 165* .. Scalars in Common .. 166 CHARACTER*32 SRNAMT 167* .. 168* .. Common blocks .. 169 COMMON / SRNAMC / SRNAMT 170* .. 171* .. Data statements .. 172 DATA ISEEDY / 1988, 1989, 1990, 1991 / 173 DATA UPLOS / 'U', 'L' / 174 DATA FORMS / 'N', 'T' / 175 DATA SIDES / 'L', 'R' / 176 DATA TRANSS / 'N', 'T' / 177 DATA DIAGS / 'N', 'U' / 178* .. 179* .. Executable Statements .. 180* 181* Initialize constants and the random number seed. 182* 183 NRUN = 0 184 NFAIL = 0 185 INFO = 0 186 DO 10 I = 1, 4 187 ISEED( I ) = ISEEDY( I ) 188 10 CONTINUE 189 EPS = SLAMCH( 'Precision' ) 190* 191 DO 170 IIM = 1, NN 192* 193 M = NVAL( IIM ) 194* 195 DO 160 IIN = 1, NN 196* 197 N = NVAL( IIN ) 198* 199 DO 150 IFORM = 1, 2 200* 201 CFORM = FORMS( IFORM ) 202* 203 DO 140 IUPLO = 1, 2 204* 205 UPLO = UPLOS( IUPLO ) 206* 207 DO 130 ISIDE = 1, 2 208* 209 SIDE = SIDES( ISIDE ) 210* 211 DO 120 ITRANS = 1, 2 212* 213 TRANS = TRANSS( ITRANS ) 214* 215 DO 110 IDIAG = 1, 2 216* 217 DIAG = DIAGS( IDIAG ) 218* 219 DO 100 IALPHA = 1, 3 220* 221 IF ( IALPHA.EQ. 1) THEN 222 ALPHA = ZERO 223 ELSE IF ( IALPHA.EQ. 2) THEN 224 ALPHA = ONE 225 ELSE 226 ALPHA = SLARND( 2, ISEED ) 227 END IF 228* 229* All the parameters are set: 230* CFORM, SIDE, UPLO, TRANS, DIAG, M, N, 231* and ALPHA 232* READY TO TEST! 233* 234 NRUN = NRUN + 1 235* 236 IF ( ISIDE.EQ.1 ) THEN 237* 238* The case ISIDE.EQ.1 is when SIDE.EQ.'L' 239* -> A is M-by-M ( B is M-by-N ) 240* 241 NA = M 242* 243 ELSE 244* 245* The case ISIDE.EQ.2 is when SIDE.EQ.'R' 246* -> A is N-by-N ( B is M-by-N ) 247* 248 NA = N 249* 250 END IF 251* 252* Generate A our NA--by--NA triangular 253* matrix. 254* Our test is based on forward error so we 255* do want A to be well conditioned! To get 256* a well-conditioned triangular matrix, we 257* take the R factor of the QR/LQ factorization 258* of a random matrix. 259* 260 DO J = 1, NA 261 DO I = 1, NA 262 A( I, J) = SLARND( 2, ISEED ) 263 END DO 264 END DO 265* 266 IF ( IUPLO.EQ.1 ) THEN 267* 268* The case IUPLO.EQ.1 is when SIDE.EQ.'U' 269* -> QR factorization. 270* 271 SRNAMT = 'SGEQRF' 272 CALL SGEQRF( NA, NA, A, LDA, TAU, 273 + S_WORK_SGEQRF, LDA, 274 + INFO ) 275 ELSE 276* 277* The case IUPLO.EQ.2 is when SIDE.EQ.'L' 278* -> QL factorization. 279* 280 SRNAMT = 'SGELQF' 281 CALL SGELQF( NA, NA, A, LDA, TAU, 282 + S_WORK_SGEQRF, LDA, 283 + INFO ) 284 END IF 285* 286* Store a copy of A in RFP format (in ARF). 287* 288 SRNAMT = 'STRTTF' 289 CALL STRTTF( CFORM, UPLO, NA, A, LDA, ARF, 290 + INFO ) 291* 292* Generate B1 our M--by--N right-hand side 293* and store a copy in B2. 294* 295 DO J = 1, N 296 DO I = 1, M 297 B1( I, J) = SLARND( 2, ISEED ) 298 B2( I, J) = B1( I, J) 299 END DO 300 END DO 301* 302* Solve op( A ) X = B or X op( A ) = B 303* with STRSM 304* 305 SRNAMT = 'STRSM' 306 CALL STRSM( SIDE, UPLO, TRANS, DIAG, M, N, 307 + ALPHA, A, LDA, B1, LDA ) 308* 309* Solve op( A ) X = B or X op( A ) = B 310* with STFSM 311* 312 SRNAMT = 'STFSM' 313 CALL STFSM( CFORM, SIDE, UPLO, TRANS, 314 + DIAG, M, N, ALPHA, ARF, B2, 315 + LDA ) 316* 317* Check that the result agrees. 318* 319 DO J = 1, N 320 DO I = 1, M 321 B1( I, J) = B2( I, J ) - B1( I, J ) 322 END DO 323 END DO 324* 325 RESULT(1) = SLANGE( 'I', M, N, B1, LDA, 326 + S_WORK_SLANGE ) 327* 328 RESULT(1) = RESULT(1) / SQRT( EPS ) 329 + / MAX ( MAX( M, N), 1 ) 330* 331 IF( RESULT(1).GE.THRESH ) THEN 332 IF( NFAIL.EQ.0 ) THEN 333 WRITE( NOUT, * ) 334 WRITE( NOUT, FMT = 9999 ) 335 END IF 336 WRITE( NOUT, FMT = 9997 ) 'STFSM', 337 + CFORM, SIDE, UPLO, TRANS, DIAG, M, 338 + N, RESULT(1) 339 NFAIL = NFAIL + 1 340 END IF 341* 342 100 CONTINUE 343 110 CONTINUE 344 120 CONTINUE 345 130 CONTINUE 346 140 CONTINUE 347 150 CONTINUE 348 160 CONTINUE 349 170 CONTINUE 350* 351* Print a summary of the results. 352* 353 IF ( NFAIL.EQ.0 ) THEN 354 WRITE( NOUT, FMT = 9996 ) 'STFSM', NRUN 355 ELSE 356 WRITE( NOUT, FMT = 9995 ) 'STFSM', NFAIL, NRUN 357 END IF 358* 359 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing STFSM 360 + ***') 361 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', 362 + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',', 363 + ' DIAG=''',A1,''',',' M=',I3,', N =', I3,', test=',G12.5) 364 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ', 365 + 'threshold ( ',I5,' tests run)') 366 9995 FORMAT( 1X, A6, ' auxiliary routine: ',I5,' out of ',I5, 367 + ' tests failed to pass the threshold') 368* 369 RETURN 370* 371* End of SDRVRF3 372* 373 END 374