LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
zchktz.f
Go to the documentation of this file.
00001 *> \brief \b ZCHKTZ
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 ZCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
00012 *                          COPYA, S, TAU, WORK, RWORK, 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   S( * ), RWORK( * )
00023 *       COMPLEX*16         A( * ), COPYA( * ), TAU( * ), WORK( * )
00024 *       ..
00025 *  
00026 *
00027 *> \par Purpose:
00028 *  =============
00029 *>
00030 *> \verbatim
00031 *>
00032 *> ZCHKTZ tests ZTZRQF and ZTZRZF.
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 COMPLEX*16 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 COMPLEX*16 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 COMPLEX*16 array, dimension (MMAX)
00105 *> \endverbatim
00106 *>
00107 *> \param[out] WORK
00108 *> \verbatim
00109 *>          WORK is COMPLEX*16 array, dimension
00110 *>                      (MMAX*NMAX + 4*NMAX + MMAX)
00111 *> \endverbatim
00112 *>
00113 *> \param[out] RWORK
00114 *> \verbatim
00115 *>          RWORK is DOUBLE PRECISION array, dimension (2*NMAX)
00116 *> \endverbatim
00117 *>
00118 *> \param[in] NOUT
00119 *> \verbatim
00120 *>          NOUT is INTEGER
00121 *>          The unit number for output.
00122 *> \endverbatim
00123 *
00124 *  Authors:
00125 *  ========
00126 *
00127 *> \author Univ. of Tennessee 
00128 *> \author Univ. of California Berkeley 
00129 *> \author Univ. of Colorado Denver 
00130 *> \author NAG Ltd. 
00131 *
00132 *> \date November 2011
00133 *
00134 *> \ingroup complex16_lin
00135 *
00136 *  =====================================================================
00137       SUBROUTINE ZCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
00138      $                   COPYA, S, TAU, WORK, RWORK, NOUT )
00139 *
00140 *  -- LAPACK test routine (version 3.4.0) --
00141 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00142 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00143 *     November 2011
00144 *
00145 *     .. Scalar Arguments ..
00146       LOGICAL            TSTERR
00147       INTEGER            NM, NN, NOUT
00148       DOUBLE PRECISION   THRESH
00149 *     ..
00150 *     .. Array Arguments ..
00151       LOGICAL            DOTYPE( * )
00152       INTEGER            MVAL( * ), NVAL( * )
00153       DOUBLE PRECISION   S( * ), RWORK( * )
00154       COMPLEX*16         A( * ), COPYA( * ), TAU( * ), WORK( * )
00155 *     ..
00156 *
00157 *  =====================================================================
00158 *
00159 *     .. Parameters ..
00160       INTEGER            NTYPES
00161       PARAMETER          ( NTYPES = 3 )
00162       INTEGER            NTESTS
00163       PARAMETER          ( NTESTS = 6 )
00164       DOUBLE PRECISION   ONE, ZERO
00165       PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
00166 *     ..
00167 *     .. Local Scalars ..
00168       CHARACTER*3        PATH
00169       INTEGER            I, IM, IMODE, IN, INFO, K, LDA, LWORK, M,
00170      $                   MNMIN, MODE, N, NERRS, NFAIL, NRUN
00171       DOUBLE PRECISION   EPS
00172 *     ..
00173 *     .. Local Arrays ..
00174       INTEGER            ISEED( 4 ), ISEEDY( 4 )
00175       DOUBLE PRECISION   RESULT( NTESTS )
00176 *     ..
00177 *     .. External Functions ..
00178       DOUBLE PRECISION   DLAMCH, ZQRT12, ZRZT01, ZRZT02, ZTZT01, ZTZT02
00179       EXTERNAL           DLAMCH, ZQRT12, ZRZT01, ZRZT02, ZTZT01, ZTZT02
00180 *     ..
00181 *     .. External Subroutines ..
00182       EXTERNAL           ALAHD, ALASUM, DLAORD, ZERRTZ, ZGEQR2, ZLACPY,
00183      $                   ZLASET, ZLATMS, ZTZRQF, ZTZRZF
00184 *     ..
00185 *     .. Intrinsic Functions ..
00186       INTRINSIC          DCMPLX, MAX, MIN
00187 *     ..
00188 *     .. Scalars in Common ..
00189       LOGICAL            LERR, OK
00190       CHARACTER*32       SRNAMT
00191       INTEGER            INFOT, IOUNIT
00192 *     ..
00193 *     .. Common blocks ..
00194       COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
00195       COMMON             / SRNAMC / SRNAMT
00196 *     ..
00197 *     .. Data statements ..
00198       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
00199 *     ..
00200 *     .. Executable Statements ..
00201 *
00202 *     Initialize constants and the random number seed.
00203 *
00204       PATH( 1: 1 ) = 'Zomplex precision'
00205       PATH( 2: 3 ) = 'TZ'
00206       NRUN = 0
00207       NFAIL = 0
00208       NERRS = 0
00209       DO 10 I = 1, 4
00210          ISEED( I ) = ISEEDY( I )
00211    10 CONTINUE
00212       EPS = DLAMCH( 'Epsilon' )
00213 *
00214 *     Test the error exits
00215 *
00216       IF( TSTERR )
00217      $   CALL ZERRTZ( PATH, NOUT )
00218       INFOT = 0
00219 *
00220       DO 70 IM = 1, NM
00221 *
00222 *        Do for each value of M in MVAL.
00223 *
00224          M = MVAL( IM )
00225          LDA = MAX( 1, M )
00226 *
00227          DO 60 IN = 1, NN
00228 *
00229 *           Do for each value of N in NVAL for which M .LE. N.
00230 *
00231             N = NVAL( IN )
00232             MNMIN = MIN( M, N )
00233             LWORK = MAX( 1, N*N+4*M+N )
00234 *
00235             IF( M.LE.N ) THEN
00236                DO 50 IMODE = 1, NTYPES
00237                   IF( .NOT.DOTYPE( IMODE ) )
00238      $               GO TO 50
00239 *
00240 *                 Do for each type of singular value distribution.
00241 *                    0:  zero matrix
00242 *                    1:  one small singular value
00243 *                    2:  exponential distribution
00244 *
00245                   MODE = IMODE - 1
00246 *
00247 *                 Test ZTZRQF
00248 *
00249 *                 Generate test matrix of size m by n using
00250 *                 singular value distribution indicated by `mode'.
00251 *
00252                   IF( MODE.EQ.0 ) THEN
00253                      CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ),
00254      $                            DCMPLX( ZERO ), A, LDA )
00255                      DO 20 I = 1, MNMIN
00256                         S( I ) = ZERO
00257    20                CONTINUE
00258                   ELSE
00259                      CALL ZLATMS( M, N, 'Uniform', ISEED,
00260      $                            'Nonsymmetric', S, IMODE,
00261      $                            ONE / EPS, ONE, M, N, 'No packing', A,
00262      $                            LDA, WORK, INFO )
00263                      CALL ZGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
00264      $                            INFO )
00265                      CALL ZLASET( 'Lower', M-1, N, DCMPLX( ZERO ),
00266      $                            DCMPLX( ZERO ), A( 2 ), LDA )
00267                      CALL DLAORD( 'Decreasing', MNMIN, S, 1 )
00268                   END IF
00269 *
00270 *                 Save A and its singular values
00271 *
00272                   CALL ZLACPY( 'All', M, N, A, LDA, COPYA, LDA )
00273 *
00274 *                 Call ZTZRQF to reduce the upper trapezoidal matrix to
00275 *                 upper triangular form.
00276 *
00277                   SRNAMT = 'ZTZRQF'
00278                   CALL ZTZRQF( M, N, A, LDA, TAU, INFO )
00279 *
00280 *                 Compute norm(svd(a) - svd(r))
00281 *
00282                   RESULT( 1 ) = ZQRT12( M, M, A, LDA, S, WORK,
00283      $                          LWORK, RWORK )
00284 *
00285 *                 Compute norm( A - R*Q )
00286 *
00287                   RESULT( 2 ) = ZTZT01( M, N, COPYA, A, LDA, TAU, WORK,
00288      $                          LWORK )
00289 *
00290 *                 Compute norm(Q'*Q - I).
00291 *
00292                   RESULT( 3 ) = ZTZT02( M, N, A, LDA, TAU, WORK, LWORK )
00293 *
00294 *                 Test ZTZRZF
00295 *
00296 *                 Generate test matrix of size m by n using
00297 *                 singular value distribution indicated by `mode'.
00298 *
00299                   IF( MODE.EQ.0 ) THEN
00300                      CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ),
00301      $                            DCMPLX( ZERO ), A, LDA )
00302                      DO 30 I = 1, MNMIN
00303                         S( I ) = ZERO
00304    30                CONTINUE
00305                   ELSE
00306                      CALL ZLATMS( M, N, 'Uniform', ISEED,
00307      $                            'Nonsymmetric', S, IMODE,
00308      $                            ONE / EPS, ONE, M, N, 'No packing', A,
00309      $                            LDA, WORK, INFO )
00310                      CALL ZGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
00311      $                            INFO )
00312                      CALL ZLASET( 'Lower', M-1, N, DCMPLX( ZERO ),
00313      $                            DCMPLX( ZERO ), A( 2 ), LDA )
00314                      CALL DLAORD( 'Decreasing', MNMIN, S, 1 )
00315                   END IF
00316 *
00317 *                 Save A and its singular values
00318 *
00319                   CALL ZLACPY( 'All', M, N, A, LDA, COPYA, LDA )
00320 *
00321 *                 Call ZTZRZF to reduce the upper trapezoidal matrix to
00322 *                 upper triangular form.
00323 *
00324                   SRNAMT = 'ZTZRZF'
00325                   CALL ZTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
00326 *
00327 *                 Compute norm(svd(a) - svd(r))
00328 *
00329                   RESULT( 4 ) = ZQRT12( M, M, A, LDA, S, WORK,
00330      $                          LWORK, RWORK )
00331 *
00332 *                 Compute norm( A - R*Q )
00333 *
00334                   RESULT( 5 ) = ZRZT01( M, N, COPYA, A, LDA, TAU, WORK,
00335      $                          LWORK )
00336 *
00337 *                 Compute norm(Q'*Q - I).
00338 *
00339                   RESULT( 6 ) = ZRZT02( M, N, A, LDA, TAU, WORK, LWORK )
00340 *
00341 *                 Print information about the tests that did not pass
00342 *                 the threshold.
00343 *
00344                   DO 40 K = 1, 6
00345                      IF( RESULT( K ).GE.THRESH ) THEN
00346                         IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00347      $                     CALL ALAHD( NOUT, PATH )
00348                         WRITE( NOUT, FMT = 9999 )M, N, IMODE, K,
00349      $                     RESULT( K )
00350                         NFAIL = NFAIL + 1
00351                      END IF
00352    40             CONTINUE
00353                   NRUN = NRUN + 6
00354    50          CONTINUE
00355             END IF
00356    60    CONTINUE
00357    70 CONTINUE
00358 *
00359 *     Print a summary of the results.
00360 *
00361       CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
00362 *
00363  9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2,
00364      $      ', ratio =', G12.5 )
00365 *
00366 *     End if ZCHKTZ
00367 *
00368       END
 All Files Functions