1*> \brief \b SCHKQR 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 SCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, 12* NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, 13* B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) 14* 15* .. Scalar Arguments .. 16* LOGICAL TSTERR 17* INTEGER NM, NMAX, NN, NNB, NOUT, NRHS 18* REAL THRESH 19* .. 20* .. Array Arguments .. 21* LOGICAL DOTYPE( * ) 22* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), 23* $ NXVAL( * ) 24* REAL A( * ), AC( * ), AF( * ), AQ( * ), AR( * ), 25* $ B( * ), RWORK( * ), TAU( * ), WORK( * ), 26* $ X( * ), XACT( * ) 27* .. 28* 29* 30*> \par Purpose: 31* ============= 32*> 33*> \verbatim 34*> 35*> SCHKQR tests SGEQRF, SORGQR and SORMQR. 36*> \endverbatim 37* 38* Arguments: 39* ========== 40* 41*> \param[in] DOTYPE 42*> \verbatim 43*> DOTYPE is LOGICAL array, dimension (NTYPES) 44*> The matrix types to be used for testing. Matrices of type j 45*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 46*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 47*> \endverbatim 48*> 49*> \param[in] NM 50*> \verbatim 51*> NM is INTEGER 52*> The number of values of M contained in the vector MVAL. 53*> \endverbatim 54*> 55*> \param[in] MVAL 56*> \verbatim 57*> MVAL is INTEGER array, dimension (NM) 58*> The values of the matrix row dimension M. 59*> \endverbatim 60*> 61*> \param[in] NN 62*> \verbatim 63*> NN is INTEGER 64*> The number of values of N contained in the vector NVAL. 65*> \endverbatim 66*> 67*> \param[in] NVAL 68*> \verbatim 69*> NVAL is INTEGER array, dimension (NN) 70*> The values of the matrix column dimension N. 71*> \endverbatim 72*> 73*> \param[in] NNB 74*> \verbatim 75*> NNB is INTEGER 76*> The number of values of NB and NX contained in the 77*> vectors NBVAL and NXVAL. The blocking parameters are used 78*> in pairs (NB,NX). 79*> \endverbatim 80*> 81*> \param[in] NBVAL 82*> \verbatim 83*> NBVAL is INTEGER array, dimension (NNB) 84*> The values of the blocksize NB. 85*> \endverbatim 86*> 87*> \param[in] NXVAL 88*> \verbatim 89*> NXVAL is INTEGER array, dimension (NNB) 90*> The values of the crossover point NX. 91*> \endverbatim 92*> 93*> \param[in] NRHS 94*> \verbatim 95*> NRHS is INTEGER 96*> The number of right hand side vectors to be generated for 97*> each linear system. 98*> \endverbatim 99*> 100*> \param[in] THRESH 101*> \verbatim 102*> THRESH is REAL 103*> The threshold value for the test ratios. A result is 104*> included in the output file if RESULT >= THRESH. To have 105*> every test ratio printed, use THRESH = 0. 106*> \endverbatim 107*> 108*> \param[in] TSTERR 109*> \verbatim 110*> TSTERR is LOGICAL 111*> Flag that indicates whether error exits are to be tested. 112*> \endverbatim 113*> 114*> \param[in] NMAX 115*> \verbatim 116*> NMAX is INTEGER 117*> The maximum value permitted for M or N, used in dimensioning 118*> the work arrays. 119*> \endverbatim 120*> 121*> \param[out] A 122*> \verbatim 123*> A is REAL array, dimension (NMAX*NMAX) 124*> \endverbatim 125*> 126*> \param[out] AF 127*> \verbatim 128*> AF is REAL array, dimension (NMAX*NMAX) 129*> \endverbatim 130*> 131*> \param[out] AQ 132*> \verbatim 133*> AQ is REAL array, dimension (NMAX*NMAX) 134*> \endverbatim 135*> 136*> \param[out] AR 137*> \verbatim 138*> AR is REAL array, dimension (NMAX*NMAX) 139*> \endverbatim 140*> 141*> \param[out] AC 142*> \verbatim 143*> AC is REAL array, dimension (NMAX*NMAX) 144*> \endverbatim 145*> 146*> \param[out] B 147*> \verbatim 148*> B is REAL array, dimension (NMAX*NRHS) 149*> \endverbatim 150*> 151*> \param[out] X 152*> \verbatim 153*> X is REAL array, dimension (NMAX*NRHS) 154*> \endverbatim 155*> 156*> \param[out] XACT 157*> \verbatim 158*> XACT is REAL array, dimension (NMAX*NRHS) 159*> \endverbatim 160*> 161*> \param[out] TAU 162*> \verbatim 163*> TAU is REAL array, dimension (NMAX) 164*> \endverbatim 165*> 166*> \param[out] WORK 167*> \verbatim 168*> WORK is REAL array, dimension (NMAX*NMAX) 169*> \endverbatim 170*> 171*> \param[out] RWORK 172*> \verbatim 173*> RWORK is REAL array, dimension (NMAX) 174*> \endverbatim 175*> 176*> \param[out] IWORK 177*> \verbatim 178*> IWORK is INTEGER array, dimension (NMAX) 179*> \endverbatim 180*> 181*> \param[in] NOUT 182*> \verbatim 183*> NOUT is INTEGER 184*> The unit number for output. 185*> \endverbatim 186* 187* Authors: 188* ======== 189* 190*> \author Univ. of Tennessee 191*> \author Univ. of California Berkeley 192*> \author Univ. of Colorado Denver 193*> \author NAG Ltd. 194* 195*> \date November 2011 196* 197*> \ingroup single_lin 198* 199* ===================================================================== 200 SUBROUTINE SCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, 201 $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, 202 $ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) 203* 204* -- LAPACK test routine (version 3.4.0) -- 205* -- LAPACK is a software package provided by Univ. of Tennessee, -- 206* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 207* November 2011 208* 209* .. Scalar Arguments .. 210 LOGICAL TSTERR 211 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS 212 REAL THRESH 213* .. 214* .. Array Arguments .. 215 LOGICAL DOTYPE( * ) 216 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), 217 $ NXVAL( * ) 218 REAL A( * ), AC( * ), AF( * ), AQ( * ), AR( * ), 219 $ B( * ), RWORK( * ), TAU( * ), WORK( * ), 220 $ X( * ), XACT( * ) 221* .. 222* 223* ===================================================================== 224* 225* .. Parameters .. 226 INTEGER NTESTS 227 PARAMETER ( NTESTS = 9 ) 228 INTEGER NTYPES 229 PARAMETER ( NTYPES = 8 ) 230 REAL ZERO 231 PARAMETER ( ZERO = 0.0E0 ) 232* .. 233* .. Local Scalars .. 234 CHARACTER DIST, TYPE 235 CHARACTER*3 PATH 236 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA, 237 $ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK, 238 $ NRUN, NT, NX 239 REAL ANORM, CNDNUM 240* .. 241* .. Local Arrays .. 242 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 ) 243 REAL RESULT( NTESTS ) 244* .. 245* .. External Functions .. 246 LOGICAL SGENND 247 EXTERNAL SGENND 248* .. 249* .. External Subroutines .. 250 EXTERNAL ALAERH, ALAHD, ALASUM, SERRQR, SGEQRS, SGET02, 251 $ SLACPY, SLARHS, SLATB4, SLATMS, SQRT01, 252 $ SQRT01P, SQRT02, SQRT03, XLAENV 253* .. 254* .. Intrinsic Functions .. 255 INTRINSIC MAX, MIN 256* .. 257* .. Scalars in Common .. 258 LOGICAL LERR, OK 259 CHARACTER*32 SRNAMT 260 INTEGER INFOT, NUNIT 261* .. 262* .. Common blocks .. 263 COMMON / INFOC / INFOT, NUNIT, OK, LERR 264 COMMON / SRNAMC / SRNAMT 265* .. 266* .. Data statements .. 267 DATA ISEEDY / 1988, 1989, 1990, 1991 / 268* .. 269* .. Executable Statements .. 270* 271* Initialize constants and the random number seed. 272* 273 PATH( 1: 1 ) = 'Single precision' 274 PATH( 2: 3 ) = 'QR' 275 NRUN = 0 276 NFAIL = 0 277 NERRS = 0 278 DO 10 I = 1, 4 279 ISEED( I ) = ISEEDY( I ) 280 10 CONTINUE 281* 282* Test the error exits 283* 284 IF( TSTERR ) 285 $ CALL SERRQR( PATH, NOUT ) 286 INFOT = 0 287 CALL XLAENV( 2, 2 ) 288* 289 LDA = NMAX 290 LWORK = NMAX*MAX( NMAX, NRHS ) 291* 292* Do for each value of M in MVAL. 293* 294 DO 70 IM = 1, NM 295 M = MVAL( IM ) 296* 297* Do for each value of N in NVAL. 298* 299 DO 60 IN = 1, NN 300 N = NVAL( IN ) 301 MINMN = MIN( M, N ) 302 DO 50 IMAT = 1, NTYPES 303* 304* Do the tests only if DOTYPE( IMAT ) is true. 305* 306 IF( .NOT.DOTYPE( IMAT ) ) 307 $ GO TO 50 308* 309* Set up parameters with SLATB4 and generate a test matrix 310* with SLATMS. 311* 312 CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, 313 $ CNDNUM, DIST ) 314* 315 SRNAMT = 'SLATMS' 316 CALL SLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE, 317 $ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA, 318 $ WORK, INFO ) 319* 320* Check error code from SLATMS. 321* 322 IF( INFO.NE.0 ) THEN 323 CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N, -1, 324 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 325 GO TO 50 326 END IF 327* 328* Set some values for K: the first value must be MINMN, 329* corresponding to the call of SQRT01; other values are 330* used in the calls of SQRT02, and must not exceed MINMN. 331* 332 KVAL( 1 ) = MINMN 333 KVAL( 2 ) = 0 334 KVAL( 3 ) = 1 335 KVAL( 4 ) = MINMN / 2 336 IF( MINMN.EQ.0 ) THEN 337 NK = 1 338 ELSE IF( MINMN.EQ.1 ) THEN 339 NK = 2 340 ELSE IF( MINMN.LE.3 ) THEN 341 NK = 3 342 ELSE 343 NK = 4 344 END IF 345* 346* Do for each value of K in KVAL 347* 348 DO 40 IK = 1, NK 349 K = KVAL( IK ) 350* 351* Do for each pair of values (NB,NX) in NBVAL and NXVAL. 352* 353 DO 30 INB = 1, NNB 354 NB = NBVAL( INB ) 355 CALL XLAENV( 1, NB ) 356 NX = NXVAL( INB ) 357 CALL XLAENV( 3, NX ) 358 DO I = 1, NTESTS 359 RESULT( I ) = ZERO 360 END DO 361 NT = 2 362 IF( IK.EQ.1 ) THEN 363* 364* Test SGEQRF 365* 366 CALL SQRT01( M, N, A, AF, AQ, AR, LDA, TAU, 367 $ WORK, LWORK, RWORK, RESULT( 1 ) ) 368* 369* Test SGEQRFP 370* 371 CALL SQRT01P( M, N, A, AF, AQ, AR, LDA, TAU, 372 $ WORK, LWORK, RWORK, RESULT( 8 ) ) 373 374 IF( .NOT. SGENND( M, N, AF, LDA ) ) 375 $ RESULT( 9 ) = 2*THRESH 376 NT = NT + 1 377 ELSE IF( M.GE.N ) THEN 378* 379* Test SORGQR, using factorization 380* returned by SQRT01 381* 382 CALL SQRT02( M, N, K, A, AF, AQ, AR, LDA, TAU, 383 $ WORK, LWORK, RWORK, RESULT( 1 ) ) 384 END IF 385 IF( M.GE.K ) THEN 386* 387* Test SORMQR, using factorization returned 388* by SQRT01 389* 390 CALL SQRT03( M, N, K, AF, AC, AR, AQ, LDA, TAU, 391 $ WORK, LWORK, RWORK, RESULT( 3 ) ) 392 NT = NT + 4 393* 394* If M>=N and K=N, call SGEQRS to solve a system 395* with NRHS right hand sides and compute the 396* residual. 397* 398 IF( K.EQ.N .AND. INB.EQ.1 ) THEN 399* 400* Generate a solution and set the right 401* hand side. 402* 403 SRNAMT = 'SLARHS' 404 CALL SLARHS( PATH, 'New', 'Full', 405 $ 'No transpose', M, N, 0, 0, 406 $ NRHS, A, LDA, XACT, LDA, B, LDA, 407 $ ISEED, INFO ) 408* 409 CALL SLACPY( 'Full', M, NRHS, B, LDA, X, 410 $ LDA ) 411 SRNAMT = 'SGEQRS' 412 CALL SGEQRS( M, N, NRHS, AF, LDA, TAU, X, 413 $ LDA, WORK, LWORK, INFO ) 414* 415* Check error code from SGEQRS. 416* 417 IF( INFO.NE.0 ) 418 $ CALL ALAERH( PATH, 'SGEQRS', INFO, 0, ' ', 419 $ M, N, NRHS, -1, NB, IMAT, 420 $ NFAIL, NERRS, NOUT ) 421* 422 CALL SGET02( 'No transpose', M, N, NRHS, A, 423 $ LDA, X, LDA, B, LDA, RWORK, 424 $ RESULT( 7 ) ) 425 NT = NT + 1 426 END IF 427 END IF 428* 429* Print information about the tests that did not 430* pass the threshold. 431* 432 DO 20 I = 1, NTESTS 433 IF( RESULT( I ).GE.THRESH ) THEN 434 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 435 $ CALL ALAHD( NOUT, PATH ) 436 WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX, 437 $ IMAT, I, RESULT( I ) 438 NFAIL = NFAIL + 1 439 END IF 440 20 CONTINUE 441 NRUN = NRUN + NT 442 30 CONTINUE 443 40 CONTINUE 444 50 CONTINUE 445 60 CONTINUE 446 70 CONTINUE 447* 448* Print a summary of the results. 449* 450 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 451* 452 9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=', 453 $ I5, ', type ', I2, ', test(', I2, ')=', G12.5 ) 454 RETURN 455* 456* End of SCHKQR 457* 458 END 459