LAPACK: TESTING/LIN/schklq.f Source File

Go to the documentation of this file.
00001       SUBROUTINE SCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
00002      $                   NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC,
00003      $                   B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
00004 *
00005 *  -- LAPACK test routine (version 3.1) --
00006 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00007 *     June 2010
00008 *
00009 *     .. Scalar Arguments ..
00010       LOGICAL            TSTERR
00011       INTEGER            NM, NMAX, NN, NNB, NOUT, NRHS
00012       REAL               THRESH
00013 *     ..
00014 *     .. Array Arguments ..
00015       LOGICAL            DOTYPE( * )
00016       INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
00017      $                   NXVAL( * )
00018       REAL               A( * ), AC( * ), AF( * ), AL( * ), AQ( * ),
00019      $                   B( * ), RWORK( * ), TAU( * ), WORK( * ),
00020      $                   X( * ), XACT( * )
00021 *     ..
00022 *
00023 *  Purpose
00024 *  =======
00025 *
00026 *  SCHKLQ tests SGELQF, SORGLQ and SORMLQ.
00027 *
00028 *  Arguments
00029 *  =========
00030 *
00031 *  DOTYPE  (input) LOGICAL array, dimension (NTYPES)
00032 *          The matrix types to be used for testing.  Matrices of type j
00033 *          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
00034 *          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
00035 *
00036 *  NM      (input) INTEGER
00037 *          The number of values of M contained in the vector MVAL.
00038 *
00039 *  MVAL    (input) INTEGER array, dimension (NM)
00040 *          The values of the matrix row dimension M.
00041 *
00042 *  NN      (input) INTEGER
00043 *          The number of values of N contained in the vector NVAL.
00044 *
00045 *  NVAL    (input) INTEGER array, dimension (NN)
00046 *          The values of the matrix column dimension N.
00047 *
00048 *  NNB     (input) INTEGER
00049 *          The number of values of NB and NX contained in the
00050 *          vectors NBVAL and NXVAL.  The blocking parameters are used
00051 *          in pairs (NB,NX).
00052 *
00053 *  NBVAL   (input) INTEGER array, dimension (NNB)
00054 *          The values of the blocksize NB.
00055 *
00056 *  NXVAL   (input) INTEGER array, dimension (NNB)
00057 *          The values of the crossover point NX.
00058 *
00059 *  NRHS    (input) INTEGER
00060 *          The number of right hand side vectors to be generated for
00061 *          each linear system.
00062 *
00063 *  THRESH  (input) REAL
00064 *          The threshold value for the test ratios.  A result is
00065 *          included in the output file if RESULT >= THRESH.  To have
00066 *          every test ratio printed, use THRESH = 0.
00067 *
00068 *  TSTERR  (input) LOGICAL
00069 *          Flag that indicates whether error exits are to be tested.
00070 *
00071 *  NMAX    (input) INTEGER
00072 *          The maximum value permitted for M or N, used in dimensioning
00073 *          the work arrays.
00074 *
00075 *  A       (workspace) REAL array, dimension (NMAX*NMAX)
00076 *
00077 *  AF      (workspace) REAL array, dimension (NMAX*NMAX)
00078 *
00079 *  AQ      (workspace) REAL array, dimension (NMAX*NMAX)
00080 *
00081 *  AL      (workspace) REAL array, dimension (NMAX*NMAX)
00082 *
00083 *  AC      (workspace) REAL array, dimension (NMAX*NMAX)
00084 *
00085 *  B       (workspace) REAL array, dimension (NMAX*NRHS)
00086 *
00087 *  X       (workspace) REAL array, dimension (NMAX*NRHS)
00088 *
00089 *  XACT    (workspace) REAL array, dimension (NMAX*NRHS)
00090 *
00091 *  TAU     (workspace) REAL array, dimension (NMAX)
00092 *
00093 *  WORK    (workspace) REAL array, dimension (NMAX*NMAX)
00094 *
00095 *  RWORK   (workspace) REAL array, dimension (NMAX)
00096 *
00097 *  IWORK   (workspace) INTEGER array, dimension (NMAX)
00098 *
00099 *  NOUT    (input) INTEGER
00100 *          The unit number for output.
00101 *
00102 *  =====================================================================
00103 *
00104 *     .. Parameters ..
00105       INTEGER            NTESTS
00106       PARAMETER          ( NTESTS = 7 )
00107       INTEGER            NTYPES
00108       PARAMETER          ( NTYPES = 8 )
00109       REAL               ZERO
00110       PARAMETER          ( ZERO = 0.0E0 )
00111 *     ..
00112 *     .. Local Scalars ..
00113       CHARACTER          DIST, TYPE
00114       CHARACTER*3        PATH
00115       INTEGER            I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
00116      $                   LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
00117      $                   NRUN, NT, NX
00118       REAL               ANORM, CNDNUM
00119 *     ..
00120 *     .. Local Arrays ..
00121       INTEGER            ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
00122       REAL               RESULT( NTESTS )
00123 *     ..
00124 *     .. External Subroutines ..
00125       EXTERNAL           ALAERH, ALAHD, ALASUM, SERRLQ, SGELQS, SGET02,
00126      $                   SLACPY, SLARHS, SLATB4, SLATMS, SLQT01, SLQT02,
00127      $                   SLQT03, XLAENV
00128 *     ..
00129 *     .. Intrinsic Functions ..
00130       INTRINSIC          MAX, MIN
00131 *     ..
00132 *     .. Scalars in Common ..
00133       LOGICAL            LERR, OK
00134       CHARACTER*32       SRNAMT
00135       INTEGER            INFOT, NUNIT
00136 *     ..
00137 *     .. Common blocks ..
00138       COMMON             / INFOC / INFOT, NUNIT, OK, LERR
00139       COMMON             / SRNAMC / SRNAMT
00140 *     ..
00141 *     .. Data statements ..
00142       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
00143 *     ..
00144 *     .. Executable Statements ..
00145 *
00146 *     Initialize constants and the random number seed.
00147 *
00148       PATH( 1: 1 ) = 'Single precision'
00149       PATH( 2: 3 ) = 'LQ'
00150       NRUN = 0
00151       NFAIL = 0
00152       NERRS = 0
00153       DO 10 I = 1, 4
00154          ISEED( I ) = ISEEDY( I )
00155    10 CONTINUE
00156 *
00157 *     Test the error exits
00158 *
00159       IF( TSTERR )
00160      $   CALL SERRLQ( PATH, NOUT )
00161       INFOT = 0
00162       CALL XLAENV( 2, 2 )
00163 *
00164       LDA = NMAX
00165       LWORK = NMAX*MAX( NMAX, NRHS )
00166 *
00167 *     Do for each value of M in MVAL.
00168 *
00169       DO 70 IM = 1, NM
00170          M = MVAL( IM )
00171 *
00172 *        Do for each value of N in NVAL.
00173 *
00174          DO 60 IN = 1, NN
00175             N = NVAL( IN )
00176             MINMN = MIN( M, N )
00177             DO 50 IMAT = 1, NTYPES
00178 *
00179 *              Do the tests only if DOTYPE( IMAT ) is true.
00180 *
00181                IF( .NOT.DOTYPE( IMAT ) )
00182      $            GO TO 50
00183 *
00184 *              Set up parameters with SLATB4 and generate a test matrix
00185 *              with SLATMS.
00186 *
00187                CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
00188      $                      CNDNUM, DIST )
00189 *
00190                SRNAMT = 'SLATMS'
00191                CALL SLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
00192      $                      CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
00193      $                      WORK, INFO )
00194 *
00195 *              Check error code from SLATMS.
00196 *
00197                IF( INFO.NE.0 ) THEN
00198                   CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N, -1,
00199      $                         -1, -1, IMAT, NFAIL, NERRS, NOUT )
00200                   GO TO 50
00201                END IF
00202 *
00203 *              Set some values for K: the first value must be MINMN,
00204 *              corresponding to the call of SLQT01; other values are
00205 *              used in the calls of SLQT02, and must not exceed MINMN.
00206 *
00207                KVAL( 1 ) = MINMN
00208                KVAL( 2 ) = 0
00209                KVAL( 3 ) = 1
00210                KVAL( 4 ) = MINMN / 2
00211                IF( MINMN.EQ.0 ) THEN
00212                   NK = 1
00213                ELSE IF( MINMN.EQ.1 ) THEN
00214                   NK = 2
00215                ELSE IF( MINMN.LE.3 ) THEN
00216                   NK = 3
00217                ELSE
00218                   NK = 4
00219                END IF
00220 *
00221 *              Do for each value of K in KVAL
00222 *
00223                DO 40 IK = 1, NK
00224                   K = KVAL( IK )
00225 *
00226 *                 Do for each pair of values (NB,NX) in NBVAL and NXVAL.
00227 *
00228                   DO 30 INB = 1, NNB
00229                      NB = NBVAL( INB )
00230                      CALL XLAENV( 1, NB )
00231                      NX = NXVAL( INB )
00232                      CALL XLAENV( 3, NX )
00233                      DO I = 1, NTESTS
00234                         RESULT( I ) = ZERO
00235                      END DO
00236                      NT = 2
00237                      IF( IK.EQ.1 ) THEN
00238 *
00239 *                       Test SGELQF
00240 *
00241                         CALL SLQT01( M, N, A, AF, AQ, AL, LDA, TAU,
00242      $                               WORK, LWORK, RWORK, RESULT( 1 ) )
00243                      ELSE IF( M.LE.N ) THEN
00244 *
00245 *                       Test SORGLQ, using factorization
00246 *                       returned by SLQT01
00247 *
00248                         CALL SLQT02( M, N, K, A, AF, AQ, AL, LDA, TAU,
00249      $                               WORK, LWORK, RWORK, RESULT( 1 ) )
00250                      END IF
00251                      IF( M.GE.K ) THEN
00252 *
00253 *                       Test SORMLQ, using factorization returned
00254 *                       by SLQT01
00255 *
00256                         CALL SLQT03( M, N, K, AF, AC, AL, AQ, LDA, TAU,
00257      $                               WORK, LWORK, RWORK, RESULT( 3 ) )
00258                         NT = NT + 4
00259 *
00260 *                       If M>=N and K=N, call SGELQS to solve a system
00261 *                       with NRHS right hand sides and compute the
00262 *                       residual.
00263 *
00264                         IF( K.EQ.M .AND. INB.EQ.1 ) THEN
00265 *
00266 *                          Generate a solution and set the right
00267 *                          hand side.
00268 *
00269                            SRNAMT = 'SLARHS'
00270                            CALL SLARHS( PATH, 'New', 'Full',
00271      $                                  'No transpose', M, N, 0, 0,
00272      $                                  NRHS, A, LDA, XACT, LDA, B, LDA,
00273      $                                  ISEED, INFO )
00274 *
00275                            CALL SLACPY( 'Full', M, NRHS, B, LDA, X,
00276      $                                  LDA )
00277                            SRNAMT = 'SGELQS'
00278                            CALL SGELQS( M, N, NRHS, AF, LDA, TAU, X,
00279      $                                  LDA, WORK, LWORK, INFO )
00280 *
00281 *                          Check error code from SGELQS.
00282 *
00283                            IF( INFO.NE.0 )
00284      $                        CALL ALAERH( PATH, 'SGELQS', INFO, 0, ' ',
00285      $                                     M, N, NRHS, -1, NB, IMAT,
00286      $                                     NFAIL, NERRS, NOUT )
00287 *
00288                            CALL SGET02( 'No transpose', M, N, NRHS, A,
00289      $                                  LDA, X, LDA, B, LDA, RWORK,
00290      $                                  RESULT( 7 ) )
00291                            NT = NT + 1
00292                         END IF
00293                      END IF
00294 *
00295 *                    Print information about the tests that did not
00296 *                    pass the threshold.
00297 *
00298                      DO 20 I = 1, NTESTS
00299                         IF( RESULT( I ).GE.THRESH ) THEN
00300                            IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00301      $                        CALL ALAHD( NOUT, PATH )
00302                            WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX,
00303      $                        IMAT, I, RESULT( I )
00304                            NFAIL = NFAIL + 1
00305                         END IF
00306    20                CONTINUE
00307                      NRUN = NRUN + NT
00308    30             CONTINUE
00309    40          CONTINUE
00310    50       CONTINUE
00311    60    CONTINUE
00312    70 CONTINUE
00313 *
00314 *     Print a summary of the results.
00315 *
00316       CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
00317 *
00318  9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=',
00319      $      I5, ', type ', I2, ', test(', I2, ')=', G12.5 )
00320       RETURN
00321 *
00322 *     End of SCHKLQ
00323 *
00324       END