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
zchkge.f
Go to the documentation of this file.
1  SUBROUTINE zchkge( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS,
2  $ ibval, nsval, thresh, tsterr, nmax, a, afac,
3  $ ainv, b, x, xact, work, rwork, iwork,
4  $ nout )
5 *
6  include 'plasmaf.h'
7 *
8 * -- LAPACK test routine (version 3.1.1) --
9 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
10 * January 2007
11 *
12 * .. Scalar Arguments ..
13  LOGICAL tsterr
14  INTEGER nm, nmax, nn, nnb, nns, nout
15  DOUBLE PRECISION thresh
16 * ..
17 * .. Array Arguments ..
18  LOGICAL dotype( * )
19  INTEGER iwork( * ), mval( * ), nbval( * ), nsval( * ),
20  $ ibval( * ), nval( * )
21  DOUBLE PRECISION rwork( * )
22  COMPLEX*16 a( * ), afac( * ), ainv( * ), b( * ),
23  $ work( * ), x( * ), xact( * )
24 * ..
25 *
26 * Purpose
27 * =======
28 *
29 * ZCHKGE tests ZGETRF, -TRI, -TRS, -RFS, and -CON.
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 contained in the vector NBVAL.
53 *
54 * NBVAL (input) INTEGER array, dimension (NBVAL)
55 * The values of the blocksize NB.
56 *
57 * IBVAL (input) INTEGER array, dimension (NBVAL)
58 * The values of the inner block size IB.
59 *
60 * NNS (input) INTEGER
61 * The number of values of NRHS contained in the vector NSVAL.
62 *
63 * NSVAL (input) INTEGER array, dimension (NNS)
64 * The values of the number of right hand sides NRHS.
65 *
66 * NRHS (input) INTEGER
67 * The number of right hand side vectors to be generated for
68 * each linear system.
69 *
70 * THRESH (input) DOUBLE PRECISION
71 * The threshold value for the test ratios. A result is
72 * included in the output file if RESULT >= THRESH. To have
73 * every test ratio printed, use THRESH = 0.
74 *
75 * TSTERR (input) LOGICAL
76 * Flag that indicates whether error exits are to be tested.
77 *
78 * NMAX (input) INTEGER
79 * The maximum value permitted for M or N, used in dimensioning
80 * the work arrays.
81 *
82 * A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
83 *
84 * AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
85 *
86 * AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
87 *
88 * B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
89 * where NSMAX is the largest entry in NSVAL.
90 *
91 * X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
92 *
93 * XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
94 *
95 * WORK (workspace) COMPLEX*16 array, dimension
96 * (NMAX*max(3,NSMAX))
97 *
98 * RWORK (workspace) DOUBLE PRECISION array, dimension
99 * (max(2*NMAX,2*NSMAX+NWORK))
100 *
101 * IWORK (workspace) INTEGER array, dimension (NMAX)
102 *
103 * NOUT (input) INTEGER
104 * The unit number for output.
105 *
106 * =====================================================================
107 *
108 * .. Parameters ..
109  DOUBLE PRECISION one, zero
110  parameter( one = 1.0d+0, zero = 0.0d+0 )
111  INTEGER ntypes
112  parameter( ntypes = 11 )
113  INTEGER ntests
114  parameter( ntests = 8 )
115  INTEGER ntran
116  parameter( ntran = 1 )
117 * ..
118 * .. Local Scalars ..
119  LOGICAL trfcon, zerot
120  CHARACTER dist, norm, trans, type, xtype
121  CHARACTER*3 path
122  INTEGER i, im, imat, in, inb, info, ioff, irhs, itran,
123  $ izero, k, kl, ku, lda, lwork, m, mode, n, nb,
124  $ nerrs, nfail, nimat, nrhs, nrun, nt, ib,
125  $ plasma_trans
126  DOUBLE PRECISION ainvnm, anorm, anormi, anormo, cndnum, dummy,
127  $ rcond, rcondc, rcondi, rcondo
128  INTEGER hl( 2 ), hpiv( 2 )
129 * ..
130 * .. Local Arrays ..
131  CHARACTER transs( ntran )
132  INTEGER iseed( 4 ), iseedy( 4 ), plasma_transs( ntran )
133  DOUBLE PRECISION result( ntests )
134 * ..
135 * .. External Functions ..
136  DOUBLE PRECISION dget06, zlange
137  EXTERNAL dget06, zlange
138 * ..
139 * .. External Subroutines ..
140  EXTERNAL alaerh, alahd, alasum, xlaenv, zerrge, zgecon,
141  $ zgerfs, zget02, zget04,
142  $ zgetrf, zgetri, zgetrs, zlacpy, zlarhs, zlaset,
143  $ zlatb4, zlatms
144 * ..
145 * .. Intrinsic Functions ..
146  INTRINSIC dcmplx, max, min
147 * ..
148 * .. Scalars in Common ..
149  LOGICAL lerr, ok
150  CHARACTER*32 srnamt
151  INTEGER infot, nunit
152 * ..
153 * .. Common blocks ..
154  common / infoc / infot, nunit, ok, lerr
155  common / srnamc / srnamt
156 * ..
157 * .. Data statements ..
158  DATA iseedy / 1988, 1989, 1990, 1991 / ,
159 * $ TRANSS / 'N', 'T', 'C' /
160  $ transs / 'N' /
161  $ plasma_transs / plasmanotrans /
162 * ..
163 * .. Executable Statements ..
164 *
165 * Initialize constants and the random number seed.
166 *
167  path( 1: 1 ) = 'Zomplex precision'
168  path( 2: 3 ) = 'GE'
169  rcondo = zero
170  rcondi = zero
171  nrun = 0
172  nfail = 0
173  nerrs = 0
174  DO 10 i = 1, 4
175  iseed( i ) = iseedy( i )
176  10 continue
177 *
178 * Test the error exits
179 *
180  CALL xlaenv( 1, 1 )
181  IF( tsterr )
182  $ CALL zerrge( path, nout )
183  infot = 0
184  CALL xlaenv( 2, 2 )
185 *
186 * Do for each value of M in MVAL
187 *
188  DO 120 im = 1, nm
189  m = mval( im )
190  lda = max( 1, m )
191 *
192 * Do for each value of N in NVAL
193 *
194  DO 110 in = 1, nn
195  n = nval( in )
196  xtype = 'N'
197  nimat = ntypes
198  IF( m.LE.0 .OR. n.LE.0 )
199  $ nimat = 1
200 *
201  DO 100 imat = 1, nimat
202 *
203 * Do the tests only if DOTYPE( IMAT ) is true.
204 *
205  IF( .NOT.dotype( imat ) )
206  $ go to 100
207 *
208 * Skip types 5, 6, or 7 if the matrix size is too small.
209 *
210  zerot = imat.GE.5 .AND. imat.LE.7
211  IF( zerot .AND. n.LT.imat-4 )
212  $ go to 100
213 *
214 * Set up parameters with ZLATB4 and generate a test matrix
215 * with ZLATMS.
216 *
217  CALL zlatb4( path, imat, m, n, type, kl, ku, anorm, mode,
218  $ cndnum, dist )
219 *
220  srnamt = 'ZLATMS'
221  CALL zlatms( m, n, dist, iseed, type, rwork, mode,
222  $ cndnum, anorm, kl, ku, 'No packing', a, lda,
223  $ work, info )
224 *
225 * Check error code from ZLATMS.
226 *
227  IF( info.NE.0 ) THEN
228  CALL alaerh( path, 'ZLATMS', info, 0, ' ', m, n, -1,
229  $ -1, -1, imat, nfail, nerrs, nout )
230  go to 100
231  END IF
232 *
233 * For types 5-7, zero one or more columns of the matrix to
234 * test that INFO is returned correctly.
235 *
236  IF( zerot ) THEN
237  IF( imat.EQ.5 ) THEN
238  izero = 1
239  ELSE IF( imat.EQ.6 ) THEN
240  izero = min( m, n )
241  ELSE
242  izero = min( m, n ) / 2 + 1
243  END IF
244  ioff = ( izero-1 )*lda
245  IF( imat.LT.7 ) THEN
246  DO 20 i = 1, m
247  a( ioff+i ) = zero
248  20 continue
249  ELSE
250  CALL zlaset( 'Full', m, n-izero+1, dcmplx( zero ),
251  $ dcmplx( zero ), a( ioff+1 ), lda )
252  END IF
253  ELSE
254  izero = 0
255  END IF
256 *
257 * These lines, if used in place of the calls in the DO 60
258 * loop, cause the code to bomb on a Sun SPARCstation.
259 *
260 * ANORMO = ZLANGE( 'O', M, N, A, LDA, RWORK )
261 * ANORMI = ZLANGE( 'I', M, N, A, LDA, RWORK )
262 *
263 * Do for each blocksize in NBVAL
264 *
265  DO 90 inb = 1, nnb
266  nb = nbval( inb )
267  CALL xlaenv( 1, nb )
268  ib = ibval( inb )
269  IF ( (max(m, n) / 25) .GT. nb ) THEN
270  goto 90
271  END IF
272  CALL plasma_set( plasma_tile_size, nb, info )
273  CALL plasma_set( plasma_inner_block_size, ib, info )
274 *
275 * ALLOCATE HL and HPIV
276 *
277 c$$$ CALL PLASMA_ALLOC_WORKSPACE_ZGETRF_INCPIV(
278 c$$$ $ M, N, HL, HPIV, INFO )
279 *
280 * Compute the LU factorization of the matrix.
281 *
282  CALL zlacpy( 'Full', m, n, a, lda, afac, lda )
283  srnamt = 'ZGETRF'
284 c$$$ CALL PLASMA_ZGETRF_INCPIV( M, N, AFAC, LDA, HL, HPIV,
285 c$$$ $ INFO )
286  CALL plasma_zgetrf( m, n, afac, lda, iwork,
287  $ info )
288 *
289 * Check error code from ZGETRF.
290 *
291  IF( info.NE.izero )
292  $ CALL alaerh( path, 'ZGETRF', info, izero, ' ', m,
293  $ n, -1, -1, nb, imat, nfail, nerrs,
294  $ nout )
295  trfcon = .false.
296  nt = 0
297 *
298  IF( m.NE.n .OR. info.GT.0 ) THEN
299 *
300 * Do only the condition estimate if INFO > 0.
301 *
302  trfcon = .true.
303  anormo = zlange( 'O', m, n, a, lda, rwork )
304  anormi = zlange( 'I', m, n, a, lda, rwork )
305  rcondo = zero
306  rcondi = zero
307  END IF
308 *
309 * Print information about the tests so far that did not
310 * pass the threshold.
311 *
312  DO 30 k = 1, nt
313  IF( result( k ).GE.thresh ) THEN
314  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
315  $ CALL alahd( nout, path )
316  WRITE( nout, fmt = 9999 )m, n, nb, imat, k,
317  $ result( k )
318  nfail = nfail + 1
319  END IF
320  30 continue
321  nrun = nrun + nt
322 *
323 * Skip the remaining tests if this is not the first
324 * block size or if M .ne. N. Skip the solve tests if
325 * the matrix is singular.
326 *
327 * IF( INB.GT.1 .OR. M.NE.N )
328 * $ GO TO 90
329  IF( trfcon )
330  $ go to 70
331 *
332  DO 60 irhs = 1, nns
333  nrhs = nsval( irhs )
334  xtype = 'N'
335 *
336  DO 50 itran = 1, ntran
337  trans = transs( itran )
338  plasma_trans = plasma_transs( itran )
339  IF( itran.EQ.1 ) THEN
340  rcondc = rcondo
341  ELSE
342  rcondc = rcondi
343  END IF
344 *
345 *+ TEST 3
346 * Solve and compute residual for A * X = B.
347 *
348  srnamt = 'ZLARHS'
349  CALL zlarhs( path, xtype, ' ', trans, n, n, kl,
350  $ ku, nrhs, a, lda, xact, lda, b,
351  $ lda, iseed, info )
352  xtype = 'C'
353 *
354  CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
355  srnamt = 'ZGETRS'
356 c$$$ CALL PLASMA_ZGETRS_INCPIV( PLASMA_TRANS, N,
357 c$$$ $ NRHS, AFAC, LDA, HL, HPIV,
358 c$$$ $ X, LDA, INFO )
359  CALL plasma_zgetrs( plasma_trans, n,
360  $ nrhs, afac, lda, iwork,
361  $ x, lda, info )
362 *
363 * Check error code from ZGETRS.
364 *
365  IF( info.NE.0 )
366  $ CALL alaerh( path, 'ZGETRS', info, 0, trans,
367  $ n, n, -1, -1, nrhs, imat, nfail,
368  $ nerrs, nout )
369 *
370  CALL zlacpy( 'Full', n, nrhs, b, lda, work,
371  $ lda )
372  CALL zget02( trans, n, n, nrhs, a, lda, x, lda,
373  $ work, lda, rwork, result( 3 ) )
374 *
375 *+ TEST 4
376 * Check solution from generated exact solution.
377 *
378  CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
379  $ result( 4 ) )
380 *
381 * Print information about the tests that did not
382 * pass the threshold.
383 *
384  DO 40 k = 3, 4
385  IF( result( k ).GE.thresh ) THEN
386  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
387  $ CALL alahd( nout, path )
388  WRITE( nout, fmt = 9998 )trans, n, nrhs,
389  $ imat, k, result( k )
390  nfail = nfail + 1
391  END IF
392  40 continue
393  nrun = nrun + 2
394  50 continue
395  60 continue
396 *
397  70 continue
398 *
399 * DEALLOCATE HL and HPIV
400 *
401 c$$$ CALL PLASMA_DEALLOC_HANDLE( HL, INFO )
402 c$$$ CALL PLASMA_DEALLOC_HANDLE( HPIV, INFO )
403  90 continue
404  100 continue
405 *
406  110 continue
407  120 continue
408 *
409 * Print a summary of the results.
410 *
411  CALL alasum( path, nout, nfail, nrun, nerrs )
412 *
413  9999 format( ' M = ', i5, ', N =', i5, ', NB =', i4, ', type ', i2,
414  $ ', test(', i2, ') =', g12.5 )
415  9998 format( ' TRANS=''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
416  $ i2, ', test(', i2, ') =', g12.5 )
417  9997 format( ' NORM =''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
418  $ ', test(', i2, ') =', g12.5 )
419  return
420 *
421 * End of ZCHKGE
422 *
423  END