TESTING/LIN/schklq.f

   1 *> \brief \b SCHKLQ
   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 SCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
  12 *                          NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC,
  13 *                          B, X, XACT, TAU, WORK, RWORK, 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            MVAL( * ), NBVAL( * ), NVAL( * ),
  23 *      $                   NXVAL( * )
  24 *       REAL               A( * ), AC( * ), AF( * ), AL( * ), AQ( * ),
  25 *      $                   B( * ), RWORK( * ), TAU( * ), WORK( * ),
  26 *      $                   X( * ), XACT( * )
  27 *       ..
  28 *
  29 *
  30 *> \par Purpose:
  31 *  =============
  32 *>
  33 *> \verbatim
  34 *>
  35 *> SCHKLQ tests SGELQF, SORGLQ and SORMLQ.
  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] AL
 137 *> \verbatim
 138 *>          AL 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[in] NOUT
 177 *> \verbatim
 178 *>          NOUT is INTEGER
 179 *>          The unit number for output.
 180 *> \endverbatim
 181 *
 182 *  Authors:
 183 *  ========
 184 *
 185 *> \author Univ. of Tennessee
 186 *> \author Univ. of California Berkeley
 187 *> \author Univ. of Colorado Denver
 188 *> \author NAG Ltd.
 189 *
 190 *> \date November 2015
 191 *
 192 *> \ingroup single_lin
 193 *
 194 *  =====================================================================
 195       SUBROUTINE SCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
 196      $                   NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC,
 197      $                   B, X, XACT, TAU, WORK, RWORK, NOUT )
 198 *
 199 *  -- LAPACK test routine (version 3.6.0) --
 200 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 201 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 202 *     November 2015
 203 *
 204 *     .. Scalar Arguments ..
 205       LOGICAL            TSTERR
 206       INTEGER            NM, NMAX, NN, NNB, NOUT, NRHS
 207       REAL               THRESH
 208 *     ..
 209 *     .. Array Arguments ..
 210       LOGICAL            DOTYPE( * )
 211       INTEGER            MVAL( * ), NBVAL( * ), NVAL( * ),
 212      $                   NXVAL( * )
 213       REAL               A( * ), AC( * ), AF( * ), AL( * ), AQ( * ),
 214      $                   B( * ), RWORK( * ), TAU( * ), WORK( * ),
 215      $                   X( * ), XACT( * )
 216 *     ..
 217 *
 218 *  =====================================================================
 219 *
 220 *     .. Parameters ..
 221       INTEGER            NTESTS
 222       PARAMETER          ( NTESTS = 7 )
 223       INTEGER            NTYPES
 224       PARAMETER          ( NTYPES = 8 )
 225       REAL               ZERO
 226       PARAMETER          ( ZERO = 0.0E0 )
 227 *     ..
 228 *     .. Local Scalars ..
 229       CHARACTER          DIST, TYPE
 230       CHARACTER*3        PATH
 231       INTEGER            I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
 232      $                   LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
 233      $                   NRUN, NT, NX
 234       REAL               ANORM, CNDNUM
 235 *     ..
 236 *     .. Local Arrays ..
 237       INTEGER            ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
 238       REAL               RESULT( NTESTS )
 239 *     ..
 240 *     .. External Subroutines ..
 241       EXTERNAL           ALAERH, ALAHD, ALASUM, SERRLQ, SGELQS, SGET02,
 242      $                   SLACPY, SLARHS, SLATB4, SLATMS, SLQT01, SLQT02,
 243      $                   SLQT03, XLAENV
 244 *     ..
 245 *     .. Intrinsic Functions ..
 246       INTRINSIC          MAX, MIN
 247 *     ..
 248 *     .. Scalars in Common ..
 249       LOGICAL            LERR, OK
 250       CHARACTER*32       SRNAMT
 251       INTEGER            INFOT, NUNIT
 252 *     ..
 253 *     .. Common blocks ..
 254       COMMON             / INFOC / INFOT, NUNIT, OK, LERR
 255       COMMON             / SRNAMC / SRNAMT
 256 *     ..
 257 *     .. Data statements ..
 258       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
 259 *     ..
 260 *     .. Executable Statements ..
 261 *
 262 *     Initialize constants and the random number seed.
 263 *
 264       PATH( 1: 1 ) = 'Single precision'
 265       PATH( 2: 3 ) = 'LQ'
 266       NRUN = 0
 267       NFAIL = 0
 268       NERRS = 0
 269       DO 10 I = 1, 4
 270          ISEED( I ) = ISEEDY( I )
 271    10 CONTINUE
 272 *
 273 *     Test the error exits
 274 *
 275       IF( TSTERR )
 276      $   CALL SERRLQ( PATH, NOUT )
 277       INFOT = 0
 278       CALL XLAENV( 2, 2 )
 279 *
 280       LDA = NMAX
 281       LWORK = NMAX*MAX( NMAX, NRHS )
 282 *
 283 *     Do for each value of M in MVAL.
 284 *
 285       DO 70 IM = 1, NM
 286          M = MVAL( IM )
 287 *
 288 *        Do for each value of N in NVAL.
 289 *
 290          DO 60 IN = 1, NN
 291             N = NVAL( IN )
 292             MINMN = MIN( M, N )
 293             DO 50 IMAT = 1, NTYPES
 294 *
 295 *              Do the tests only if DOTYPE( IMAT ) is true.
 296 *
 297                IF( .NOT.DOTYPE( IMAT ) )
 298      $            GO TO 50
 299 *
 300 *              Set up parameters with SLATB4 and generate a test matrix
 301 *              with SLATMS.
 302 *
 303                CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
 304      $                      CNDNUM, DIST )
 305 *
 306                SRNAMT = 'SLATMS'
 307                CALL SLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
 308      $                      CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
 309      $                      WORK, INFO )
 310 *
 311 *              Check error code from SLATMS.
 312 *
 313                IF( INFO.NE.0 ) THEN
 314                   CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N, -1,
 315      $                         -1, -1, IMAT, NFAIL, NERRS, NOUT )
 316                   GO TO 50
 317                END IF
 318 *
 319 *              Set some values for K: the first value must be MINMN,
 320 *              corresponding to the call of SLQT01; other values are
 321 *              used in the calls of SLQT02, and must not exceed MINMN.
 322 *
 323                KVAL( 1 ) = MINMN
 324                KVAL( 2 ) = 0
 325                KVAL( 3 ) = 1
 326                KVAL( 4 ) = MINMN / 2
 327                IF( MINMN.EQ.0 ) THEN
 328                   NK = 1
 329                ELSE IF( MINMN.EQ.1 ) THEN
 330                   NK = 2
 331                ELSE IF( MINMN.LE.3 ) THEN
 332                   NK = 3
 333                ELSE
 334                   NK = 4
 335                END IF
 336 *
 337 *              Do for each value of K in KVAL
 338 *
 339                DO 40 IK = 1, NK
 340                   K = KVAL( IK )
 341 *
 342 *                 Do for each pair of values (NB,NX) in NBVAL and NXVAL.
 343 *
 344                   DO 30 INB = 1, NNB
 345                      NB = NBVAL( INB )
 346                      CALL XLAENV( 1, NB )
 347                      NX = NXVAL( INB )
 348                      CALL XLAENV( 3, NX )
 349                      DO I = 1, NTESTS
 350                         RESULT( I ) = ZERO
 351                      END DO
 352                      NT = 2
 353                      IF( IK.EQ.1 ) THEN
 354 *
 355 *                       Test SGELQF
 356 *
 357                         CALL SLQT01( M, N, A, AF, AQ, AL, LDA, TAU,
 358      $                               WORK, LWORK, RWORK, RESULT( 1 ) )
 359                      ELSE IF( M.LE.N ) THEN
 360 *
 361 *                       Test SORGLQ, using factorization
 362 *                       returned by SLQT01
 363 *
 364                         CALL SLQT02( M, N, K, A, AF, AQ, AL, LDA, TAU,
 365      $                               WORK, LWORK, RWORK, RESULT( 1 ) )
 366                      END IF
 367                      IF( M.GE.K ) THEN
 368 *
 369 *                       Test SORMLQ, using factorization returned
 370 *                       by SLQT01
 371 *
 372                         CALL SLQT03( M, N, K, AF, AC, AL, AQ, LDA, TAU,
 373      $                               WORK, LWORK, RWORK, RESULT( 3 ) )
 374                         NT = NT + 4
 375 *
 376 *                       If M>=N and K=N, call SGELQS to solve a system
 377 *                       with NRHS right hand sides and compute the
 378 *                       residual.
 379 *
 380                         IF( K.EQ.M .AND. INB.EQ.1 ) THEN
 381 *
 382 *                          Generate a solution and set the right
 383 *                          hand side.
 384 *
 385                            SRNAMT = 'SLARHS'
 386                            CALL SLARHS( PATH, 'New', 'Full',
 387      $                                  'No transpose', M, N, 0, 0,
 388      $                                  NRHS, A, LDA, XACT, LDA, B, LDA,
 389      $                                  ISEED, INFO )
 390 *
 391                            CALL SLACPY( 'Full', M, NRHS, B, LDA, X,
 392      $                                  LDA )
 393                            SRNAMT = 'SGELQS'
 394                            CALL SGELQS( M, N, NRHS, AF, LDA, TAU, X,
 395      $                                  LDA, WORK, LWORK, INFO )
 396 *
 397 *                          Check error code from SGELQS.
 398 *
 399                            IF( INFO.NE.0 )
 400      $                        CALL ALAERH( PATH, 'SGELQS', INFO, 0, ' ',
 401      $                                     M, N, NRHS, -1, NB, IMAT,
 402      $                                     NFAIL, NERRS, NOUT )
 403 *
 404                            CALL SGET02( 'No transpose', M, N, NRHS, A,
 405      $                                  LDA, X, LDA, B, LDA, RWORK,
 406      $                                  RESULT( 7 ) )
 407                            NT = NT + 1
 408                         END IF
 409                      END IF
 410 *
 411 *                    Print information about the tests that did not
 412 *                    pass the threshold.
 413 *
 414                      DO 20 I = 1, NT
 415                         IF( RESULT( I ).GE.THRESH ) THEN
 416                            IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
 417      $                        CALL ALAHD( NOUT, PATH )
 418                            WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX,
 419      $                        IMAT, I, RESULT( I )
 420                            NFAIL = NFAIL + 1
 421                         END IF
 422    20                CONTINUE
 423                      NRUN = NRUN + NT
 424    30             CONTINUE
 425    40          CONTINUE
 426    50       CONTINUE
 427    60    CONTINUE
 428    70 CONTINUE
 429 *
 430 *     Print a summary of the results.
 431 *
 432       CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
 433 *
 434  9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=',
 435      $      I5, ', type ', I2, ', test(', I2, ')=', G12.5 )
 436       RETURN
 437 *
 438 *     End of SCHKLQ
 439 *
 440       END