PLASMA  2.4.5
PLASMA - Parallel Linear Algebra for Scalable Multi-core Architectures
 All Data Structures Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros Groups
zchklq.f
Go to the documentation of this file.
1  SUBROUTINE zchklq( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
2  $ ibval, nrhs, thresh, tsterr, nmax, a, af, aq,
3  $ al, ac, b, x, xact, tau, work, rwork, iwork,
4  $ nout )
5 *
6  include 'plasmaf.h'
7 *
8 * -- LAPACK test routine (version 3.1) --
9 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
10 * November 2006
11 *
12 * .. Scalar Arguments ..
13  LOGICAL tsterr
14  INTEGER nm, nmax, nn, nnb, nout, nrhs
15  DOUBLE PRECISION thresh
16 * ..
17 * .. Array Arguments ..
18  LOGICAL dotype( * )
19  INTEGER iwork( * ), mval( * ), nbval( * ), nval( * ),
20  $ nxval( * ), ibval( * )
21  DOUBLE PRECISION rwork( * )
22  COMPLEX*16 a( * ), ac( * ), af( * ), al( * ), aq( * ),
23  $ b( * ), tau( * ), work( * ), x( * ), xact( * )
24 * ..
25 *
26 * Purpose
27 * =======
28 *
29 * ZCHKLQ tests ZGELQF, ZUNGLQ and CUNMLQ.
30 *
31 * Arguments
32 * =========
33 *
34 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
35 * The matrix types to be used for testing. Matrices of type j
36 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
37 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
38 *
39 * NM (input) INTEGER
40 * The number of values of M contained in the vector MVAL.
41 *
42 * MVAL (input) INTEGER array, dimension (NM)
43 * The values of the matrix row dimension M.
44 *
45 * NN (input) INTEGER
46 * The number of values of N contained in the vector NVAL.
47 *
48 * NVAL (input) INTEGER array, dimension (NN)
49 * The values of the matrix column dimension N.
50 *
51 * NNB (input) INTEGER
52 * The number of values of NB and NX contained in the
53 * vectors NBVAL and NXVAL. The blocking parameters are used
54 * in pairs (NB,NX).
55 *
56 * NBVAL (input) INTEGER array, dimension (NNB)
57 * The values of the blocksize NB.
58 *
59 * NXVAL (input) INTEGER array, dimension (NNB)
60 * The values of the crossover point NX.
61 *
62 * NRHS (input) INTEGER
63 * The number of right hand side vectors to be generated for
64 * each linear system.
65 *
66 * THRESH (input) DOUBLE PRECISION
67 * The threshold value for the test ratios. A result is
68 * included in the output file if RESULT >= THRESH. To have
69 * every test ratio printed, use THRESH = 0.
70 *
71 * TSTERR (input) LOGICAL
72 * Flag that indicates whether error exits are to be tested.
73 *
74 * NMAX (input) INTEGER
75 * The maximum value permitted for M or N, used in dimensioning
76 * the work arrays.
77 *
78 * A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
79 *
80 * AF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
81 *
82 * AQ (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
83 *
84 * AL (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
85 *
86 * AC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
87 *
88 * B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
89 *
90 * X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
91 *
92 * XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
93 *
94 * TAU (workspace) COMPLEX*16 array, dimension (NMAX)
95 *
96 * WORK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
97 *
98 * RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
99 *
100 * IWORK (workspace) INTEGER array, dimension (NMAX)
101 *
102 * NOUT (input) INTEGER
103 * The unit number for output.
104 *
105 * =====================================================================
106 *
107 * .. Parameters ..
108  INTEGER ntests
109  parameter( ntests = 7 )
110  INTEGER ntypes
111  parameter( ntypes = 8 )
112  DOUBLE PRECISION zero
113  parameter( zero = 0.0d0 )
114 * ..
115 * .. Local Scalars ..
116  CHARACTER dist, type
117  CHARACTER*3 path
118  INTEGER i, ik, im, imat, in, inb, info, k, kl, ku, lda,
119  $ lwork, m, minmn, mode, n, nb, nerrs, nfail, nk,
120  $ nrun, nt, nx, ib, irh, rhblk
121  DOUBLE PRECISION anorm, cndnum
122 * ..
123 * .. Local Arrays ..
124  INTEGER iseed( 4 ), iseedy( 4 ), kval( 4 )
125  DOUBLE PRECISION result( ntests )
126  INTEGER ht( 2 )
127 * ..
128 * .. External Functions ..
129  LOGICAL zgennd
130  EXTERNAL zgennd
131 * ..
132 * .. External Subroutines ..
133  EXTERNAL alaerh, alahd, alasum, xlaenv, zerrlq,
134  $ zget02, zlacpy, zlarhs, zlatb4, zlatms, zlqt01,
135  $ zlqt02, zlqt03
136 * ..
137 * .. Intrinsic Functions ..
138  INTRINSIC max, min
139 * ..
140 * .. Scalars in Common ..
141  LOGICAL lerr, ok
142  CHARACTER*32 srnamt
143  INTEGER infot, nunit
144 * ..
145 * .. Common blocks ..
146  common / infoc / infot, nunit, ok, lerr
147  common / srnamc / srnamt
148 * ..
149 * .. Data statements ..
150  DATA iseedy / 1988, 1989, 1990, 1991 /
151 * ..
152 * .. Executable Statements ..
153 *
154 * Initialize constants and the random number seed.
155 *
156  rhblk = 4
157  path( 1: 1 ) = 'Zomplex precision'
158  path( 2: 3 ) = 'LQ'
159  nrun = 0
160  nfail = 0
161  nerrs = 0
162  DO 10 i = 1, 4
163  iseed( i ) = iseedy( i )
164  10 continue
165 *
166 * Test the error exits
167 *
168  IF( tsterr )
169  $ CALL zerrlq( path, nout )
170  infot = 0
171  CALL xlaenv( 2, 2 )
172 *
173  lda = nmax
174  lwork = nmax*max( nmax, nrhs )
175 *
176 * Do for each value of M in MVAL.
177 *
178  DO 70 im = 1, nm
179  m = mval( im )
180 *
181 * Do for each value of N in NVAL.
182 *
183  DO 60 in = 1, nn
184  n = nval( in )
185  IF ( n.LT.m )
186  $ go to 60
187  minmn = min( m, n )
188  DO 50 imat = 1, ntypes
189 *
190 * Do the tests only if DOTYPE( IMAT ) is true.
191 *
192  IF( .NOT.dotype( imat ) )
193  $ go to 50
194 *
195 * Set up parameters with ZLATB4 and generate a test matrix
196 * with ZLATMS.
197 *
198  CALL zlatb4( path, imat, m, n, type, kl, ku, anorm, mode,
199  $ cndnum, dist )
200 *
201  srnamt = 'ZLATMS'
202  CALL zlatms( m, n, dist, iseed, type, rwork, mode,
203  $ cndnum, anorm, kl, ku, 'No packing', a, lda,
204  $ work, info )
205 *
206 * Check error code from ZLATMS.
207 *
208  IF( info.NE.0 ) THEN
209  CALL alaerh( path, 'ZLATMS', info, 0, ' ', m, n, -1,
210  $ -1, -1, imat, nfail, nerrs, nout )
211  go to 50
212  END IF
213 *
214 * Set some values for K: the first value must be MINMN,
215 * corresponding to the call of ZLQT01; other values are
216 * used in the calls of ZLQT02, and must not exceed MINMN.
217 *
218  kval( 1 ) = minmn
219  kval( 2 ) = 0
220  kval( 3 ) = 1
221  kval( 4 ) = minmn / 2
222  IF( minmn.EQ.0 ) THEN
223  nk = 1
224  ELSE IF( minmn.EQ.1 ) THEN
225  nk = 2
226  ELSE IF( minmn.LE.3 ) THEN
227  nk = 3
228  ELSE
229  nk = 4
230  END IF
231 *
232 * Set Householder mode (tree or flat)
233 *
234  DO 45 irh = 0, 1
235  IF (irh .EQ. 0) THEN
236  CALL plasma_set(plasma_householder_mode,
237  $ plasma_flat_householder, info )
238  ELSE
239  CALL plasma_set(plasma_householder_mode,
240  $ plasma_tree_householder, info )
241  CALL plasma_set(plasma_householder_size,
242  $ rhblk, info)
243  END IF
244 *
245 * Do for each value of K in KVAL
246 *
247  DO 40 ik = 1, 2
248  k = kval( ik )
249 *
250 * Do for each pair of values (NB,NX) in NBVAL and NXVAL.
251 *
252  DO 30 inb = 1, nnb
253  nb = nbval( inb )
254  ib = ibval( inb )
255  CALL xlaenv( 1, nb )
256  nx = nxval( inb )
257  CALL xlaenv( 3, nx )
258  IF ( (max(m, n) / 10) .GT. nb ) THEN
259  goto 30
260  END IF
261  CALL plasma_set( plasma_tile_size, nb, info )
262  CALL plasma_set( plasma_inner_block_size, ib, info)
263 *
264 * Allocate HT
265 *
266  CALL plasma_alloc_workspace_zgelqf( m, n, ht,
267  $ info )
268 *
269  DO i = 1, ntests
270  result( i ) = zero
271  END DO
272  nt = 2
273  IF( ik.EQ.1 ) THEN
274 *
275 * Test ZGELQF
276 *
277  CALL zlqt01( m, n, a, af, aq, al, lda, ht,
278  $ work, lwork, rwork, result( 1 ) )
279 * IF( .NOT.ZGENND( M, N, AF, LDA ) )
280 * $ RESULT( 8 ) = 2*THRESH
281 * NT = NT + 1
282  ELSE IF( m.LE.n ) THEN
283 *
284 * Test ZUNGLQ, using factorization
285 * returned by ZLQT01
286 *
287  CALL zlqt02( m, n, k, a, af, aq, al, lda, ht,
288  $ work, lwork, rwork, result( 1 ) )
289  ELSE
290  result( 1 ) = zero
291  result( 2 ) = zero
292  END IF
293  IF( m.GE.k ) THEN
294 *
295 * Test ZUNMLQ, using factorization returned
296 * by ZLQT01
297 *
298  CALL zlqt03( m, n, k, af, ac, al, aq, lda, ht,
299  $ work, lwork, rwork, result( 3 ) )
300  nt = nt + 4
301 *
302 * If M>=N and K=N, call ZGELQS to solve a system
303 * with NRHS right hand sides and compute the
304 * residual.
305 *
306  IF( k.EQ.m .AND. inb.EQ.1 ) THEN
307 *
308 * Generate a solution and set the right
309 * hand side.
310 *
311  srnamt = 'ZLARHS'
312  CALL zlarhs( path, 'New', 'Full',
313  $ 'No transpose', m, n, 0, 0,
314  $ nrhs, a, lda, xact, lda, b, lda,
315  $ iseed, info )
316 *
317  CALL zlacpy( 'Full', m, nrhs, b, lda, x,
318  $ lda )
319  srnamt = 'ZGELQS'
320  CALL plasma_zgelqs( m, n, nrhs, af, lda, ht,
321  $ x, lda, info )
322 *
323 * Check error code from ZGELQS.
324 *
325  IF( info.NE.0 )
326  $ CALL alaerh( path, 'ZGELQS', info, 0, ' ',
327  $ m, n, nrhs, -1, nb, imat,
328  $ nfail, nerrs, nout )
329 *
330  CALL zget02( 'No transpose', m, n, nrhs, a,
331  $ lda, x, lda, b, lda, rwork,
332  $ result( 7 ) )
333  nt = nt + 1
334  ELSE
335  result( 7 ) = zero
336  END IF
337  ELSE
338  result( 3 ) = zero
339  result( 4 ) = zero
340  result( 5 ) = zero
341  result( 6 ) = zero
342  END IF
343 *
344 * Print information about the tests that did not
345 * pass the threshold.
346 *
347  DO 20 i = 1, nt
348  IF( result( i ).GE.thresh ) THEN
349  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
350  $ CALL alahd( nout, path )
351  WRITE( nout, fmt = 9999 )m, n, k, nb, nx,
352  $ imat, i, result( i )
353  nfail = nfail + 1
354  END IF
355  20 continue
356  nrun = nrun + nt
357 *
358 * Deallocate T
359 *
360  CALL plasma_dealloc_handle( ht, info )
361  30 continue
362  40 continue
363  45 continue
364  50 continue
365  60 continue
366  70 continue
367 *
368 * Print a summary of the results.
369 *
370  CALL alasum( path, nout, nfail, nrun, nerrs )
371 *
372  9999 format( ' M=', i5, ', N=', i5, ', K=', i5, ', NB=', i4, ', NX=',
373  $ i5, ', type ', i2, ', test(', i2, ')=', g12.5 )
374  return
375 *
376 * End of ZCHKLQ
377 *
378  END