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