LAPACK: TESTING/LIN/zchktz.f Source File

Go to the documentation of this file.
00001       SUBROUTINE ZCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
00002      $                   COPYA, S, COPYS, TAU, WORK, RWORK, NOUT )
00003 *
00004 *  -- LAPACK test routine (version 3.1) --
00005 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00006 *     November 2006
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   COPYS( * ), RWORK( * ), S( * )
00017       COMPLEX*16         A( * ), COPYA( * ), TAU( * ), WORK( * )
00018 *     ..
00019 *
00020 *  Purpose
00021 *  =======
00022 *
00023 *  ZCHKTZ tests ZTZRQF and ZTZRZF.
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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 array, dimension (MMAX)
00066 *
00067 *  WORK    (workspace) COMPLEX*16 array, dimension
00068 *                      (MMAX*NMAX + 4*NMAX + MMAX)
00069 *
00070 *  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*NMAX)
00071 *
00072 *  NOUT    (input) INTEGER
00073 *          The unit number for output.
00074 *
00075 *  =====================================================================
00076 *
00077 *     .. Parameters ..
00078       INTEGER            NTYPES
00079       PARAMETER          ( NTYPES = 3 )
00080       INTEGER            NTESTS
00081       PARAMETER          ( NTESTS = 6 )
00082       DOUBLE PRECISION   ONE, ZERO
00083       PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
00084 *     ..
00085 *     .. Local Scalars ..
00086       CHARACTER*3        PATH
00087       INTEGER            I, IM, IMODE, IN, INFO, K, LDA, LWORK, M,
00088      $                   MNMIN, MODE, N, NERRS, NFAIL, NRUN
00089       DOUBLE PRECISION   EPS
00090 *     ..
00091 *     .. Local Arrays ..
00092       INTEGER            ISEED( 4 ), ISEEDY( 4 )
00093       DOUBLE PRECISION   RESULT( NTESTS )
00094 *     ..
00095 *     .. External Functions ..
00096       DOUBLE PRECISION   DLAMCH, ZQRT12, ZRZT01, ZRZT02, ZTZT01, ZTZT02
00097       EXTERNAL           DLAMCH, ZQRT12, ZRZT01, ZRZT02, ZTZT01, ZTZT02
00098 *     ..
00099 *     .. External Subroutines ..
00100       EXTERNAL           ALAHD, ALASUM, DLAORD, ZERRTZ, ZGEQR2, ZLACPY,
00101      $                   ZLASET, ZLATMS, ZTZRQF, ZTZRZF
00102 *     ..
00103 *     .. Intrinsic Functions ..
00104       INTRINSIC          DCMPLX, MAX, MIN
00105 *     ..
00106 *     .. Scalars in Common ..
00107       LOGICAL            LERR, OK
00108       CHARACTER*32       SRNAMT
00109       INTEGER            INFOT, IOUNIT
00110 *     ..
00111 *     .. Common blocks ..
00112       COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
00113       COMMON             / SRNAMC / SRNAMT
00114 *     ..
00115 *     .. Data statements ..
00116       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
00117 *     ..
00118 *     .. Executable Statements ..
00119 *
00120 *     Initialize constants and the random number seed.
00121 *
00122       PATH( 1: 1 ) = 'Zomplex precision'
00123       PATH( 2: 3 ) = 'TZ'
00124       NRUN = 0
00125       NFAIL = 0
00126       NERRS = 0
00127       DO 10 I = 1, 4
00128          ISEED( I ) = ISEEDY( I )
00129    10 CONTINUE
00130       EPS = DLAMCH( 'Epsilon' )
00131 *
00132 *     Test the error exits
00133 *
00134       IF( TSTERR )
00135      $   CALL ZERRTZ( PATH, NOUT )
00136       INFOT = 0
00137 *
00138       DO 70 IM = 1, NM
00139 *
00140 *        Do for each value of M in MVAL.
00141 *
00142          M = MVAL( IM )
00143          LDA = MAX( 1, M )
00144 *
00145          DO 60 IN = 1, NN
00146 *
00147 *           Do for each value of N in NVAL for which M .LE. N.
00148 *
00149             N = NVAL( IN )
00150             MNMIN = MIN( M, N )
00151             LWORK = MAX( 1, N*N+4*M+N )
00152 *
00153             IF( M.LE.N ) THEN
00154                DO 50 IMODE = 1, NTYPES
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 ZTZRQF
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 ZLASET( 'Full', M, N, DCMPLX( ZERO ),
00170      $                            DCMPLX( ZERO ), A, LDA )
00171                      DO 20 I = 1, MNMIN
00172                         COPYS( I ) = ZERO
00173    20                CONTINUE
00174                   ELSE
00175                      CALL ZLATMS( M, N, 'Uniform', ISEED,
00176      $                            'Nonsymmetric', COPYS, IMODE,
00177      $                            ONE / EPS, ONE, M, N, 'No packing', A,
00178      $                            LDA, WORK, INFO )
00179                      CALL ZGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
00180      $                            INFO )
00181                      CALL ZLASET( 'Lower', M-1, N, DCMPLX( ZERO ),
00182      $                            DCMPLX( ZERO ), A( 2 ), LDA )
00183                      CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 )
00184                   END IF
00185 *
00186 *                 Save A and its singular values
00187 *
00188                   CALL ZLACPY( 'All', M, N, A, LDA, COPYA, LDA )
00189 *
00190 *                 Call ZTZRQF to reduce the upper trapezoidal matrix to
00191 *                 upper triangular form.
00192 *
00193                   SRNAMT = 'ZTZRQF'
00194                   CALL ZTZRQF( M, N, A, LDA, TAU, INFO )
00195 *
00196 *                 Compute norm(svd(a) - svd(r))
00197 *
00198                   RESULT( 1 ) = ZQRT12( M, M, A, LDA, COPYS, WORK,
00199      $                          LWORK, RWORK )
00200 *
00201 *                 Compute norm( A - R*Q )
00202 *
00203                   RESULT( 2 ) = ZTZT01( M, N, COPYA, A, LDA, TAU, WORK,
00204      $                          LWORK )
00205 *
00206 *                 Compute norm(Q'*Q - I).
00207 *
00208                   RESULT( 3 ) = ZTZT02( M, N, A, LDA, TAU, WORK, LWORK )
00209 *
00210 *                 Test ZTZRZF
00211 *
00212 *                 Generate test matrix of size m by n using
00213 *                 singular value distribution indicated by `mode'.
00214 *
00215                   IF( MODE.EQ.0 ) THEN
00216                      CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ),
00217      $                            DCMPLX( ZERO ), A, LDA )
00218                      DO 30 I = 1, MNMIN
00219                         COPYS( I ) = ZERO
00220    30                CONTINUE
00221                   ELSE
00222                      CALL ZLATMS( M, N, 'Uniform', ISEED,
00223      $                            'Nonsymmetric', COPYS, IMODE,
00224      $                            ONE / EPS, ONE, M, N, 'No packing', A,
00225      $                            LDA, WORK, INFO )
00226                      CALL ZGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
00227      $                            INFO )
00228                      CALL ZLASET( 'Lower', M-1, N, DCMPLX( ZERO ),
00229      $                            DCMPLX( ZERO ), A( 2 ), LDA )
00230                      CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 )
00231                   END IF
00232 *
00233 *                 Save A and its singular values
00234 *
00235                   CALL ZLACPY( 'All', M, N, A, LDA, COPYA, LDA )
00236 *
00237 *                 Call ZTZRZF to reduce the upper trapezoidal matrix to
00238 *                 upper triangular form.
00239 *
00240                   SRNAMT = 'ZTZRZF'
00241                   CALL ZTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
00242 *
00243 *                 Compute norm(svd(a) - svd(r))
00244 *
00245                   RESULT( 4 ) = ZQRT12( M, M, A, LDA, COPYS, WORK,
00246      $                          LWORK, RWORK )
00247 *
00248 *                 Compute norm( A - R*Q )
00249 *
00250                   RESULT( 5 ) = ZRZT01( M, N, COPYA, A, LDA, TAU, WORK,
00251      $                          LWORK )
00252 *
00253 *                 Compute norm(Q'*Q - I).
00254 *
00255                   RESULT( 6 ) = ZRZT02( M, N, A, LDA, TAU, WORK, LWORK )
00256 *
00257 *                 Print information about the tests that did not pass
00258 *                 the threshold.
00259 *
00260                   DO 40 K = 1, 6
00261                      IF( RESULT( K ).GE.THRESH ) THEN
00262                         IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00263      $                     CALL ALAHD( NOUT, PATH )
00264                         WRITE( NOUT, FMT = 9999 )M, N, IMODE, K,
00265      $                     RESULT( K )
00266                         NFAIL = NFAIL + 1
00267                      END IF
00268    40             CONTINUE
00269                   NRUN = NRUN + 6
00270    50          CONTINUE
00271             END IF
00272    60    CONTINUE
00273    70 CONTINUE
00274 *
00275 *     Print a summary of the results.
00276 *
00277       CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
00278 *
00279  9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2,
00280      $      ', ratio =', G12.5 )
00281 *
00282 *     End if ZCHKTZ
00283 *
00284       END