1*> \brief \b ZCHKQ3
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 ZCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
12*                          THRESH, A, COPYA, S, TAU, WORK, RWORK,
13*                          IWORK, NOUT )
14*
15*       .. Scalar Arguments ..
16*       INTEGER            NM, NN, NNB, NOUT
17*       DOUBLE PRECISION   THRESH
18*       ..
19*       .. Array Arguments ..
20*       LOGICAL            DOTYPE( * )
21*       INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
22*      $                   NXVAL( * )
23*       DOUBLE PRECISION   S( * ), RWORK( * )
24*       COMPLEX*16         A( * ), COPYA( * ), TAU( * ), WORK( * )
25*       ..
26*
27*
28*> \par Purpose:
29*  =============
30*>
31*> \verbatim
32*>
33*> ZCHKQ3 tests ZGEQP3.
34*> \endverbatim
35*
36*  Arguments:
37*  ==========
38*
39*> \param[in] DOTYPE
40*> \verbatim
41*>          DOTYPE is LOGICAL array, dimension (NTYPES)
42*>          The matrix types to be used for testing.  Matrices of type j
43*>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
44*>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
45*> \endverbatim
46*>
47*> \param[in] NM
48*> \verbatim
49*>          NM is INTEGER
50*>          The number of values of M contained in the vector MVAL.
51*> \endverbatim
52*>
53*> \param[in] MVAL
54*> \verbatim
55*>          MVAL is INTEGER array, dimension (NM)
56*>          The values of the matrix row dimension M.
57*> \endverbatim
58*>
59*> \param[in] NN
60*> \verbatim
61*>          NN is INTEGER
62*>          The number of values of N contained in the vector NVAL.
63*> \endverbatim
64*>
65*> \param[in] NVAL
66*> \verbatim
67*>          NVAL is INTEGER array, dimension (NN)
68*>          The values of the matrix column dimension N.
69*> \endverbatim
70*>
71*> \param[in] NNB
72*> \verbatim
73*>          NNB is INTEGER
74*>          The number of values of NB and NX contained in the
75*>          vectors NBVAL and NXVAL.  The blocking parameters are used
76*>          in pairs (NB,NX).
77*> \endverbatim
78*>
79*> \param[in] NBVAL
80*> \verbatim
81*>          NBVAL is INTEGER array, dimension (NNB)
82*>          The values of the blocksize NB.
83*> \endverbatim
84*>
85*> \param[in] NXVAL
86*> \verbatim
87*>          NXVAL is INTEGER array, dimension (NNB)
88*>          The values of the crossover point NX.
89*> \endverbatim
90*>
91*> \param[in] THRESH
92*> \verbatim
93*>          THRESH is DOUBLE PRECISION
94*>          The threshold value for the test ratios.  A result is
95*>          included in the output file if RESULT >= THRESH.  To have
96*>          every test ratio printed, use THRESH = 0.
97*> \endverbatim
98*>
99*> \param[out] A
100*> \verbatim
101*>          A is COMPLEX*16 array, dimension (MMAX*NMAX)
102*>          where MMAX is the maximum value of M in MVAL and NMAX is the
103*>          maximum value of N in NVAL.
104*> \endverbatim
105*>
106*> \param[out] COPYA
107*> \verbatim
108*>          COPYA is COMPLEX*16 array, dimension (MMAX*NMAX)
109*> \endverbatim
110*>
111*> \param[out] S
112*> \verbatim
113*>          S is DOUBLE PRECISION array, dimension
114*>                      (min(MMAX,NMAX))
115*> \endverbatim
116*>
117*> \param[out] TAU
118*> \verbatim
119*>          TAU is COMPLEX*16 array, dimension (MMAX)
120*> \endverbatim
121*>
122*> \param[out] WORK
123*> \verbatim
124*>          WORK is COMPLEX*16 array, dimension
125*>                      (max(M*max(M,N) + 4*min(M,N) + max(M,N)))
126*> \endverbatim
127*>
128*> \param[out] RWORK
129*> \verbatim
130*>          RWORK is DOUBLE PRECISION array, dimension (4*NMAX)
131*> \endverbatim
132*>
133*> \param[out] IWORK
134*> \verbatim
135*>          IWORK is INTEGER array, dimension (2*NMAX)
136*> \endverbatim
137*>
138*> \param[in] NOUT
139*> \verbatim
140*>          NOUT is INTEGER
141*>          The unit number for output.
142*> \endverbatim
143*
144*  Authors:
145*  ========
146*
147*> \author Univ. of Tennessee
148*> \author Univ. of California Berkeley
149*> \author Univ. of Colorado Denver
150*> \author NAG Ltd.
151*
152*> \ingroup complex16_lin
153*
154*  =====================================================================
155      SUBROUTINE ZCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
156     $                   THRESH, A, COPYA, S, TAU, WORK, RWORK,
157     $                   IWORK, NOUT )
158*
159*  -- LAPACK test routine --
160*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
161*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
162*
163*     .. Scalar Arguments ..
164      INTEGER            NM, NN, NNB, NOUT
165      DOUBLE PRECISION   THRESH
166*     ..
167*     .. Array Arguments ..
168      LOGICAL            DOTYPE( * )
169      INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
170     $                   NXVAL( * )
171      DOUBLE PRECISION   S( * ), RWORK( * )
172      COMPLEX*16         A( * ), COPYA( * ), TAU( * ), WORK( * )
173*     ..
174*
175*  =====================================================================
176*
177*     .. Parameters ..
178      INTEGER            NTYPES
179      PARAMETER          ( NTYPES = 6 )
180      INTEGER            NTESTS
181      PARAMETER          ( NTESTS = 3 )
182      DOUBLE PRECISION   ONE, ZERO
183      COMPLEX*16         CZERO
184      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0,
185     $                   CZERO = ( 0.0D+0, 0.0D+0 ) )
186*     ..
187*     .. Local Scalars ..
188      CHARACTER*3        PATH
189      INTEGER            I, IHIGH, ILOW, IM, IMODE, IN, INB, INFO,
190     $                   ISTEP, K, LDA, LW, LWORK, M, MNMIN, MODE, N,
191     $                   NB, NERRS, NFAIL, NRUN, NX
192      DOUBLE PRECISION   EPS
193*     ..
194*     .. Local Arrays ..
195      INTEGER            ISEED( 4 ), ISEEDY( 4 )
196      DOUBLE PRECISION   RESULT( NTESTS )
197*     ..
198*     .. External Functions ..
199      DOUBLE PRECISION   DLAMCH, ZQPT01, ZQRT11, ZQRT12
200      EXTERNAL           DLAMCH, ZQPT01, ZQRT11, ZQRT12
201*     ..
202*     .. External Subroutines ..
203      EXTERNAL           ALAHD, ALASUM, DLAORD, ICOPY, XLAENV, ZGEQP3,
204     $                   ZLACPY, ZLASET, ZLATMS
205*     ..
206*     .. Intrinsic Functions ..
207      INTRINSIC          MAX, MIN
208*     ..
209*     .. Scalars in Common ..
210      LOGICAL            LERR, OK
211      CHARACTER*32       SRNAMT
212      INTEGER            INFOT, IOUNIT
213*     ..
214*     .. Common blocks ..
215      COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
216      COMMON             / SRNAMC / SRNAMT
217*     ..
218*     .. Data statements ..
219      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
220*     ..
221*     .. Executable Statements ..
222*
223*     Initialize constants and the random number seed.
224*
225      PATH( 1: 1 ) = 'Zomplex precision'
226      PATH( 2: 3 ) = 'Q3'
227      NRUN = 0
228      NFAIL = 0
229      NERRS = 0
230      DO 10 I = 1, 4
231         ISEED( I ) = ISEEDY( I )
232   10 CONTINUE
233      EPS = DLAMCH( 'Epsilon' )
234      INFOT = 0
235*
236      DO 90 IM = 1, NM
237*
238*        Do for each value of M in MVAL.
239*
240         M = MVAL( IM )
241         LDA = MAX( 1, M )
242*
243         DO 80 IN = 1, NN
244*
245*           Do for each value of N in NVAL.
246*
247            N = NVAL( IN )
248            MNMIN = MIN( M, N )
249            LWORK = MAX( 1, M*MAX( M, N )+4*MNMIN+MAX( M, N ) )
250*
251            DO 70 IMODE = 1, NTYPES
252               IF( .NOT.DOTYPE( IMODE ) )
253     $            GO TO 70
254*
255*              Do for each type of matrix
256*                 1:  zero matrix
257*                 2:  one small singular value
258*                 3:  geometric distribution of singular values
259*                 4:  first n/2 columns fixed
260*                 5:  last n/2 columns fixed
261*                 6:  every second column fixed
262*
263               MODE = IMODE
264               IF( IMODE.GT.3 )
265     $            MODE = 1
266*
267*              Generate test matrix of size m by n using
268*              singular value distribution indicated by `mode'.
269*
270               DO 20 I = 1, N
271                  IWORK( I ) = 0
272   20          CONTINUE
273               IF( IMODE.EQ.1 ) THEN
274                  CALL ZLASET( 'Full', M, N, CZERO, CZERO, COPYA, LDA )
275                  DO 30 I = 1, MNMIN
276                     S( I ) = ZERO
277   30             CONTINUE
278               ELSE
279                  CALL ZLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', S,
280     $                         MODE, ONE / EPS, ONE, M, N, 'No packing',
281     $                         COPYA, LDA, WORK, INFO )
282                  IF( IMODE.GE.4 ) THEN
283                     IF( IMODE.EQ.4 ) THEN
284                        ILOW = 1
285                        ISTEP = 1
286                        IHIGH = MAX( 1, N / 2 )
287                     ELSE IF( IMODE.EQ.5 ) THEN
288                        ILOW = MAX( 1, N / 2 )
289                        ISTEP = 1
290                        IHIGH = N
291                     ELSE IF( IMODE.EQ.6 ) THEN
292                        ILOW = 1
293                        ISTEP = 2
294                        IHIGH = N
295                     END IF
296                     DO 40 I = ILOW, IHIGH, ISTEP
297                        IWORK( I ) = 1
298   40                CONTINUE
299                  END IF
300                  CALL DLAORD( 'Decreasing', MNMIN, S, 1 )
301               END IF
302*
303               DO 60 INB = 1, NNB
304*
305*                 Do for each pair of values (NB,NX) in NBVAL and NXVAL.
306*
307                  NB = NBVAL( INB )
308                  CALL XLAENV( 1, NB )
309                  NX = NXVAL( INB )
310                  CALL XLAENV( 3, NX )
311*
312*                 Save A and its singular values and a copy of
313*                 vector IWORK.
314*
315                  CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA )
316                  CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 )
317*
318*                 Workspace needed.
319*
320                  LW = NB*( N+1 )
321*
322                  SRNAMT = 'ZGEQP3'
323                  CALL ZGEQP3( M, N, A, LDA, IWORK( N+1 ), TAU, WORK,
324     $                         LW, RWORK, INFO )
325*
326*                 Compute norm(svd(a) - svd(r))
327*
328                  RESULT( 1 ) = ZQRT12( M, N, A, LDA, S, WORK,
329     $                          LWORK, RWORK )
330*
331*                 Compute norm( A*P - Q*R )
332*
333                  RESULT( 2 ) = ZQPT01( M, N, MNMIN, COPYA, A, LDA, TAU,
334     $                          IWORK( N+1 ), WORK, LWORK )
335*
336*                 Compute Q'*Q
337*
338                  RESULT( 3 ) = ZQRT11( M, MNMIN, A, LDA, TAU, WORK,
339     $                          LWORK )
340*
341*                 Print information about the tests that did not pass
342*                 the threshold.
343*
344                  DO 50 K = 1, NTESTS
345                     IF( RESULT( K ).GE.THRESH ) THEN
346                        IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
347     $                     CALL ALAHD( NOUT, PATH )
348                        WRITE( NOUT, FMT = 9999 )'ZGEQP3', M, N, NB,
349     $                     IMODE, K, RESULT( K )
350                        NFAIL = NFAIL + 1
351                     END IF
352   50             CONTINUE
353                  NRUN = NRUN + NTESTS
354*
355   60          CONTINUE
356   70       CONTINUE
357   80    CONTINUE
358   90 CONTINUE
359*
360*     Print a summary of the results.
361*
362      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
363*
364 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, ', NB =', I4, ', type ',
365     $      I2, ', test ', I2, ', ratio =', G12.5 )
366*
367*     End of ZCHKQ3
368*
369      END
370