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
cchkge.f
Go to the documentation of this file.
1  SUBROUTINE cchkge( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS,
2  $ ibval, nsval, thresh, tsterr, nmax, a, afac,
3  $ ainv, b, x, xact, work, rwork, iwork, nout )
4 *
5  include 'plasmaf.h'
6 *
7 * -- LAPACK test routine (version 3.1.1) --
8 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
9 * January 2007
10 *
11 * .. Scalar Arguments ..
12  LOGICAL tsterr
13  INTEGER nm, nmax, nn, nnb, nns, nout
14  REAL thresh
15 * ..
16 * .. Array Arguments ..
17  LOGICAL dotype( * )
18  INTEGER iwork( * ), mval( * ), nbval( * ), nsval( * ),
19  $ ibval( * ), nval( * )
20  REAL rwork( * )
21  COMPLEX a( * ), afac( * ), ainv( * ), b( * ),
22  $ work( * ), x( * ), xact( * )
23 * ..
24 *
25 * Purpose
26 * =======
27 *
28 * CCHKGE tests CGETRF, -TRI, -TRS, -RFS, and -CON.
29 *
30 * Arguments
31 * =========
32 *
33 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
34 * The matrix types to be used for testing. Matrices of type j
35 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
36 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
37 *
38 * NM (input) INTEGER
39 * The number of values of M contained in the vector MVAL.
40 *
41 * MVAL (input) INTEGER array, dimension (NM)
42 * The values of the matrix row dimension M.
43 *
44 * NN (input) INTEGER
45 * The number of values of N contained in the vector NVAL.
46 *
47 * NVAL (input) INTEGER array, dimension (NN)
48 * The values of the matrix column dimension N.
49 *
50 * NNB (input) INTEGER
51 * The number of values of NB contained in the vector NBVAL.
52 *
53 * NBVAL (input) INTEGER array, dimension (NBVAL)
54 * The values of the blocksize NB.
55 *
56 * IBVAL (input) INTEGER array, dimension (NBVAL)
57 * The values of the inner block size IB.
58 *
59 * NNS (input) INTEGER
60 * The number of values of NRHS contained in the vector NSVAL.
61 *
62 * NSVAL (input) INTEGER array, dimension (NNS)
63 * The values of the number of right hand sides NRHS.
64 *
65 * NRHS (input) INTEGER
66 * The number of right hand side vectors to be generated for
67 * each linear system.
68 *
69 * THRESH (input) REAL
70 * The threshold value for the test ratios. A result is
71 * included in the output file if RESULT >= THRESH. To have
72 * every test ratio printed, use THRESH = 0.
73 *
74 * TSTERR (input) LOGICAL
75 * Flag that indicates whether error exits are to be tested.
76 *
77 * NMAX (input) INTEGER
78 * The maximum value permitted for M or N, used in dimensioning
79 * the work arrays.
80 *
81 * A (workspace) COMPLEX array, dimension (NMAX*NMAX)
82 *
83 * AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX)
84 *
85 * AINV (workspace) COMPLEX array, dimension (NMAX*NMAX)
86 *
87 * B (workspace) COMPLEX array, dimension (NMAX*NSMAX)
88 * where NSMAX is the largest entry in NSVAL.
89 *
90 * X (workspace) COMPLEX array, dimension (NMAX*NSMAX)
91 *
92 * XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX)
93 *
94 * WORK (workspace) COMPLEX array, dimension
95 * (NMAX*max(3,NSMAX))
96 *
97 * RWORK (workspace) REAL array, dimension
98 * (max(2*NMAX,2*NSMAX+NWORK))
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  REAL one, zero
109  parameter( one = 1.0e+0, zero = 0.0e+0 )
110  INTEGER ntypes
111  parameter( ntypes = 11 )
112  INTEGER ntests
113  parameter( ntests = 8 )
114  INTEGER ntran
115 * ONLY NOTRANS SUPPORTED !!!
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  REAL ainvnm, anorm, anormi, anormo, cndnum, dummy,
127  $ rcond, rcondc, rcondi, rcondo
128 c$$$ INTEGER HL( 2 ), HPIV( 2 )
129 * ..
130 * .. Local Arrays ..
131  CHARACTER transs( ntran )
132  INTEGER iseed( 4 ), iseedy( 4 ), plasma_transs( ntran )
133  REAL result( ntests )
134 * ..
135 * .. External Functions ..
136  REAL clange, sget06
137  EXTERNAL clange, sget06
138 * ..
139 * .. External Subroutines ..
140  EXTERNAL alaerh, alahd, alasum, cerrge, cgecon, cgerfs,
141  $ cget02, cget04, cgetrf,
142  $ cgetri, cgetrs, clacpy, clarhs, claset, clatb4,
143  $ clatms, xlaenv
144 * ..
145 * .. Intrinsic Functions ..
146  INTRINSIC cmplx, 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 ) = 'Complex 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 cerrge( 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 CLATB4 and generate a test matrix
215 * with CLATMS.
216 *
217  CALL clatb4( path, imat, m, n, type, kl, ku, anorm, mode,
218  $ cndnum, dist )
219 *
220  srnamt = 'CLATMS'
221  CALL clatms( 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 CLATMS.
226 *
227  IF( info.NE.0 ) THEN
228  CALL alaerh( path, 'CLATMS', 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 claset( 'Full', m, n-izero+1, cmplx( zero ),
251  $ cmplx( 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 = CLANGE( 'O', M, N, A, LDA, RWORK )
261 * ANORMI = CLANGE( '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_CGETRF_INCPIV(
278 c$$$ $ M, N, HL, HPIV, INFO )
279 *
280 * Compute the LU factorization of the matrix.
281 *
282  CALL clacpy( 'Full', m, n, a, lda, afac, lda )
283  srnamt = 'CGETRF'
284 c$$$ CALL PLASMA_CGETRF_INCPIV( M, N, AFAC, LDA, HL,
285 c$$$ $ HPIV, INFO )
286  CALL plasma_cgetrf( m, n, afac, lda,
287  $ iwork, info )
288 *
289 * Check error code from CGETRF.
290 *
291  IF( info.NE.izero )
292  $ CALL alaerh( path, 'CGETRF', 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 = clange( 'O', m, n, a, lda, rwork )
304  anormi = clange( '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 = 'CLARHS'
349  CALL clarhs( path, xtype, ' ', trans, n, n, kl,
350  $ ku, nrhs, a, lda, xact, lda, b,
351  $ lda, iseed, info )
352  xtype = 'C'
353 *
354  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
355  srnamt = 'CGETRS'
356 c$$$ CALL PLASMA_CGETRS_INCPIV( PLASMA_TRANS, N,
357 c$$$ $ NRHS, AFAC, LDA, HL, HPIV,
358 c$$$ $ X, LDA, INFO )
359  CALL plasma_cgetrs( plasma_trans, n,
360  $ nrhs, afac, lda, iwork,
361  $ x, lda, info )
362 *
363 * Check error code from CGETRS.
364 *
365  IF( info.NE.0 )
366  $ CALL alaerh( path, 'CGETRS', info, 0, trans,
367  $ n, n, -1, -1, nrhs, imat, nfail,
368  $ nerrs, nout )
369 *
370  CALL clacpy( 'Full', n, nrhs, b, lda, work,
371  $ lda )
372  CALL cget02( 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 cget04( 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, nb,
389  $ nrhs, 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, ', NB =', i4,
416 ', $NRHS=', i3, ', type ', 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 CCHKGE
422 *
423  END