LAPACK: TESTING/LIN/dchktz.f Source File

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