1*> \brief \b SCKGQR
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 SCKGQR( NM, MVAL, NP, PVAL, NN, NVAL, NMATS, ISEED,
12*                          THRESH, NMAX, A, AF, AQ, AR, TAUA, B, BF, BZ,
13*                          BT, BWK, TAUB, WORK, RWORK, NIN, NOUT, INFO )
14*
15*       .. Scalar Arguments ..
16*       INTEGER            INFO, NIN, NM, NMATS, NMAX, NN, NOUT, NP
17*       REAL               THRESH
18*       ..
19*       .. Array Arguments ..
20*       INTEGER            ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
21*       REAL               A( * ), AF( * ), AQ( * ), AR( * ), B( * ),
22*      $                   BF( * ), BT( * ), BWK( * ), BZ( * ),
23*      $                   RWORK( * ), TAUA( * ), TAUB( * ), WORK( * )
24*       ..
25*
26*
27*> \par Purpose:
28*  =============
29*>
30*> \verbatim
31*>
32*> SCKGQR tests
33*> SGGQRF: GQR factorization for N-by-M matrix A and N-by-P matrix B,
34*> SGGRQF: GRQ factorization for M-by-N matrix A and P-by-N matrix B.
35*> \endverbatim
36*
37*  Arguments:
38*  ==========
39*
40*> \param[in] NM
41*> \verbatim
42*>          NM is INTEGER
43*>          The number of values of M contained in the vector MVAL.
44*> \endverbatim
45*>
46*> \param[in] MVAL
47*> \verbatim
48*>          MVAL is INTEGER array, dimension (NM)
49*>          The values of the matrix row(column) dimension M.
50*> \endverbatim
51*>
52*> \param[in] NP
53*> \verbatim
54*>          NP is INTEGER
55*>          The number of values of P contained in the vector PVAL.
56*> \endverbatim
57*>
58*> \param[in] PVAL
59*> \verbatim
60*>          PVAL is INTEGER array, dimension (NP)
61*>          The values of the matrix row(column) dimension P.
62*> \endverbatim
63*>
64*> \param[in] NN
65*> \verbatim
66*>          NN is INTEGER
67*>          The number of values of N contained in the vector NVAL.
68*> \endverbatim
69*>
70*> \param[in] NVAL
71*> \verbatim
72*>          NVAL is INTEGER array, dimension (NN)
73*>          The values of the matrix column(row) dimension N.
74*> \endverbatim
75*>
76*> \param[in] NMATS
77*> \verbatim
78*>          NMATS is INTEGER
79*>          The number of matrix types to be tested for each combination
80*>          of matrix dimensions.  If NMATS >= NTYPES (the maximum
81*>          number of matrix types), then all the different types are
82*>          generated for testing.  If NMATS < NTYPES, another input line
83*>          is read to get the numbers of the matrix types to be used.
84*> \endverbatim
85*>
86*> \param[in,out] ISEED
87*> \verbatim
88*>          ISEED is INTEGER array, dimension (4)
89*>          On entry, the seed of the random number generator.  The array
90*>          elements should be between 0 and 4095, otherwise they will be
91*>          reduced mod 4096, and ISEED(4) must be odd.
92*>          On exit, the next seed in the random number sequence after
93*>          all the test matrices have been generated.
94*> \endverbatim
95*>
96*> \param[in] THRESH
97*> \verbatim
98*>          THRESH is REAL
99*>          The threshold value for the test ratios.  A result is
100*>          included in the output file if RESULT >= THRESH.  To have
101*>          every test ratio printed, use THRESH = 0.
102*> \endverbatim
103*>
104*> \param[in] NMAX
105*> \verbatim
106*>          NMAX is INTEGER
107*>          The maximum value permitted for M or N, used in dimensioning
108*>          the work arrays.
109*> \endverbatim
110*>
111*> \param[out] A
112*> \verbatim
113*>          A is REAL array, dimension (NMAX*NMAX)
114*> \endverbatim
115*>
116*> \param[out] AF
117*> \verbatim
118*>          AF is REAL array, dimension (NMAX*NMAX)
119*> \endverbatim
120*>
121*> \param[out] AQ
122*> \verbatim
123*>          AQ is REAL array, dimension (NMAX*NMAX)
124*> \endverbatim
125*>
126*> \param[out] AR
127*> \verbatim
128*>          AR is REAL array, dimension (NMAX*NMAX)
129*> \endverbatim
130*>
131*> \param[out] TAUA
132*> \verbatim
133*>          TAUA is REAL array, dimension (NMAX)
134*> \endverbatim
135*>
136*> \param[out] B
137*> \verbatim
138*>          B is REAL array, dimension (NMAX*NMAX)
139*> \endverbatim
140*>
141*> \param[out] BF
142*> \verbatim
143*>          BF is REAL array, dimension (NMAX*NMAX)
144*> \endverbatim
145*>
146*> \param[out] BZ
147*> \verbatim
148*>          BZ is REAL array, dimension (NMAX*NMAX)
149*> \endverbatim
150*>
151*> \param[out] BT
152*> \verbatim
153*>          BT is REAL array, dimension (NMAX*NMAX)
154*> \endverbatim
155*>
156*> \param[out] BWK
157*> \verbatim
158*>          BWK is REAL array, dimension (NMAX*NMAX)
159*> \endverbatim
160*>
161*> \param[out] TAUB
162*> \verbatim
163*>          TAUB is REAL array, dimension (NMAX)
164*> \endverbatim
165*>
166*> \param[out] WORK
167*> \verbatim
168*>          WORK is REAL array, dimension (NMAX*NMAX)
169*> \endverbatim
170*>
171*> \param[out] RWORK
172*> \verbatim
173*>          RWORK is REAL array, dimension (NMAX)
174*> \endverbatim
175*>
176*> \param[in] NIN
177*> \verbatim
178*>          NIN is INTEGER
179*>          The unit number for input.
180*> \endverbatim
181*>
182*> \param[in] NOUT
183*> \verbatim
184*>          NOUT is INTEGER
185*>          The unit number for output.
186*> \endverbatim
187*>
188*> \param[out] INFO
189*> \verbatim
190*>          INFO is INTEGER
191*>          = 0 :  successful exit
192*>          > 0 :  If SLATMS returns an error code, the absolute value
193*>                 of it is returned.
194*> \endverbatim
195*
196*  Authors:
197*  ========
198*
199*> \author Univ. of Tennessee
200*> \author Univ. of California Berkeley
201*> \author Univ. of Colorado Denver
202*> \author NAG Ltd.
203*
204*> \ingroup single_eig
205*
206*  =====================================================================
207      SUBROUTINE SCKGQR( NM, MVAL, NP, PVAL, NN, NVAL, NMATS, ISEED,
208     $                   THRESH, NMAX, A, AF, AQ, AR, TAUA, B, BF, BZ,
209     $                   BT, BWK, TAUB, WORK, RWORK, NIN, NOUT, INFO )
210*
211*  -- LAPACK test routine --
212*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
213*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
214*
215*     .. Scalar Arguments ..
216      INTEGER            INFO, NIN, NM, NMATS, NMAX, NN, NOUT, NP
217      REAL               THRESH
218*     ..
219*     .. Array Arguments ..
220      INTEGER            ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
221      REAL               A( * ), AF( * ), AQ( * ), AR( * ), B( * ),
222     $                   BF( * ), BT( * ), BWK( * ), BZ( * ),
223     $                   RWORK( * ), TAUA( * ), TAUB( * ), WORK( * )
224*     ..
225*
226*  =====================================================================
227*
228*     .. Parameters ..
229      INTEGER            NTESTS
230      PARAMETER          ( NTESTS = 7 )
231      INTEGER            NTYPES
232      PARAMETER          ( NTYPES = 8 )
233*     ..
234*     .. Local Scalars ..
235      LOGICAL            FIRSTT
236      CHARACTER          DISTA, DISTB, TYPE
237      CHARACTER*3        PATH
238      INTEGER            I, IINFO, IM, IMAT, IN, IP, KLA, KLB, KUA, KUB,
239     $                   LDA, LDB, LWORK, M, MODEA, MODEB, N, NFAIL,
240     $                   NRUN, NT, P
241      REAL               ANORM, BNORM, CNDNMA, CNDNMB
242*     ..
243*     .. Local Arrays ..
244      LOGICAL            DOTYPE( NTYPES )
245      REAL               RESULT( NTESTS )
246*     ..
247*     .. External Subroutines ..
248      EXTERNAL           ALAHDG, ALAREQ, ALASUM, SGQRTS, SGRQTS, SLATB9,
249     $                   SLATMS
250*     ..
251*     .. Intrinsic Functions ..
252      INTRINSIC          ABS
253*     ..
254*     .. Executable Statements ..
255*
256*     Initialize constants.
257*
258      PATH( 1: 3 ) = 'GQR'
259      INFO = 0
260      NRUN = 0
261      NFAIL = 0
262      FIRSTT = .TRUE.
263      CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
264      LDA = NMAX
265      LDB = NMAX
266      LWORK = NMAX*NMAX
267*
268*     Do for each value of M in MVAL.
269*
270      DO 60 IM = 1, NM
271         M = MVAL( IM )
272*
273*        Do for each value of P in PVAL.
274*
275         DO 50 IP = 1, NP
276            P = PVAL( IP )
277*
278*           Do for each value of N in NVAL.
279*
280            DO 40 IN = 1, NN
281               N = NVAL( IN )
282*
283               DO 30 IMAT = 1, NTYPES
284*
285*                 Do the tests only if DOTYPE( IMAT ) is true.
286*
287                  IF( .NOT.DOTYPE( IMAT ) )
288     $               GO TO 30
289*
290*                 Test SGGRQF
291*
292*                 Set up parameters with SLATB9 and generate test
293*                 matrices A and B with SLATMS.
294*
295                  CALL SLATB9( 'GRQ', IMAT, M, P, N, TYPE, KLA, KUA,
296     $                         KLB, KUB, ANORM, BNORM, MODEA, MODEB,
297     $                         CNDNMA, CNDNMB, DISTA, DISTB )
298*
299*                 Generate M by N matrix A
300*
301                  CALL SLATMS( M, N, DISTA, ISEED, TYPE, RWORK, MODEA,
302     $                         CNDNMA, ANORM, KLA, KUA, 'No packing', A,
303     $                         LDA, WORK, IINFO )
304                  IF( IINFO.NE.0 ) THEN
305                     WRITE( NOUT, FMT = 9999 )IINFO
306                     INFO = ABS( IINFO )
307                     GO TO 30
308                  END IF
309*
310*                 Generate P by N matrix B
311*
312                  CALL SLATMS( P, N, DISTB, ISEED, TYPE, RWORK, MODEB,
313     $                         CNDNMB, BNORM, KLB, KUB, 'No packing', B,
314     $                         LDB, WORK, IINFO )
315                  IF( IINFO.NE.0 ) THEN
316                     WRITE( NOUT, FMT = 9999 )IINFO
317                     INFO = ABS( IINFO )
318                     GO TO 30
319                  END IF
320*
321                  NT = 4
322*
323                  CALL SGRQTS( M, P, N, A, AF, AQ, AR, LDA, TAUA, B, BF,
324     $                         BZ, BT, BWK, LDB, TAUB, WORK, LWORK,
325     $                         RWORK, RESULT )
326*
327*                 Print information about the tests that did not
328*                 pass the threshold.
329*
330                  DO 10 I = 1, NT
331                     IF( RESULT( I ).GE.THRESH ) THEN
332                        IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
333                           FIRSTT = .FALSE.
334                           CALL ALAHDG( NOUT, 'GRQ' )
335                        END IF
336                        WRITE( NOUT, FMT = 9998 )M, P, N, IMAT, I,
337     $                     RESULT( I )
338                        NFAIL = NFAIL + 1
339                     END IF
340   10             CONTINUE
341                  NRUN = NRUN + NT
342*
343*                 Test SGGQRF
344*
345*                 Set up parameters with SLATB9 and generate test
346*                 matrices A and B with SLATMS.
347*
348                  CALL SLATB9( 'GQR', IMAT, M, P, N, TYPE, KLA, KUA,
349     $                         KLB, KUB, ANORM, BNORM, MODEA, MODEB,
350     $                         CNDNMA, CNDNMB, DISTA, DISTB )
351*
352*                 Generate N-by-M matrix  A
353*
354                  CALL SLATMS( N, M, DISTA, ISEED, TYPE, RWORK, MODEA,
355     $                         CNDNMA, ANORM, KLA, KUA, 'No packing', A,
356     $                         LDA, WORK, IINFO )
357                  IF( IINFO.NE.0 ) THEN
358                     WRITE( NOUT, FMT = 9999 )IINFO
359                     INFO = ABS( IINFO )
360                     GO TO 30
361                  END IF
362*
363*                 Generate N-by-P matrix  B
364*
365                  CALL SLATMS( N, P, DISTB, ISEED, TYPE, RWORK, MODEA,
366     $                         CNDNMA, BNORM, KLB, KUB, 'No packing', B,
367     $                         LDB, WORK, IINFO )
368                  IF( IINFO.NE.0 ) THEN
369                     WRITE( NOUT, FMT = 9999 )IINFO
370                     INFO = ABS( IINFO )
371                     GO TO 30
372                  END IF
373*
374                  NT = 4
375*
376                  CALL SGQRTS( N, M, P, A, AF, AQ, AR, LDA, TAUA, B, BF,
377     $                         BZ, BT, BWK, LDB, TAUB, WORK, LWORK,
378     $                         RWORK, RESULT )
379*
380*                 Print information about the tests that did not
381*                 pass the threshold.
382*
383                  DO 20 I = 1, NT
384                     IF( RESULT( I ).GE.THRESH ) THEN
385                        IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
386                           FIRSTT = .FALSE.
387                           CALL ALAHDG( NOUT, PATH )
388                        END IF
389                        WRITE( NOUT, FMT = 9997 )N, M, P, IMAT, I,
390     $                     RESULT( I )
391                        NFAIL = NFAIL + 1
392                     END IF
393   20             CONTINUE
394                  NRUN = NRUN + NT
395*
396   30          CONTINUE
397   40       CONTINUE
398   50    CONTINUE
399   60 CONTINUE
400*
401*     Print a summary of the results.
402*
403      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 )
404*
405 9999 FORMAT( ' SLATMS in SCKGQR:    INFO = ', I5 )
406 9998 FORMAT( ' M=', I4, ' P=', I4, ', N=', I4, ', type ', I2,
407     $      ', test ', I2, ', ratio=', G13.6 )
408 9997 FORMAT( ' N=', I4, ' M=', I4, ', P=', I4, ', type ', I2,
409     $      ', test ', I2, ', ratio=', G13.6 )
410      RETURN
411*
412*     End of SCKGQR
413*
414      END
415