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*> \date June 2017 114* 115*> \ingroup single_lin 116* 117* ===================================================================== 118 SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, 119 + S_WORK_SLANGE, S_WORK_SGEQRF, TAU ) 120* 121* -- LAPACK test routine (version 3.7.1) -- 122* -- LAPACK is a software package provided by Univ. of Tennessee, -- 123* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 124* June 2017 125* 126* .. Scalar Arguments .. 127 INTEGER LDA, NN, NOUT 128 REAL THRESH 129* .. 130* .. Array Arguments .. 131 INTEGER NVAL( NN ) 132 REAL A( LDA, * ), ARF( * ), B1( LDA, * ), 133 + B2( LDA, * ), S_WORK_SGEQRF( * ), 134 + S_WORK_SLANGE( * ), TAU( * ) 135* .. 136* 137* ===================================================================== 138* .. 139* .. Parameters .. 140 REAL ZERO, ONE 141 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) , 142 + ONE = ( 1.0E+0, 0.0E+0 ) ) 143 INTEGER NTESTS 144 PARAMETER ( NTESTS = 1 ) 145* .. 146* .. Local Scalars .. 147 CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE 148 INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA, 149 + NFAIL, NRUN, ISIDE, IDIAG, IALPHA, ITRANS 150 REAL EPS, ALPHA 151* .. 152* .. Local Arrays .. 153 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ), 154 + DIAGS( 2 ), SIDES( 2 ) 155 INTEGER ISEED( 4 ), ISEEDY( 4 ) 156 REAL RESULT( NTESTS ) 157* .. 158* .. External Functions .. 159 REAL SLAMCH, SLANGE, SLARND 160 EXTERNAL SLAMCH, SLANGE, SLARND 161* .. 162* .. External Subroutines .. 163 EXTERNAL STRTTF, SGEQRF, SGEQLF, STFSM, STRSM 164* .. 165* .. Intrinsic Functions .. 166 INTRINSIC MAX, SQRT 167* .. 168* .. Scalars in Common .. 169 CHARACTER*32 SRNAMT 170* .. 171* .. Common blocks .. 172 COMMON / SRNAMC / SRNAMT 173* .. 174* .. Data statements .. 175 DATA ISEEDY / 1988, 1989, 1990, 1991 / 176 DATA UPLOS / 'U', 'L' / 177 DATA FORMS / 'N', 'T' / 178 DATA SIDES / 'L', 'R' / 179 DATA TRANSS / 'N', 'T' / 180 DATA DIAGS / 'N', 'U' / 181* .. 182* .. Executable Statements .. 183* 184* Initialize constants and the random number seed. 185* 186 NRUN = 0 187 NFAIL = 0 188 INFO = 0 189 DO 10 I = 1, 4 190 ISEED( I ) = ISEEDY( I ) 191 10 CONTINUE 192 EPS = SLAMCH( 'Precision' ) 193* 194 DO 170 IIM = 1, NN 195* 196 M = NVAL( IIM ) 197* 198 DO 160 IIN = 1, NN 199* 200 N = NVAL( IIN ) 201* 202 DO 150 IFORM = 1, 2 203* 204 CFORM = FORMS( IFORM ) 205* 206 DO 140 IUPLO = 1, 2 207* 208 UPLO = UPLOS( IUPLO ) 209* 210 DO 130 ISIDE = 1, 2 211* 212 SIDE = SIDES( ISIDE ) 213* 214 DO 120 ITRANS = 1, 2 215* 216 TRANS = TRANSS( ITRANS ) 217* 218 DO 110 IDIAG = 1, 2 219* 220 DIAG = DIAGS( IDIAG ) 221* 222 DO 100 IALPHA = 1, 3 223* 224 IF ( IALPHA.EQ. 1) THEN 225 ALPHA = ZERO 226 ELSE IF ( IALPHA.EQ. 2) THEN 227 ALPHA = ONE 228 ELSE 229 ALPHA = SLARND( 2, ISEED ) 230 END IF 231* 232* All the parameters are set: 233* CFORM, SIDE, UPLO, TRANS, DIAG, M, N, 234* and ALPHA 235* READY TO TEST! 236* 237 NRUN = NRUN + 1 238* 239 IF ( ISIDE.EQ.1 ) THEN 240* 241* The case ISIDE.EQ.1 is when SIDE.EQ.'L' 242* -> A is M-by-M ( B is M-by-N ) 243* 244 NA = M 245* 246 ELSE 247* 248* The case ISIDE.EQ.2 is when SIDE.EQ.'R' 249* -> A is N-by-N ( B is M-by-N ) 250* 251 NA = N 252* 253 END IF 254* 255* Generate A our NA--by--NA triangular 256* matrix. 257* Our test is based on forward error so we 258* do want A to be well conditionned! To get 259* a well-conditionned triangular matrix, we 260* take the R factor of the QR/LQ factorization 261* of a random matrix. 262* 263 DO J = 1, NA 264 DO I = 1, NA 265 A( I, J) = SLARND( 2, ISEED ) 266 END DO 267 END DO 268* 269 IF ( IUPLO.EQ.1 ) THEN 270* 271* The case IUPLO.EQ.1 is when SIDE.EQ.'U' 272* -> QR factorization. 273* 274 SRNAMT = 'SGEQRF' 275 CALL SGEQRF( NA, NA, A, LDA, TAU, 276 + S_WORK_SGEQRF, LDA, 277 + INFO ) 278 ELSE 279* 280* The case IUPLO.EQ.2 is when SIDE.EQ.'L' 281* -> QL factorization. 282* 283 SRNAMT = 'SGELQF' 284 CALL SGELQF( NA, NA, A, LDA, TAU, 285 + S_WORK_SGEQRF, LDA, 286 + INFO ) 287 END IF 288* 289* Store a copy of A in RFP format (in ARF). 290* 291 SRNAMT = 'STRTTF' 292 CALL STRTTF( CFORM, UPLO, NA, A, LDA, ARF, 293 + INFO ) 294* 295* Generate B1 our M--by--N right-hand side 296* and store a copy in B2. 297* 298 DO J = 1, N 299 DO I = 1, M 300 B1( I, J) = SLARND( 2, ISEED ) 301 B2( I, J) = B1( I, J) 302 END DO 303 END DO 304* 305* Solve op( A ) X = B or X op( A ) = B 306* with STRSM 307* 308 SRNAMT = 'STRSM' 309 CALL STRSM( SIDE, UPLO, TRANS, DIAG, M, N, 310 + ALPHA, A, LDA, B1, LDA ) 311* 312* Solve op( A ) X = B or X op( A ) = B 313* with STFSM 314* 315 SRNAMT = 'STFSM' 316 CALL STFSM( CFORM, SIDE, UPLO, TRANS, 317 + DIAG, M, N, ALPHA, ARF, B2, 318 + LDA ) 319* 320* Check that the result agrees. 321* 322 DO J = 1, N 323 DO I = 1, M 324 B1( I, J) = B2( I, J ) - B1( I, J ) 325 END DO 326 END DO 327* 328 RESULT(1) = SLANGE( 'I', M, N, B1, LDA, 329 + S_WORK_SLANGE ) 330* 331 RESULT(1) = RESULT(1) / SQRT( EPS ) 332 + / MAX ( MAX( M, N), 1 ) 333* 334 IF( RESULT(1).GE.THRESH ) THEN 335 IF( NFAIL.EQ.0 ) THEN 336 WRITE( NOUT, * ) 337 WRITE( NOUT, FMT = 9999 ) 338 END IF 339 WRITE( NOUT, FMT = 9997 ) 'STFSM', 340 + CFORM, SIDE, UPLO, TRANS, DIAG, M, 341 + N, RESULT(1) 342 NFAIL = NFAIL + 1 343 END IF 344* 345 100 CONTINUE 346 110 CONTINUE 347 120 CONTINUE 348 130 CONTINUE 349 140 CONTINUE 350 150 CONTINUE 351 160 CONTINUE 352 170 CONTINUE 353* 354* Print a summary of the results. 355* 356 IF ( NFAIL.EQ.0 ) THEN 357 WRITE( NOUT, FMT = 9996 ) 'STFSM', NRUN 358 ELSE 359 WRITE( NOUT, FMT = 9995 ) 'STFSM', NFAIL, NRUN 360 END IF 361* 362 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing STFSM 363 + ***') 364 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', 365 + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',', 366 + ' DIAG=''',A1,''',',' M=',I3,', N =', I3,', test=',G12.5) 367 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ', 368 + 'threshold ( ',I5,' tests run)') 369 9995 FORMAT( 1X, A6, ' auxiliary routine: ',I5,' out of ',I5, 370 + ' tests failed to pass the threshold') 371* 372 RETURN 373* 374* End of SDRVRF3 375* 376 END 377