LAPACK 3.3.1
Linear Algebra PACKage

dchkrq.f

Go to the documentation of this file.
00001       SUBROUTINE DCHKRQ( 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.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       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 *  DCHKRQ tests DGERQF, DORGRQ and DORMRQ.
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 = 7 )
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 Subroutines ..
00125       EXTERNAL           ALAERH, ALAHD, ALASUM, DERRRQ, DGERQS, DGET02,
00126      $                   DLACPY, DLARHS, DLATB4, DLATMS, DRQT01, DRQT02,
00127      $                   DRQT03, 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 ) = 'Double precision'
00149       PATH( 2: 3 ) = 'RQ'
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 DERRRQ( 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 DLATB4 and generate a test matrix
00185 *              with DLATMS.
00186 *
00187                CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
00188      $                      CNDNUM, DIST )
00189 *
00190                SRNAMT = 'DLATMS'
00191                CALL DLATMS( 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 DLATMS.
00196 *
00197                IF( INFO.NE.0 ) THEN
00198                   CALL ALAERH( PATH, 'DLATMS', 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 DRQT01; other values are
00205 *              used in the calls of DRQT02, 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 DGERQF
00240 *
00241                         CALL DRQT01( M, N, A, AF, AQ, AR, LDA, TAU,
00242      $                               WORK, LWORK, RWORK, RESULT( 1 ) )
00243                      ELSE IF( M.LE.N ) THEN
00244 *
00245 *                       Test DORGRQ, using factorization
00246 *                       returned by DRQT01
00247 *
00248                         CALL DRQT02( M, N, K, A, AF, AQ, AR, LDA, TAU,
00249      $                               WORK, LWORK, RWORK, RESULT( 1 ) )
00250 
00251                      END IF
00252                      IF( M.GE.K ) THEN
00253 *
00254 *                       Test DORMRQ, using factorization returned
00255 *                       by DRQT01
00256 *
00257                         CALL DRQT03( M, N, K, AF, AC, AR, AQ, LDA, TAU,
00258      $                               WORK, LWORK, RWORK, RESULT( 3 ) )
00259                         NT = NT + 4
00260 *
00261 *                       If M>=N and K=N, call DGERQS to solve a system
00262 *                       with NRHS right hand sides and compute the
00263 *                       residual.
00264 *
00265                         IF( K.EQ.M .AND. INB.EQ.1 ) THEN
00266 *
00267 *                          Generate a solution and set the right
00268 *                          hand side.
00269 *
00270                            SRNAMT = 'DLARHS'
00271                            CALL DLARHS( PATH, 'New', 'Full',
00272      $                                  'No transpose', M, N, 0, 0,
00273      $                                  NRHS, A, LDA, XACT, LDA, B, LDA,
00274      $                                  ISEED, INFO )
00275 *
00276                            CALL DLACPY( 'Full', M, NRHS, B, LDA,
00277      $                                  X( N-M+1 ), LDA )
00278                            SRNAMT = 'DGERQS'
00279                            CALL DGERQS( M, N, NRHS, AF, LDA, TAU, X,
00280      $                                  LDA, WORK, LWORK, INFO )
00281 *
00282 *                          Check error code from DGERQS.
00283 *
00284                            IF( INFO.NE.0 )
00285      $                        CALL ALAERH( PATH, 'DGERQS', INFO, 0, ' ',
00286      $                                     M, N, NRHS, -1, NB, IMAT,
00287      $                                     NFAIL, NERRS, NOUT )
00288 *
00289                            CALL DGET02( 'No transpose', M, N, NRHS, A,
00290      $                                  LDA, X, LDA, B, LDA, RWORK,
00291      $                                  RESULT( 7 ) )
00292                            NT = NT + 1
00293                         END IF
00294                      END IF
00295 *
00296 *                    Print information about the tests that did not
00297 *                    pass the threshold.
00298 *
00299                      DO 20 I = 1, NT
00300                         IF( RESULT( I ).GE.THRESH ) THEN
00301                            IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00302      $                        CALL ALAHD( NOUT, PATH )
00303                            WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX,
00304      $                        IMAT, I, RESULT( I )
00305                            NFAIL = NFAIL + 1
00306                         END IF
00307    20                CONTINUE
00308                      NRUN = NRUN + NT
00309    30             CONTINUE
00310    40          CONTINUE
00311    50       CONTINUE
00312    60    CONTINUE
00313    70 CONTINUE
00314 *
00315 *     Print a summary of the results.
00316 *
00317       CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
00318 *
00319  9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=',
00320      $      I5, ', type ', I2, ', test(', I2, ')=', G12.5 )
00321       RETURN
00322 *
00323 *     End of DCHKRQ
00324 *
00325       END
 All Files Functions