1*> \brief \b SCHKQ3
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 SCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
12*                          THRESH, A, COPYA, S, TAU, WORK, IWORK,
13*                          NOUT )
14*
15*       .. Scalar Arguments ..
16*       INTEGER            NM, NN, NNB, NOUT
17*       REAL               THRESH
18*       ..
19*       .. Array Arguments ..
20*       LOGICAL            DOTYPE( * )
21*       INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
22*      $                   NXVAL( * )
23*       REAL               A( * ), COPYA( * ), S( * ),
24*      $                   TAU( * ), WORK( * )
25*       ..
26*
27*
28*> \par Purpose:
29*  =============
30*>
31*> \verbatim
32*>
33*> SCHKQ3 tests SGEQP3.
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 REAL
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 REAL 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 REAL array, dimension (MMAX*NMAX)
109*> \endverbatim
110*>
111*> \param[out] S
112*> \verbatim
113*>          S is REAL array, dimension
114*>                      (min(MMAX,NMAX))
115*> \endverbatim
116*>
117*> \param[out] TAU
118*> \verbatim
119*>          TAU is REAL array, dimension (MMAX)
120*> \endverbatim
121*>
122*> \param[out] WORK
123*> \verbatim
124*>          WORK is REAL array, dimension
125*>                      (MMAX*NMAX + 4*NMAX + MMAX)
126*> \endverbatim
127*>
128*> \param[out] IWORK
129*> \verbatim
130*>          IWORK is INTEGER array, dimension (2*NMAX)
131*> \endverbatim
132*>
133*> \param[in] NOUT
134*> \verbatim
135*>          NOUT is INTEGER
136*>          The unit number for output.
137*> \endverbatim
138*
139*  Authors:
140*  ========
141*
142*> \author Univ. of Tennessee
143*> \author Univ. of California Berkeley
144*> \author Univ. of Colorado Denver
145*> \author NAG Ltd.
146*
147*> \ingroup single_lin
148*
149*  =====================================================================
150      SUBROUTINE SCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
151     $                   THRESH, A, COPYA, S, TAU, WORK, IWORK,
152     $                   NOUT )
153*
154*  -- LAPACK test routine --
155*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
156*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157*
158*     .. Scalar Arguments ..
159      INTEGER            NM, NN, NNB, NOUT
160      REAL               THRESH
161*     ..
162*     .. Array Arguments ..
163      LOGICAL            DOTYPE( * )
164      INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
165     $                   NXVAL( * )
166      REAL               A( * ), COPYA( * ), S( * ),
167     $                   TAU( * ), WORK( * )
168*     ..
169*
170*  =====================================================================
171*
172*     .. Parameters ..
173      INTEGER            NTYPES
174      PARAMETER          ( NTYPES = 6 )
175      INTEGER            NTESTS
176      PARAMETER          ( NTESTS = 3 )
177      REAL               ONE, ZERO
178      PARAMETER          ( ONE = 1.0E0, ZERO = 0.0E0 )
179*     ..
180*     .. Local Scalars ..
181      CHARACTER*3        PATH
182      INTEGER            I, IHIGH, ILOW, IM, IMODE, IN, INB, INFO,
183     $                   ISTEP, K, LDA, LW, LWORK, M, MNMIN, MODE, N,
184     $                   NB, NERRS, NFAIL, NRUN, NX
185      REAL               EPS
186*     ..
187*     .. Local Arrays ..
188      INTEGER            ISEED( 4 ), ISEEDY( 4 )
189      REAL               RESULT( NTESTS )
190*     ..
191*     .. External Functions ..
192      REAL               SLAMCH, SQPT01, SQRT11, SQRT12
193      EXTERNAL           SLAMCH, SQPT01, SQRT11, SQRT12
194*     ..
195*     .. External Subroutines ..
196      EXTERNAL           ALAHD, ALASUM, ICOPY, SGEQP3, SLACPY, SLAORD,
197     $                   SLASET, SLATMS, XLAENV
198*     ..
199*     .. Intrinsic Functions ..
200      INTRINSIC          MAX, MIN
201*     ..
202*     .. Scalars in Common ..
203      LOGICAL            LERR, OK
204      CHARACTER*32       SRNAMT
205      INTEGER            INFOT, IOUNIT
206*     ..
207*     .. Common blocks ..
208      COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
209      COMMON             / SRNAMC / SRNAMT
210*     ..
211*     .. Data statements ..
212      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
213*     ..
214*     .. Executable Statements ..
215*
216*     Initialize constants and the random number seed.
217*
218      PATH( 1: 1 ) = 'Single precision'
219      PATH( 2: 3 ) = 'Q3'
220      NRUN = 0
221      NFAIL = 0
222      NERRS = 0
223      DO 10 I = 1, 4
224         ISEED( I ) = ISEEDY( I )
225   10 CONTINUE
226      EPS = SLAMCH( 'Epsilon' )
227      INFOT = 0
228*
229      DO 90 IM = 1, NM
230*
231*        Do for each value of M in MVAL.
232*
233         M = MVAL( IM )
234         LDA = MAX( 1, M )
235*
236         DO 80 IN = 1, NN
237*
238*           Do for each value of N in NVAL.
239*
240            N = NVAL( IN )
241            MNMIN = MIN( M, N )
242            LWORK = MAX( 1, M*MAX( M, N )+4*MNMIN+MAX( M, N ),
243     $                   M*N + 2*MNMIN + 4*N )
244*
245            DO 70 IMODE = 1, NTYPES
246               IF( .NOT.DOTYPE( IMODE ) )
247     $            GO TO 70
248*
249*              Do for each type of matrix
250*                 1:  zero matrix
251*                 2:  one small singular value
252*                 3:  geometric distribution of singular values
253*                 4:  first n/2 columns fixed
254*                 5:  last n/2 columns fixed
255*                 6:  every second column fixed
256*
257               MODE = IMODE
258               IF( IMODE.GT.3 )
259     $            MODE = 1
260*
261*              Generate test matrix of size m by n using
262*              singular value distribution indicated by `mode'.
263*
264               DO 20 I = 1, N
265                  IWORK( I ) = 0
266   20          CONTINUE
267               IF( IMODE.EQ.1 ) THEN
268                  CALL SLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA )
269                  DO 30 I = 1, MNMIN
270                     S( I ) = ZERO
271   30             CONTINUE
272               ELSE
273                  CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', S,
274     $                         MODE, ONE / EPS, ONE, M, N, 'No packing',
275     $                         COPYA, LDA, WORK, INFO )
276                  IF( IMODE.GE.4 ) THEN
277                     IF( IMODE.EQ.4 ) THEN
278                        ILOW = 1
279                        ISTEP = 1
280                        IHIGH = MAX( 1, N / 2 )
281                     ELSE IF( IMODE.EQ.5 ) THEN
282                        ILOW = MAX( 1, N / 2 )
283                        ISTEP = 1
284                        IHIGH = N
285                     ELSE IF( IMODE.EQ.6 ) THEN
286                        ILOW = 1
287                        ISTEP = 2
288                        IHIGH = N
289                     END IF
290                     DO 40 I = ILOW, IHIGH, ISTEP
291                        IWORK( I ) = 1
292   40                CONTINUE
293                  END IF
294                  CALL SLAORD( 'Decreasing', MNMIN, S, 1 )
295               END IF
296*
297               DO 60 INB = 1, NNB
298*
299*                 Do for each pair of values (NB,NX) in NBVAL and NXVAL.
300*
301                  NB = NBVAL( INB )
302                  CALL XLAENV( 1, NB )
303                  NX = NXVAL( INB )
304                  CALL XLAENV( 3, NX )
305*
306*                 Get a working copy of COPYA into A and a copy of
307*                 vector IWORK.
308*
309                  CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA )
310                  CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 )
311*
312*                 Compute the QR factorization with pivoting of A
313*
314                  LW = MAX( 1, 2*N+NB*( N+1 ) )
315*
316*                 Compute the QP3 factorization of A
317*
318                  SRNAMT = 'SGEQP3'
319                  CALL SGEQP3( M, N, A, LDA, IWORK( N+1 ), TAU, WORK,
320     $                         LW, INFO )
321*
322*                 Compute norm(svd(a) - svd(r))
323*
324                  RESULT( 1 ) = SQRT12( M, N, A, LDA, S, WORK,
325     $                          LWORK )
326*
327*                 Compute norm( A*P - Q*R )
328*
329                  RESULT( 2 ) = SQPT01( M, N, MNMIN, COPYA, A, LDA, TAU,
330     $                          IWORK( N+1 ), WORK, LWORK )
331*
332*                 Compute Q'*Q
333*
334                  RESULT( 3 ) = SQRT11( M, MNMIN, A, LDA, TAU, WORK,
335     $                          LWORK )
336*
337*                 Print information about the tests that did not pass
338*                 the threshold.
339*
340                  DO 50 K = 1, NTESTS
341                     IF( RESULT( K ).GE.THRESH ) THEN
342                        IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
343     $                     CALL ALAHD( NOUT, PATH )
344                        WRITE( NOUT, FMT = 9999 )'SGEQP3', M, N, NB,
345     $                     IMODE, K, RESULT( K )
346                        NFAIL = NFAIL + 1
347                     END IF
348   50             CONTINUE
349                  NRUN = NRUN + NTESTS
350*
351   60          CONTINUE
352   70       CONTINUE
353   80    CONTINUE
354   90 CONTINUE
355*
356*     Print a summary of the results.
357*
358      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
359*
360 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, ', NB =', I4, ', type ',
361     $      I2, ', test ', I2, ', ratio =', G12.5 )
362*
363*     End of SCHKQ3
364*
365      END
366