LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
dchkq3.f
Go to the documentation of this file.
00001 *> \brief \b DCHKQ3
00002 *
00003 *  =========== DOCUMENTATION ===========
00004 *
00005 * Online html documentation available at 
00006 *            http://www.netlib.org/lapack/explore-html/ 
00007 *
00008 *  Definition:
00009 *  ===========
00010 *
00011 *       SUBROUTINE DCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
00012 *                          THRESH, A, COPYA, S, TAU, WORK, IWORK,
00013 *                          NOUT )
00014 * 
00015 *       .. Scalar Arguments ..
00016 *       INTEGER            NM, NN, NNB, NOUT
00017 *       DOUBLE PRECISION   THRESH
00018 *       ..
00019 *       .. Array Arguments ..
00020 *       LOGICAL            DOTYPE( * )
00021 *       INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
00022 *      $                   NXVAL( * )
00023 *       DOUBLE PRECISION   A( * ), COPYA( * ), S( * ),
00024 *      $                   TAU( * ), WORK( * )
00025 *       ..
00026 *  
00027 *
00028 *> \par Purpose:
00029 *  =============
00030 *>
00031 *> \verbatim
00032 *>
00033 *> DCHKQ3 tests DGEQP3.
00034 *> \endverbatim
00035 *
00036 *  Arguments:
00037 *  ==========
00038 *
00039 *> \param[in] DOTYPE
00040 *> \verbatim
00041 *>          DOTYPE is LOGICAL array, dimension (NTYPES)
00042 *>          The matrix types to be used for testing.  Matrices of type j
00043 *>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
00044 *>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
00045 *> \endverbatim
00046 *>
00047 *> \param[in] NM
00048 *> \verbatim
00049 *>          NM is INTEGER
00050 *>          The number of values of M contained in the vector MVAL.
00051 *> \endverbatim
00052 *>
00053 *> \param[in] MVAL
00054 *> \verbatim
00055 *>          MVAL is INTEGER array, dimension (NM)
00056 *>          The values of the matrix row dimension M.
00057 *> \endverbatim
00058 *>
00059 *> \param[in] NN
00060 *> \verbatim
00061 *>          NN is INTEGER
00062 *>          The number of values of N contained in the vector NVAL.
00063 *> \endverbatim
00064 *>
00065 *> \param[in] NVAL
00066 *> \verbatim
00067 *>          NVAL is INTEGER array, dimension (NN)
00068 *>          The values of the matrix column dimension N.
00069 *> \endverbatim
00070 *>
00071 *> \param[in] NNB
00072 *> \verbatim
00073 *>          NNB is INTEGER
00074 *>          The number of values of NB and NX contained in the
00075 *>          vectors NBVAL and NXVAL.  The blocking parameters are used
00076 *>          in pairs (NB,NX).
00077 *> \endverbatim
00078 *>
00079 *> \param[in] NBVAL
00080 *> \verbatim
00081 *>          NBVAL is INTEGER array, dimension (NNB)
00082 *>          The values of the blocksize NB.
00083 *> \endverbatim
00084 *>
00085 *> \param[in] NXVAL
00086 *> \verbatim
00087 *>          NXVAL is INTEGER array, dimension (NNB)
00088 *>          The values of the crossover point NX.
00089 *> \endverbatim
00090 *>
00091 *> \param[in] THRESH
00092 *> \verbatim
00093 *>          THRESH is DOUBLE PRECISION
00094 *>          The threshold value for the test ratios.  A result is
00095 *>          included in the output file if RESULT >= THRESH.  To have
00096 *>          every test ratio printed, use THRESH = 0.
00097 *> \endverbatim
00098 *>
00099 *> \param[out] A
00100 *> \verbatim
00101 *>          A is DOUBLE PRECISION array, dimension (MMAX*NMAX)
00102 *>          where MMAX is the maximum value of M in MVAL and NMAX is the
00103 *>          maximum value of N in NVAL.
00104 *> \endverbatim
00105 *>
00106 *> \param[out] COPYA
00107 *> \verbatim
00108 *>          COPYA is DOUBLE PRECISION array, dimension (MMAX*NMAX)
00109 *> \endverbatim
00110 *>
00111 *> \param[out] S
00112 *> \verbatim
00113 *>          S is DOUBLE PRECISION array, dimension
00114 *>                      (min(MMAX,NMAX))
00115 *> \endverbatim
00116 *>
00117 *> \param[out] TAU
00118 *> \verbatim
00119 *>          TAU is DOUBLE PRECISION array, dimension (MMAX)
00120 *> \endverbatim
00121 *>
00122 *> \param[out] WORK
00123 *> \verbatim
00124 *>          WORK is DOUBLE PRECISION array, dimension
00125 *>                      (MMAX*NMAX + 4*NMAX + MMAX)
00126 *> \endverbatim
00127 *>
00128 *> \param[out] IWORK
00129 *> \verbatim
00130 *>          IWORK is INTEGER array, dimension (2*NMAX)
00131 *> \endverbatim
00132 *>
00133 *> \param[in] NOUT
00134 *> \verbatim
00135 *>          NOUT is INTEGER
00136 *>          The unit number for output.
00137 *> \endverbatim
00138 *
00139 *  Authors:
00140 *  ========
00141 *
00142 *> \author Univ. of Tennessee 
00143 *> \author Univ. of California Berkeley 
00144 *> \author Univ. of Colorado Denver 
00145 *> \author NAG Ltd. 
00146 *
00147 *> \date November 2011
00148 *
00149 *> \ingroup double_lin
00150 *
00151 *  =====================================================================
00152       SUBROUTINE DCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
00153      $                   THRESH, A, COPYA, S, TAU, WORK, IWORK,
00154      $                   NOUT )
00155 *
00156 *  -- LAPACK test routine (version 3.4.0) --
00157 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00158 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00159 *     November 2011
00160 *
00161 *     .. Scalar Arguments ..
00162       INTEGER            NM, NN, NNB, NOUT
00163       DOUBLE PRECISION   THRESH
00164 *     ..
00165 *     .. Array Arguments ..
00166       LOGICAL            DOTYPE( * )
00167       INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
00168      $                   NXVAL( * )
00169       DOUBLE PRECISION   A( * ), COPYA( * ), S( * ),
00170      $                   TAU( * ), WORK( * )
00171 *     ..
00172 *
00173 *  =====================================================================
00174 *
00175 *     .. Parameters ..
00176       INTEGER            NTYPES
00177       PARAMETER          ( NTYPES = 6 )
00178       INTEGER            NTESTS
00179       PARAMETER          ( NTESTS = 3 )
00180       DOUBLE PRECISION   ONE, ZERO
00181       PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
00182 *     ..
00183 *     .. Local Scalars ..
00184       CHARACTER*3        PATH
00185       INTEGER            I, IHIGH, ILOW, IM, IMODE, IN, INB, INFO,
00186      $                   ISTEP, K, LDA, LW, LWORK, M, MNMIN, MODE, N,
00187      $                   NB, NERRS, NFAIL, NRUN, NX
00188       DOUBLE PRECISION   EPS
00189 *     ..
00190 *     .. Local Arrays ..
00191       INTEGER            ISEED( 4 ), ISEEDY( 4 )
00192       DOUBLE PRECISION   RESULT( NTESTS )
00193 *     ..
00194 *     .. External Functions ..
00195       DOUBLE PRECISION   DLAMCH, DQPT01, DQRT11, DQRT12
00196       EXTERNAL           DLAMCH, DQPT01, DQRT11, DQRT12
00197 *     ..
00198 *     .. External Subroutines ..
00199       EXTERNAL           ALAHD, ALASUM, DGEQP3, DLACPY, DLAORD, DLASET,
00200      $                   DLATMS, ICOPY, XLAENV
00201 *     ..
00202 *     .. Intrinsic Functions ..
00203       INTRINSIC          MAX, MIN
00204 *     ..
00205 *     .. Scalars in Common ..
00206       LOGICAL            LERR, OK
00207       CHARACTER*32       SRNAMT
00208       INTEGER            INFOT, IOUNIT
00209 *     ..
00210 *     .. Common blocks ..
00211       COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
00212       COMMON             / SRNAMC / SRNAMT
00213 *     ..
00214 *     .. Data statements ..
00215       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
00216 *     ..
00217 *     .. Executable Statements ..
00218 *
00219 *     Initialize constants and the random number seed.
00220 *
00221       PATH( 1: 1 ) = 'Double precision'
00222       PATH( 2: 3 ) = 'Q3'
00223       NRUN = 0
00224       NFAIL = 0
00225       NERRS = 0
00226       DO 10 I = 1, 4
00227          ISEED( I ) = ISEEDY( I )
00228    10 CONTINUE
00229       EPS = DLAMCH( 'Epsilon' )
00230       INFOT = 0
00231 *
00232       DO 90 IM = 1, NM
00233 *
00234 *        Do for each value of M in MVAL.
00235 *
00236          M = MVAL( IM )
00237          LDA = MAX( 1, M )
00238 *
00239          DO 80 IN = 1, NN
00240 *
00241 *           Do for each value of N in NVAL.
00242 *
00243             N = NVAL( IN )
00244             MNMIN = MIN( M, N )
00245             LWORK = MAX( 1, M*MAX( M, N )+4*MNMIN+MAX( M, N ),
00246      $                   M*N + 2*MNMIN + 4*N )
00247 *
00248             DO 70 IMODE = 1, NTYPES
00249                IF( .NOT.DOTYPE( IMODE ) )
00250      $            GO TO 70
00251 *
00252 *              Do for each type of matrix
00253 *                 1:  zero matrix
00254 *                 2:  one small singular value
00255 *                 3:  geometric distribution of singular values
00256 *                 4:  first n/2 columns fixed
00257 *                 5:  last n/2 columns fixed
00258 *                 6:  every second column fixed
00259 *
00260                MODE = IMODE
00261                IF( IMODE.GT.3 )
00262      $            MODE = 1
00263 *
00264 *              Generate test matrix of size m by n using
00265 *              singular value distribution indicated by `mode'.
00266 *
00267                DO 20 I = 1, N
00268                   IWORK( I ) = 0
00269    20          CONTINUE
00270                IF( IMODE.EQ.1 ) THEN
00271                   CALL DLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA )
00272                   DO 30 I = 1, MNMIN
00273                      S( I ) = ZERO
00274    30             CONTINUE
00275                ELSE
00276                   CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', S,
00277      $                         MODE, ONE / EPS, ONE, M, N, 'No packing',
00278      $                         COPYA, LDA, WORK, INFO )
00279                   IF( IMODE.GE.4 ) THEN
00280                      IF( IMODE.EQ.4 ) THEN
00281                         ILOW = 1
00282                         ISTEP = 1
00283                         IHIGH = MAX( 1, N / 2 )
00284                      ELSE IF( IMODE.EQ.5 ) THEN
00285                         ILOW = MAX( 1, N / 2 )
00286                         ISTEP = 1
00287                         IHIGH = N
00288                      ELSE IF( IMODE.EQ.6 ) THEN
00289                         ILOW = 1
00290                         ISTEP = 2
00291                         IHIGH = N
00292                      END IF
00293                      DO 40 I = ILOW, IHIGH, ISTEP
00294                         IWORK( I ) = 1
00295    40                CONTINUE
00296                   END IF
00297                   CALL DLAORD( 'Decreasing', MNMIN, S, 1 )
00298                END IF
00299 *
00300                DO 60 INB = 1, NNB
00301 *
00302 *                 Do for each pair of values (NB,NX) in NBVAL and NXVAL.
00303 *
00304                   NB = NBVAL( INB )
00305                   CALL XLAENV( 1, NB )
00306                   NX = NXVAL( INB )
00307                   CALL XLAENV( 3, NX )
00308 *
00309 *                 Get a working copy of COPYA into A and a copy of
00310 *                 vector IWORK.
00311 *
00312                   CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA )
00313                   CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 )
00314 *
00315 *                 Compute the QR factorization with pivoting of A
00316 *
00317                   LW = MAX( 1, 2*N+NB*( N+1 ) )
00318 *
00319 *                 Compute the QP3 factorization of A
00320 *
00321                   SRNAMT = 'DGEQP3'
00322                   CALL DGEQP3( M, N, A, LDA, IWORK( N+1 ), TAU, WORK,
00323      $                         LW, INFO )
00324 *
00325 *                 Compute norm(svd(a) - svd(r))
00326 *
00327                   RESULT( 1 ) = DQRT12( M, N, A, LDA, S, WORK,
00328      $                          LWORK )
00329 *
00330 *                 Compute norm( A*P - Q*R )
00331 *
00332                   RESULT( 2 ) = DQPT01( M, N, MNMIN, COPYA, A, LDA, TAU,
00333      $                          IWORK( N+1 ), WORK, LWORK )
00334 *
00335 *                 Compute Q'*Q
00336 *
00337                   RESULT( 3 ) = DQRT11( M, MNMIN, A, LDA, TAU, WORK,
00338      $                          LWORK )
00339 *
00340 *                 Print information about the tests that did not pass
00341 *                 the threshold.
00342 *
00343                   DO 50 K = 1, NTESTS
00344                      IF( RESULT( K ).GE.THRESH ) THEN
00345                         IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00346      $                     CALL ALAHD( NOUT, PATH )
00347                         WRITE( NOUT, FMT = 9999 )'DGEQP3', M, N, NB,
00348      $                     IMODE, K, RESULT( K )
00349                         NFAIL = NFAIL + 1
00350                      END IF
00351    50             CONTINUE
00352                   NRUN = NRUN + NTESTS
00353 *
00354    60          CONTINUE
00355    70       CONTINUE
00356    80    CONTINUE
00357    90 CONTINUE
00358 *
00359 *     Print a summary of the results.
00360 *
00361       CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
00362 *
00363  9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, ', NB =', I4, ', type ',
00364      $      I2, ', test ', I2, ', ratio =', G12.5 )
00365 *
00366 *     End of DCHKQ3
00367 *
00368       END
 All Files Functions