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