LAPACK: TESTING/LIN/dchkqr.f Source File

Go to the documentation of this file.
00001       SUBROUTINE DCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
00002      $                   NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC,
00003      $                   B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
00004 *
00005 *  -- LAPACK test routine (version 3.3.0) --
00006 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00007 *     November 2010
00008 *
00009 *     .. Scalar Arguments ..
00010       LOGICAL            TSTERR
00011       INTEGER            NM, NMAX, NN, NNB, NOUT, NRHS
00012       DOUBLE PRECISION   THRESH
00013 *     ..
00014 *     .. Array Arguments ..
00015       LOGICAL            DOTYPE( * )
00016       INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
00017      $                   NXVAL( * )
00018       DOUBLE PRECISION   A( * ), AC( * ), AF( * ), AQ( * ), AR( * ),
00019      $                   B( * ), RWORK( * ), TAU( * ), WORK( * ),
00020      $                   X( * ), XACT( * )
00021 *     ..
00022 *
00023 *  Purpose
00024 *  =======
00025 *
00026 *  DCHKQR tests DGEQRF, DORGQR and DORMQR.
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) DOUBLE PRECISION
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) DOUBLE PRECISION array, dimension (NMAX*NMAX)
00076 *
00077 *  AF      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
00078 *
00079 *  AQ      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
00080 *
00081 *  AR      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
00082 *
00083 *  AC      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
00084 *
00085 *  B       (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
00086 *
00087 *  X       (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
00088 *
00089 *  XACT    (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
00090 *
00091 *  TAU     (workspace) DOUBLE PRECISION array, dimension (NMAX)
00092 *
00093 *  WORK    (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
00094 *
00095 *  RWORK   (workspace) DOUBLE PRECISION 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 = 9 )
00107       INTEGER            NTYPES
00108       PARAMETER          ( NTYPES = 8 )
00109       DOUBLE PRECISION   ZERO
00110       PARAMETER          ( ZERO = 0.0D0 )
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       DOUBLE PRECISION   ANORM, CNDNUM
00119 *     ..
00120 *     .. Local Arrays ..
00121       INTEGER            ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
00122       DOUBLE PRECISION   RESULT( NTESTS )
00123 *     ..
00124 *     .. External Functions ..
00125       LOGICAL            DGENND
00126       EXTERNAL           DGENND
00127 *     ..
00128 *     .. External Subroutines ..
00129       EXTERNAL           ALAERH, ALAHD, ALASUM, DERRQR, DGEQRS, DGET02,
00130      $                   DLACPY, DLARHS, DLATB4, DLATMS, DQRT01, 
00131      $                   DQRT01P, DQRT02, DQRT03, XLAENV
00132 *     ..
00133 *     .. Intrinsic Functions ..
00134       INTRINSIC          MAX, MIN
00135 *     ..
00136 *     .. Scalars in Common ..
00137       LOGICAL            LERR, OK
00138       CHARACTER*32       SRNAMT
00139       INTEGER            INFOT, NUNIT
00140 *     ..
00141 *     .. Common blocks ..
00142       COMMON             / INFOC / INFOT, NUNIT, OK, LERR
00143       COMMON             / SRNAMC / SRNAMT
00144 *     ..
00145 *     .. Data statements ..
00146       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
00147 *     ..
00148 *     .. Executable Statements ..
00149 *
00150 *     Initialize constants and the random number seed.
00151 *
00152       PATH( 1: 1 ) = 'Double precision'
00153       PATH( 2: 3 ) = 'QR'
00154       NRUN = 0
00155       NFAIL = 0
00156       NERRS = 0
00157       DO 10 I = 1, 4
00158          ISEED( I ) = ISEEDY( I )
00159    10 CONTINUE
00160 *
00161 *     Test the error exits
00162 *
00163       IF( TSTERR )
00164      $   CALL DERRQR( PATH, NOUT )
00165       INFOT = 0
00166       CALL XLAENV( 2, 2 )
00167 *
00168       LDA = NMAX
00169       LWORK = NMAX*MAX( NMAX, NRHS )
00170 *
00171 *     Do for each value of M in MVAL.
00172 *
00173       DO 70 IM = 1, NM
00174          M = MVAL( IM )
00175 *
00176 *        Do for each value of N in NVAL.
00177 *
00178          DO 60 IN = 1, NN
00179             N = NVAL( IN )
00180             MINMN = MIN( M, N )
00181             DO 50 IMAT = 1, NTYPES
00182 *
00183 *              Do the tests only if DOTYPE( IMAT ) is true.
00184 *
00185                IF( .NOT.DOTYPE( IMAT ) )
00186      $            GO TO 50
00187 *
00188 *              Set up parameters with DLATB4 and generate a test matrix
00189 *              with DLATMS.
00190 *
00191                CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
00192      $                      CNDNUM, DIST )
00193 *
00194                SRNAMT = 'DLATMS'
00195                CALL DLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
00196      $                      CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
00197      $                      WORK, INFO )
00198 *
00199 *              Check error code from DLATMS.
00200 *
00201                IF( INFO.NE.0 ) THEN
00202                   CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, -1,
00203      $                         -1, -1, IMAT, NFAIL, NERRS, NOUT )
00204                   GO TO 50
00205                END IF
00206 *
00207 *              Set some values for K: the first value must be MINMN,
00208 *              corresponding to the call of DQRT01; other values are
00209 *              used in the calls of DQRT02, and must not exceed MINMN.
00210 *
00211                KVAL( 1 ) = MINMN
00212                KVAL( 2 ) = 0
00213                KVAL( 3 ) = 1
00214                KVAL( 4 ) = MINMN / 2
00215                IF( MINMN.EQ.0 ) THEN
00216                   NK = 1
00217                ELSE IF( MINMN.EQ.1 ) THEN
00218                   NK = 2
00219                ELSE IF( MINMN.LE.3 ) THEN
00220                   NK = 3
00221                ELSE
00222                   NK = 4
00223                END IF
00224 *
00225 *              Do for each value of K in KVAL
00226 *
00227                DO 40 IK = 1, NK
00228                   K = KVAL( IK )
00229 *
00230 *                 Do for each pair of values (NB,NX) in NBVAL and NXVAL.
00231 *
00232                   DO 30 INB = 1, NNB
00233                      NB = NBVAL( INB )
00234                      CALL XLAENV( 1, NB )
00235                      NX = NXVAL( INB )
00236                      CALL XLAENV( 3, NX )
00237                      DO I = 1, NTESTS
00238                         RESULT( I ) = ZERO
00239                      END DO
00240                      NT = 2
00241                      IF( IK.EQ.1 ) THEN
00242 *
00243 *                       Test DGEQRF
00244 *
00245                         CALL DQRT01( M, N, A, AF, AQ, AR, LDA, TAU,
00246      $                               WORK, LWORK, RWORK, RESULT( 1 ) )
00247 
00248 *
00249 *                       Test DGEQRFP
00250 *
00251                         CALL DQRT01P( M, N, A, AF, AQ, AR, LDA, TAU,
00252      $                               WORK, LWORK, RWORK, RESULT( 8 ) )
00253 
00254                          IF( .NOT. DGENND( M, N, AF, LDA ) )
00255      $                       RESULT( 9 ) = 2*THRESH
00256                         NT = NT + 1
00257                     ELSE IF( M.GE.N ) THEN
00258 *
00259 *                       Test DORGQR, using factorization
00260 *                       returned by DQRT01
00261 *
00262                         CALL DQRT02( M, N, K, A, AF, AQ, AR, LDA, TAU,
00263      $                               WORK, LWORK, RWORK, RESULT( 1 ) )
00264                      END IF
00265                      IF( M.GE.K ) THEN
00266 *
00267 *                       Test DORMQR, using factorization returned
00268 *                       by DQRT01
00269 *
00270                         CALL DQRT03( M, N, K, AF, AC, AR, AQ, LDA, TAU,
00271      $                               WORK, LWORK, RWORK, RESULT( 3 ) )
00272                         NT = NT + 4
00273 *
00274 *                       If M>=N and K=N, call DGEQRS to solve a system
00275 *                       with NRHS right hand sides and compute the
00276 *                       residual.
00277 *
00278                         IF( K.EQ.N .AND. INB.EQ.1 ) THEN
00279 *
00280 *                          Generate a solution and set the right
00281 *                          hand side.
00282 *
00283                            SRNAMT = 'DLARHS'
00284                            CALL DLARHS( PATH, 'New', 'Full',
00285      $                                  'No transpose', M, N, 0, 0,
00286      $                                  NRHS, A, LDA, XACT, LDA, B, LDA,
00287      $                                  ISEED, INFO )
00288 *
00289                            CALL DLACPY( 'Full', M, NRHS, B, LDA, X,
00290      $                                  LDA )
00291                            SRNAMT = 'DGEQRS'
00292                            CALL DGEQRS( M, N, NRHS, AF, LDA, TAU, X,
00293      $                                  LDA, WORK, LWORK, INFO )
00294 *
00295 *                          Check error code from DGEQRS.
00296 *
00297                            IF( INFO.NE.0 )
00298      $                        CALL ALAERH( PATH, 'DGEQRS', INFO, 0, ' ',
00299      $                                     M, N, NRHS, -1, NB, IMAT,
00300      $                                     NFAIL, NERRS, NOUT )
00301 *
00302                            CALL DGET02( 'No transpose', M, N, NRHS, A,
00303      $                                  LDA, X, LDA, B, LDA, RWORK,
00304      $                                  RESULT( 7 ) )
00305                            NT = NT + 1
00306                         END IF
00307                      END IF
00308 *
00309 *                    Print information about the tests that did not
00310 *                    pass the threshold.
00311 *
00312                      DO 20 I = 1, NTESTS
00313                         IF( RESULT( I ).GE.THRESH ) THEN
00314                            IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00315      $                        CALL ALAHD( NOUT, PATH )
00316                            WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX,
00317      $                        IMAT, I, RESULT( I )
00318                            NFAIL = NFAIL + 1
00319                         END IF
00320    20                CONTINUE
00321                      NRUN = NRUN + NT
00322    30             CONTINUE
00323    40          CONTINUE
00324    50       CONTINUE
00325    60    CONTINUE
00326    70 CONTINUE
00327 *
00328 *     Print a summary of the results.
00329 *
00330       CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
00331 *
00332  9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=',
00333      $      I5, ', type ', I2, ', test(', I2, ')=', G12.5 )
00334       RETURN
00335 *
00336 *     End of DCHKQR
00337 *
00338       END