1*> \brief \b DCHKTZ
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*  Definition:
9*  ===========
10*
11*       SUBROUTINE DCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
12*                          COPYA, S, TAU, WORK, NOUT )
13*
14*       .. Scalar Arguments ..
15*       LOGICAL            TSTERR
16*       INTEGER            NM, NN, NOUT
17*       DOUBLE PRECISION   THRESH
18*       ..
19*       .. Array Arguments ..
20*       LOGICAL            DOTYPE( * )
21*       INTEGER            MVAL( * ), NVAL( * )
22*       DOUBLE PRECISION   A( * ), COPYA( * ), S( * ),
23*      $                   TAU( * ), WORK( * )
24*       ..
25*
26*
27*> \par Purpose:
28*  =============
29*>
30*> \verbatim
31*>
32*> DCHKTZ tests DTZRZF.
33*> \endverbatim
34*
35*  Arguments:
36*  ==========
37*
38*> \param[in] DOTYPE
39*> \verbatim
40*>          DOTYPE is LOGICAL array, dimension (NTYPES)
41*>          The matrix types to be used for testing.  Matrices of type j
42*>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
43*>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
44*> \endverbatim
45*>
46*> \param[in] NM
47*> \verbatim
48*>          NM is INTEGER
49*>          The number of values of M contained in the vector MVAL.
50*> \endverbatim
51*>
52*> \param[in] MVAL
53*> \verbatim
54*>          MVAL is INTEGER array, dimension (NM)
55*>          The values of the matrix row dimension M.
56*> \endverbatim
57*>
58*> \param[in] NN
59*> \verbatim
60*>          NN is INTEGER
61*>          The number of values of N contained in the vector NVAL.
62*> \endverbatim
63*>
64*> \param[in] NVAL
65*> \verbatim
66*>          NVAL is INTEGER array, dimension (NN)
67*>          The values of the matrix column dimension N.
68*> \endverbatim
69*>
70*> \param[in] THRESH
71*> \verbatim
72*>          THRESH is DOUBLE PRECISION
73*>          The threshold value for the test ratios.  A result is
74*>          included in the output file if RESULT >= THRESH.  To have
75*>          every test ratio printed, use THRESH = 0.
76*> \endverbatim
77*>
78*> \param[in] TSTERR
79*> \verbatim
80*>          TSTERR is LOGICAL
81*>          Flag that indicates whether error exits are to be tested.
82*> \endverbatim
83*>
84*> \param[out] A
85*> \verbatim
86*>          A is DOUBLE PRECISION array, dimension (MMAX*NMAX)
87*>          where MMAX is the maximum value of M in MVAL and NMAX is the
88*>          maximum value of N in NVAL.
89*> \endverbatim
90*>
91*> \param[out] COPYA
92*> \verbatim
93*>          COPYA is DOUBLE PRECISION array, dimension (MMAX*NMAX)
94*> \endverbatim
95*>
96*> \param[out] S
97*> \verbatim
98*>          S is DOUBLE PRECISION array, dimension
99*>                      (min(MMAX,NMAX))
100*> \endverbatim
101*>
102*> \param[out] TAU
103*> \verbatim
104*>          TAU is DOUBLE PRECISION array, dimension (MMAX)
105*> \endverbatim
106*>
107*> \param[out] WORK
108*> \verbatim
109*>          WORK is DOUBLE PRECISION array, dimension
110*>                      (MMAX*NMAX + 4*NMAX + MMAX)
111*> \endverbatim
112*>
113*> \param[in] NOUT
114*> \verbatim
115*>          NOUT is INTEGER
116*>          The unit number for output.
117*> \endverbatim
118*
119*  Authors:
120*  ========
121*
122*> \author Univ. of Tennessee
123*> \author Univ. of California Berkeley
124*> \author Univ. of Colorado Denver
125*> \author NAG Ltd.
126*
127*> \ingroup double_lin
128*
129*  =====================================================================
130      SUBROUTINE DCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
131     $                   COPYA, S, TAU, WORK, NOUT )
132*
133*  -- LAPACK test routine --
134*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
135*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
136*
137*     .. Scalar Arguments ..
138      LOGICAL            TSTERR
139      INTEGER            NM, NN, NOUT
140      DOUBLE PRECISION   THRESH
141*     ..
142*     .. Array Arguments ..
143      LOGICAL            DOTYPE( * )
144      INTEGER            MVAL( * ), NVAL( * )
145      DOUBLE PRECISION   A( * ), COPYA( * ), S( * ),
146     $                   TAU( * ), WORK( * )
147*     ..
148*
149*  =====================================================================
150*
151*     .. Parameters ..
152      INTEGER            NTYPES
153      PARAMETER          ( NTYPES = 3 )
154      INTEGER            NTESTS
155      PARAMETER          ( NTESTS = 3 )
156      DOUBLE PRECISION   ONE, ZERO
157      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
158*     ..
159*     .. Local Scalars ..
160      CHARACTER*3        PATH
161      INTEGER            I, IM, IMODE, IN, INFO, K, LDA, LWORK, M,
162     $                   MNMIN, MODE, N, NERRS, NFAIL, NRUN
163      DOUBLE PRECISION   EPS
164*     ..
165*     .. Local Arrays ..
166      INTEGER            ISEED( 4 ), ISEEDY( 4 )
167      DOUBLE PRECISION   RESULT( NTESTS )
168*     ..
169*     .. External Functions ..
170      DOUBLE PRECISION   DLAMCH, DQRT12, DRZT01, DRZT02
171      EXTERNAL           DLAMCH, DQRT12, DRZT01, DRZT02
172*     ..
173*     .. External Subroutines ..
174      EXTERNAL           ALAHD, ALASUM, DERRTZ, DGEQR2, DLACPY, DLAORD,
175     $                   DLASET, DLATMS, DTZRZF
176*     ..
177*     .. Intrinsic Functions ..
178      INTRINSIC          MAX, MIN
179*     ..
180*     .. Scalars in Common ..
181      LOGICAL            LERR, OK
182      CHARACTER*32       SRNAMT
183      INTEGER            INFOT, IOUNIT
184*     ..
185*     .. Common blocks ..
186      COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
187      COMMON             / SRNAMC / SRNAMT
188*     ..
189*     .. Data statements ..
190      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
191*     ..
192*     .. Executable Statements ..
193*
194*     Initialize constants and the random number seed.
195*
196      PATH( 1: 1 ) = 'Double precision'
197      PATH( 2: 3 ) = 'TZ'
198      NRUN = 0
199      NFAIL = 0
200      NERRS = 0
201      DO 10 I = 1, 4
202         ISEED( I ) = ISEEDY( I )
203   10 CONTINUE
204      EPS = DLAMCH( 'Epsilon' )
205*
206*     Test the error exits
207*
208      IF( TSTERR )
209     $   CALL DERRTZ( PATH, NOUT )
210      INFOT = 0
211*
212      DO 70 IM = 1, NM
213*
214*        Do for each value of M in MVAL.
215*
216         M = MVAL( IM )
217         LDA = MAX( 1, M )
218*
219         DO 60 IN = 1, NN
220*
221*           Do for each value of N in NVAL for which M .LE. N.
222*
223            N = NVAL( IN )
224            MNMIN = MIN( M, N )
225            LWORK = MAX( 1, N*N+4*M+N, M*N+2*MNMIN+4*N )
226*
227            IF( M.LE.N ) THEN
228               DO 50 IMODE = 1, NTYPES
229                  IF( .NOT.DOTYPE( IMODE ) )
230     $               GO TO 50
231*
232*                 Do for each type of singular value distribution.
233*                    0:  zero matrix
234*                    1:  one small singular value
235*                    2:  exponential distribution
236*
237                  MODE = IMODE - 1
238*
239*                 Test DTZRQF
240*
241*                 Generate test matrix of size m by n using
242*                 singular value distribution indicated by `mode'.
243*
244                  IF( MODE.EQ.0 ) THEN
245                     CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
246                     DO 30 I = 1, MNMIN
247                        S( I ) = ZERO
248   30                CONTINUE
249                  ELSE
250                     CALL DLATMS( M, N, 'Uniform', ISEED,
251     $                            'Nonsymmetric', S, IMODE,
252     $                            ONE / EPS, ONE, M, N, 'No packing', A,
253     $                            LDA, WORK, INFO )
254                     CALL DGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
255     $                            INFO )
256                     CALL DLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ),
257     $                            LDA )
258                     CALL DLAORD( 'Decreasing', MNMIN, S, 1 )
259                  END IF
260*
261*                 Save A and its singular values
262*
263                  CALL DLACPY( 'All', M, N, A, LDA, COPYA, LDA )
264*
265*                 Call DTZRZF to reduce the upper trapezoidal matrix to
266*                 upper triangular form.
267*
268                  SRNAMT = 'DTZRZF'
269                  CALL DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
270*
271*                 Compute norm(svd(a) - svd(r))
272*
273                  RESULT( 1 ) = DQRT12( M, M, A, LDA, S, WORK,
274     $                          LWORK )
275*
276*                 Compute norm( A - R*Q )
277*
278                  RESULT( 2 ) = DRZT01( M, N, COPYA, A, LDA, TAU, WORK,
279     $                          LWORK )
280*
281*                 Compute norm(Q'*Q - I).
282*
283                  RESULT( 3 ) = DRZT02( M, N, A, LDA, TAU, WORK, LWORK )
284*
285*                 Print information about the tests that did not pass
286*                 the threshold.
287*
288                  DO 40 K = 1, NTESTS
289                     IF( RESULT( K ).GE.THRESH ) THEN
290                        IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
291     $                     CALL ALAHD( NOUT, PATH )
292                        WRITE( NOUT, FMT = 9999 )M, N, IMODE, K,
293     $                     RESULT( K )
294                        NFAIL = NFAIL + 1
295                     END IF
296   40             CONTINUE
297                  NRUN = NRUN + 3
298   50          CONTINUE
299            END IF
300   60    CONTINUE
301   70 CONTINUE
302*
303*     Print a summary of the results.
304*
305      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
306*
307 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2,
308     $      ', ratio =', G12.5 )
309*
310*     End if DCHKTZ
311*
312      END
313