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
schkpo.f
Go to the documentation of this file.
1  SUBROUTINE schkpo( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
2  $ thresh, tsterr, nmax, a, afac, ainv, b, x,
3  $ xact, work, rwork, iwork, nout )
4 *
5  include 'plasmaf.h'
6 *
7 * -- LAPACK test routine (version 3.1) --
8 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
9 * November 2006
10 *
11 * .. Scalar Arguments ..
12  LOGICAL tsterr
13  INTEGER nmax, nn, nnb, nns, nout
14  REAL thresh
15 * ..
16 * .. Array Arguments ..
17  LOGICAL dotype( * )
18  INTEGER iwork( * ), nbval( * ), nsval( * ), nval( * )
19  REAL a( * ), afac( * ), ainv( * ), b( * ),
20  $ rwork( * ), work( * ), x( * ), xact( * )
21 * ..
22 *
23 * Purpose
24 * =======
25 *
26 * SCHKPO tests SPOTRF, -TRI, -TRS, -RFS, and -CON
27 *
28 * Arguments
29 * =========
30 *
31 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
32 * The matrix types to be used for testing. Matrices of type j
33 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
34 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
35 *
36 * NN (input) INTEGER
37 * The number of values of N contained in the vector NVAL.
38 *
39 * NVAL (input) INTEGER array, dimension (NN)
40 * The values of the matrix dimension N.
41 *
42 * NNB (input) INTEGER
43 * The number of values of NB contained in the vector NBVAL.
44 *
45 * NBVAL (input) INTEGER array, dimension (NBVAL)
46 * The values of the blocksize NB.
47 *
48 * NNS (input) INTEGER
49 * The number of values of NRHS contained in the vector NSVAL.
50 *
51 * NSVAL (input) INTEGER array, dimension (NNS)
52 * The values of the number of right hand sides NRHS.
53 *
54 * THRESH (input) REAL
55 * The threshold value for the test ratios. A result is
56 * included in the output file if RESULT >= THRESH. To have
57 * every test ratio printed, use THRESH = 0.
58 *
59 * TSTERR (input) LOGICAL
60 * Flag that indicates whether error exits are to be tested.
61 *
62 * NMAX (input) INTEGER
63 * The maximum value permitted for N, used in dimensioning the
64 * work arrays.
65 *
66 * A (workspace) REAL array, dimension (NMAX*NMAX)
67 *
68 * AFAC (workspace) REAL array, dimension (NMAX*NMAX)
69 *
70 * AINV (workspace) REAL array, dimension (NMAX*NMAX)
71 *
72 * B (workspace) REAL array, dimension (NMAX*NSMAX)
73 * where NSMAX is the largest entry in NSVAL.
74 *
75 * X (workspace) REAL array, dimension (NMAX*NSMAX)
76 *
77 * XACT (workspace) REAL array, dimension (NMAX*NSMAX)
78 *
79 * WORK (workspace) REAL array, dimension
80 * (NMAX*max(3,NSMAX))
81 *
82 * RWORK (workspace) REAL array, dimension
83 * (max(NMAX,2*NSMAX))
84 *
85 * IWORK (workspace) INTEGER array, dimension (NMAX)
86 *
87 * NOUT (input) INTEGER
88 * The unit number for output.
89 *
90 * =====================================================================
91 *
92 * .. Parameters ..
93  REAL zero
94  parameter( zero = 0.0e+0 )
95  INTEGER ntypes
96  parameter( ntypes = 9 )
97  INTEGER ntests
98  parameter( ntests = 8 )
99 * ..
100 * .. Local Scalars ..
101  LOGICAL zerot
102  CHARACTER dist, type, uplo, xtype
103  CHARACTER*3 path
104  INTEGER i, imat, in, inb, info, ioff, irhs, iuplo,
105  $ izero, k, kl, ku, lda, mode, n, nb, nerrs,
106  $ nfail, nimat, nrhs, nrun
107  INTEGER plasma_uplo
108  REAL anorm, cndnum, rcond, rcondc
109 * ..
110 * .. Local Arrays ..
111  CHARACTER uplos( 2 )
112  INTEGER plasma_uplos( 2 )
113  INTEGER iseed( 4 ), iseedy( 4 )
114  REAL result( ntests )
115 * ..
116 * .. External Functions ..
117  REAL sget06, slansy
118  EXTERNAL sget06, slansy
119 * ..
120 * .. External Subroutines ..
121  EXTERNAL alaerh, alahd, alasum, serrpo, sget04, slacpy,
122  $ slarhs, slatb4, slatms, spocon, sporfs, spot01,
123  $ spot02, spot03, spot05, spotrf, spotri, spotrs,
124  $ xlaenv
125 * ..
126 * .. Scalars in Common ..
127  LOGICAL lerr, ok
128  CHARACTER*32 srnamt
129  INTEGER infot, nunit
130 * ..
131 * .. Common blocks ..
132  common / infoc / infot, nunit, ok, lerr
133  common / srnamc / srnamt
134 * ..
135 * .. Intrinsic Functions ..
136  INTRINSIC max
137 * ..
138 * .. Data statements ..
139  DATA iseedy / 1988, 1989, 1990, 1991 /
140  DATA uplos / 'U', 'L' /
141  DATA plasma_uplos / plasmaupper, plasmalower /
142 * ..
143 * .. Executable Statements ..
144 *
145 * Initialize constants and the random number seed.
146 *
147  path( 1: 1 ) = 'Single precision'
148  path( 2: 3 ) = 'PO'
149  nrun = 0
150  nfail = 0
151  nerrs = 0
152  DO 10 i = 1, 4
153  iseed( i ) = iseedy( i )
154  10 continue
155 *
156 * Test the error exits
157 *
158  IF( tsterr )
159  $ CALL serrpo( path, nout )
160  infot = 0
161  CALL xlaenv( 2, 2 )
162 *
163 * Do for each value of N in NVAL
164 *
165  DO 120 in = 1, nn
166  n = nval( in )
167  lda = max( n, 1 )
168  xtype = 'N'
169  nimat = ntypes
170  IF( n.LE.0 )
171  $ nimat = 1
172 *
173  izero = 0
174  DO 110 imat = 1, nimat
175 *
176 * Do the tests only if DOTYPE( IMAT ) is true.
177 *
178  IF( .NOT.dotype( imat ) )
179  $ go to 110
180 *
181 * Skip types 3, 4, or 5 if the matrix size is too small.
182 *
183  zerot = imat.GE.3 .AND. imat.LE.5
184  IF( zerot .AND. n.LT.imat-2 )
185  $ go to 110
186 *
187 * Do first for UPLO = 'U', then for UPLO = 'L'
188 *
189  DO 100 iuplo = 1, 2
190  uplo = uplos( iuplo )
191  plasma_uplo = plasma_uplos( iuplo )
192 *
193 * Set up parameters with SLATB4 and generate a test matrix
194 * with SLATMS.
195 *
196  CALL slatb4( path, imat, n, n, type, kl, ku, anorm, mode,
197  $ cndnum, dist )
198 *
199  srnamt = 'SLATMS'
200  CALL slatms( n, n, dist, iseed, type, rwork, mode,
201  $ cndnum, anorm, kl, ku, uplo, a, lda, work,
202  $ info )
203 *
204 * Check error code from SLATMS.
205 *
206  IF( info.NE.0 ) THEN
207  CALL alaerh( path, 'SLATMS', info, 0, uplo, n, n, -1,
208  $ -1, -1, imat, nfail, nerrs, nout )
209  go to 100
210  END IF
211 *
212 * For types 3-5, zero one row and column of the matrix to
213 * test that INFO is returned correctly.
214 *
215  IF( zerot ) THEN
216  IF( imat.EQ.3 ) THEN
217  izero = 1
218  ELSE IF( imat.EQ.4 ) THEN
219  izero = n
220  ELSE
221  izero = n / 2 + 1
222  END IF
223  ioff = ( izero-1 )*lda
224 *
225 * Set row and column IZERO of A to 0.
226 *
227  IF( iuplo.EQ.1 ) THEN
228  DO 20 i = 1, izero - 1
229  a( ioff+i ) = zero
230  20 continue
231  ioff = ioff + izero
232  DO 30 i = izero, n
233  a( ioff ) = zero
234  ioff = ioff + lda
235  30 continue
236  ELSE
237  ioff = izero
238  DO 40 i = 1, izero - 1
239  a( ioff ) = zero
240  ioff = ioff + lda
241  40 continue
242  ioff = ioff - izero
243  DO 50 i = izero, n
244  a( ioff+i ) = zero
245  50 continue
246  END IF
247  ELSE
248  izero = 0
249  END IF
250 *
251 * Do for each value of NB in NBVAL
252 *
253  DO 90 inb = 1, nnb
254  nb = nbval( inb )
255  CALL xlaenv( 1, nb )
256  IF ( (n / 25) .GT. nb ) THEN
257  goto 90
258  END IF
259  CALL plasma_set( plasma_tile_size, nb, info )
260 *
261 * Compute the L*L' or U'*U factorization of the matrix.
262 *
263  CALL slacpy( uplo, n, n, a, lda, afac, lda )
264  srnamt = 'SPOTRF'
265  CALL plasma_spotrf( plasma_uplo, n, afac, lda, info )
266 *
267 * Check error code from SPOTRF.
268 *
269  IF( info.NE.izero ) THEN
270  CALL alaerh( path, 'SPOTRF', info, izero, uplo, n,
271  $ n, -1, -1, nb, imat, nfail, nerrs,
272  $ nout )
273  go to 90
274  END IF
275 *
276 * Skip the tests if INFO is not 0.
277 *
278  IF( info.NE.0 )
279  $ go to 90
280 *
281 *+ TEST 1
282 * Reconstruct matrix from factors and compute residual.
283 *
284  CALL slacpy( uplo, n, n, afac, lda, ainv, lda )
285  CALL spot01( uplo, n, a, lda, ainv, lda, rwork,
286  $ result( 1 ) )
287 *
288 *+ TEST 2
289 * Form the inverse and compute the residual.
290 *
291  CALL slacpy( uplo, n, n, afac, lda, ainv, lda )
292  srnamt = 'SPOTRI'
293  CALL plasma_spotri( plasma_uplo, n, ainv, lda,
294  $ info )
295 *
296 * Check error code from SPOTRI.
297 *
298  IF( info.NE.0 )
299  $ CALL alaerh( path, 'SPOTRI', info, 0, uplo, n, n,
300  $ -1, -1, -1, imat, nfail, nerrs, nout )
301 *
302  CALL spot03( uplo, n, a, lda, ainv, lda, work, lda,
303  $ rwork, rcondc, result( 2 ) )
304 *
305 * Print information about the tests that did not pass
306 * the threshold.
307 *
308  DO 60 k = 1, 2
309  IF( result( k ).GE.thresh ) THEN
310  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
311  $ CALL alahd( nout, path )
312  WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
313  $ result( k )
314  nfail = nfail + 1
315  END IF
316  60 continue
317  nrun = nrun + 2
318 *
319 * Skip the rest of the tests unless this is the first
320 * blocksize.
321 *
322  IF( inb.NE.1 )
323  $ go to 90
324 *
325  DO 80 irhs = 1, nns
326  nrhs = nsval( irhs )
327 *
328 *+ TEST 3
329 * Solve and compute residual for A * X = B .
330 *
331  srnamt = 'SLARHS'
332  CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
333  $ nrhs, a, lda, xact, lda, b, lda,
334  $ iseed, info )
335  CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
336 *
337  srnamt = 'SPOTRS'
338  CALL plasma_spotrs( plasma_uplo, n, nrhs, afac,
339  $ lda, x, lda, info )
340 *
341 * Check error code from SPOTRS.
342 *
343  IF( info.NE.0 )
344  $ CALL alaerh( path, 'SPOTRS', info, 0, uplo, n,
345  $ n, -1, -1, nrhs, imat, nfail,
346  $ nerrs, nout )
347 *
348  CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
349  CALL spot02( uplo, n, nrhs, a, lda, x, lda, work,
350  $ lda, rwork, result( 3 ) )
351 *
352 *+ TEST 4
353 * Check solution from generated exact solution.
354 *
355  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
356  $ result( 4 ) )
357 *
358 *+ TESTS 5, 6, and 7
359 * Use iterative refinement to improve the solution.
360 *
361  srnamt = 'SPORFS'
362  CALL sporfs( uplo, n, nrhs, a, lda, afac, lda, b,
363  $ lda, x, lda, rwork, rwork( nrhs+1 ),
364  $ work, iwork, info )
365 *
366 * Check error code from SPORFS.
367 *
368  IF( info.NE.0 )
369  $ CALL alaerh( path, 'SPORFS', info, 0, uplo, n,
370  $ n, -1, -1, nrhs, imat, nfail,
371  $ nerrs, nout )
372 *
373  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
374  $ result( 5 ) )
375  CALL spot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
376  $ xact, lda, rwork, rwork( nrhs+1 ),
377  $ result( 6 ) )
378 *
379 * Print information about the tests that did not pass
380 * the threshold.
381 *
382  DO 70 k = 3, 7
383  IF( result( k ).GE.thresh ) THEN
384  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
385  $ CALL alahd( nout, path )
386  WRITE( nout, fmt = 9998 )uplo, n, nrhs,
387  $ imat, k, result( k )
388  nfail = nfail + 1
389  END IF
390  70 continue
391  nrun = nrun + 5
392  80 continue
393 *
394 *+ TEST 8
395 * Get an estimate of RCOND = 1/CNDNUM.
396 *
397  anorm = slansy( '1', uplo, n, a, lda, rwork )
398  srnamt = 'SPOCON'
399  CALL spocon( uplo, n, afac, lda, anorm, rcond, work,
400  $ iwork, info )
401 *
402 * Check error code from SPOCON.
403 *
404  IF( info.NE.0 )
405  $ CALL alaerh( path, 'SPOCON', info, 0, uplo, n, n,
406  $ -1, -1, -1, imat, nfail, nerrs, nout )
407 *
408  result( 8 ) = sget06( rcond, rcondc )
409 *
410 * Print the test ratio if it is .GE. THRESH.
411 *
412  IF( result( 8 ).GE.thresh ) THEN
413  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
414  $ CALL alahd( nout, path )
415  WRITE( nout, fmt = 9997 )uplo, n, imat, 8,
416  $ result( 8 )
417  nfail = nfail + 1
418  END IF
419  nrun = nrun + 1
420  90 continue
421  100 continue
422  110 continue
423  120 continue
424 *
425 * Print a summary of the results.
426 *
427  CALL alasum( path, nout, nfail, nrun, nerrs )
428 *
429  9999 format( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
430  $ i2, ', test ', i2, ', ratio =', g12.5 )
431  9998 format( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
432  $ i2, ', test(', i2, ') =', g12.5 )
433  9997 format( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
434  $ ', test(', i2, ') =', g12.5 )
435  return
436 *
437 * End of SCHKPO
438 *
439  END