LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine schkpp ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNS,
integer, dimension( * )  NSVAL,
real  THRESH,
logical  TSTERR,
integer  NMAX,
real, dimension( * )  A,
real, dimension( * )  AFAC,
real, dimension( * )  AINV,
real, dimension( * )  B,
real, dimension( * )  X,
real, dimension( * )  XACT,
real, dimension( * )  WORK,
real, dimension( * )  RWORK,
integer, dimension( * )  IWORK,
integer  NOUT 
)

SCHKPP

Purpose: 
 SCHKPP tests SPPTRF, -TRI, -TRS, -RFS, and -CON
Parameters
[in]DOTYPE
          DOTYPE is LOGICAL array, dimension (NTYPES)
          The matrix types to be used for testing.  Matrices of type j
          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
[in]NN
          NN is INTEGER
          The number of values of N contained in the vector NVAL.
[in]NVAL
          NVAL is INTEGER array, dimension (NN)
          The values of the matrix dimension N.
[in]NNS
          NNS is INTEGER
          The number of values of NRHS contained in the vector NSVAL.
[in]NSVAL
          NSVAL is INTEGER array, dimension (NNS)
          The values of the number of right hand sides NRHS.
[in]THRESH
          THRESH is REAL
          The threshold value for the test ratios.  A result is
          included in the output file if RESULT >= THRESH.  To have
          every test ratio printed, use THRESH = 0.
[in]TSTERR
          TSTERR is LOGICAL
          Flag that indicates whether error exits are to be tested.
[in]NMAX
          NMAX is INTEGER
          The maximum value permitted for N, used in dimensioning the
          work arrays.
[out]A
          A is REAL array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AFAC
          AFAC is REAL array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AINV
          AINV is REAL array, dimension
                      (NMAX*(NMAX+1)/2)
[out]B
          B is REAL array, dimension (NMAX*NSMAX)
          where NSMAX is the largest entry in NSVAL.
[out]X
          X is REAL array, dimension (NMAX*NSMAX)
[out]XACT
          XACT is REAL array, dimension (NMAX*NSMAX)
[out]WORK
          WORK is REAL array, dimension
                      (NMAX*max(3,NSMAX))
[out]RWORK
          RWORK is REAL array, dimension
                      (max(NMAX,2*NSMAX))
[out]IWORK
          IWORK is INTEGER array, dimension (NMAX)
[in]NOUT
          NOUT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
November 2011

Definition at line 165 of file schkpp.f.

165 *
166 * -- LAPACK test routine (version 3.4.0) --
167 * -- LAPACK is a software package provided by Univ. of Tennessee, --
168 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
169 * November 2011
170 *
171 * .. Scalar Arguments ..
172  LOGICAL tsterr
173  INTEGER nmax, nn, nns, nout
174  REAL thresh
175 * ..
176 * .. Array Arguments ..
177  LOGICAL dotype( * )
178  INTEGER iwork( * ), nsval( * ), nval( * )
179  REAL a( * ), afac( * ), ainv( * ), b( * ),
180  $ rwork( * ), work( * ), x( * ), xact( * )
181 * ..
182 *
183 * =====================================================================
184 *
185 * .. Parameters ..
186  REAL zero
187  parameter ( zero = 0.0e+0 )
188  INTEGER ntypes
189  parameter ( ntypes = 9 )
190  INTEGER ntests
191  parameter ( ntests = 8 )
192 * ..
193 * .. Local Scalars ..
194  LOGICAL zerot
195  CHARACTER dist, packit, TYPE, uplo, xtype
196  CHARACTER*3 path
197  INTEGER i, imat, in, info, ioff, irhs, iuplo, izero, k,
198  $ kl, ku, lda, mode, n, nerrs, nfail, nimat, npp,
199  $ nrhs, nrun
200  REAL anorm, cndnum, rcond, rcondc
201 * ..
202 * .. Local Arrays ..
203  CHARACTER packs( 2 ), uplos( 2 )
204  INTEGER iseed( 4 ), iseedy( 4 )
205  REAL result( ntests )
206 * ..
207 * .. External Functions ..
208  REAL sget06, slansp
209  EXTERNAL sget06, slansp
210 * ..
211 * .. External Subroutines ..
212  EXTERNAL alaerh, alahd, alasum, scopy, serrpo, sget04,
213  $ slacpy, slarhs, slatb4, slatms, sppcon, spprfs,
214  $ sppt01, sppt02, sppt03, sppt05, spptrf, spptri,
215  $ spptrs
216 * ..
217 * .. Scalars in Common ..
218  LOGICAL lerr, ok
219  CHARACTER*32 srnamt
220  INTEGER infot, nunit
221 * ..
222 * .. Common blocks ..
223  COMMON / infoc / infot, nunit, ok, lerr
224  COMMON / srnamc / srnamt
225 * ..
226 * .. Intrinsic Functions ..
227  INTRINSIC max
228 * ..
229 * .. Data statements ..
230  DATA iseedy / 1988, 1989, 1990, 1991 /
231  DATA uplos / 'U', 'L' / , packs / 'C', 'R' /
232 * ..
233 * .. Executable Statements ..
234 *
235 * Initialize constants and the random number seed.
236 *
237  path( 1: 1 ) = 'Single precision'
238  path( 2: 3 ) = 'PP'
239  nrun = 0
240  nfail = 0
241  nerrs = 0
242  DO 10 i = 1, 4
243  iseed( i ) = iseedy( i )
244  10 CONTINUE
245 *
246 * Test the error exits
247 *
248  IF( tsterr )
249  $ CALL serrpo( path, nout )
250  infot = 0
251 *
252 * Do for each value of N in NVAL
253 *
254  DO 110 in = 1, nn
255  n = nval( in )
256  lda = max( n, 1 )
257  xtype = 'N'
258  nimat = ntypes
259  IF( n.LE.0 )
260  $ nimat = 1
261 *
262  DO 100 imat = 1, nimat
263 *
264 * Do the tests only if DOTYPE( IMAT ) is true.
265 *
266  IF( .NOT.dotype( imat ) )
267  $ GO TO 100
268 *
269 * Skip types 3, 4, or 5 if the matrix size is too small.
270 *
271  zerot = imat.GE.3 .AND. imat.LE.5
272  IF( zerot .AND. n.LT.imat-2 )
273  $ GO TO 100
274 *
275 * Do first for UPLO = 'U', then for UPLO = 'L'
276 *
277  DO 90 iuplo = 1, 2
278  uplo = uplos( iuplo )
279  packit = packs( iuplo )
280 *
281 * Set up parameters with SLATB4 and generate a test matrix
282 * with SLATMS.
283 *
284  CALL slatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
285  $ cndnum, dist )
286 *
287  srnamt = 'SLATMS'
288  CALL slatms( n, n, dist, iseed, TYPE, rwork, mode,
289  $ cndnum, anorm, kl, ku, packit, a, lda, work,
290  $ info )
291 *
292 * Check error code from SLATMS.
293 *
294  IF( info.NE.0 ) THEN
295  CALL alaerh( path, 'SLATMS', info, 0, uplo, n, n, -1,
296  $ -1, -1, imat, nfail, nerrs, nout )
297  GO TO 90
298  END IF
299 *
300 * For types 3-5, zero one row and column of the matrix to
301 * test that INFO is returned correctly.
302 *
303  IF( zerot ) THEN
304  IF( imat.EQ.3 ) THEN
305  izero = 1
306  ELSE IF( imat.EQ.4 ) THEN
307  izero = n
308  ELSE
309  izero = n / 2 + 1
310  END IF
311 *
312 * Set row and column IZERO of A to 0.
313 *
314  IF( iuplo.EQ.1 ) THEN
315  ioff = ( izero-1 )*izero / 2
316  DO 20 i = 1, izero - 1
317  a( ioff+i ) = zero
318  20 CONTINUE
319  ioff = ioff + izero
320  DO 30 i = izero, n
321  a( ioff ) = zero
322  ioff = ioff + i
323  30 CONTINUE
324  ELSE
325  ioff = izero
326  DO 40 i = 1, izero - 1
327  a( ioff ) = zero
328  ioff = ioff + n - i
329  40 CONTINUE
330  ioff = ioff - izero
331  DO 50 i = izero, n
332  a( ioff+i ) = zero
333  50 CONTINUE
334  END IF
335  ELSE
336  izero = 0
337  END IF
338 *
339 * Compute the L*L' or U'*U factorization of the matrix.
340 *
341  npp = n*( n+1 ) / 2
342  CALL scopy( npp, a, 1, afac, 1 )
343  srnamt = 'SPPTRF'
344  CALL spptrf( uplo, n, afac, info )
345 *
346 * Check error code from SPPTRF.
347 *
348  IF( info.NE.izero ) THEN
349  CALL alaerh( path, 'SPPTRF', info, izero, uplo, n, n,
350  $ -1, -1, -1, imat, nfail, nerrs, nout )
351  GO TO 90
352  END IF
353 *
354 * Skip the tests if INFO is not 0.
355 *
356  IF( info.NE.0 )
357  $ GO TO 90
358 *
359 *+ TEST 1
360 * Reconstruct matrix from factors and compute residual.
361 *
362  CALL scopy( npp, afac, 1, ainv, 1 )
363  CALL sppt01( uplo, n, a, ainv, rwork, result( 1 ) )
364 *
365 *+ TEST 2
366 * Form the inverse and compute the residual.
367 *
368  CALL scopy( npp, afac, 1, ainv, 1 )
369  srnamt = 'SPPTRI'
370  CALL spptri( uplo, n, ainv, info )
371 *
372 * Check error code from SPPTRI.
373 *
374  IF( info.NE.0 )
375  $ CALL alaerh( path, 'SPPTRI', info, 0, uplo, n, n, -1,
376  $ -1, -1, imat, nfail, nerrs, nout )
377 *
378  CALL sppt03( uplo, n, a, ainv, work, lda, rwork, rcondc,
379  $ result( 2 ) )
380 *
381 * Print information about the tests that did not pass
382 * the threshold.
383 *
384  DO 60 k = 1, 2
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 = 9999 )uplo, n, imat, k,
389  $ result( k )
390  nfail = nfail + 1
391  END IF
392  60 CONTINUE
393  nrun = nrun + 2
394 *
395  DO 80 irhs = 1, nns
396  nrhs = nsval( irhs )
397 *
398 *+ TEST 3
399 * Solve and compute residual for A * X = B.
400 *
401  srnamt = 'SLARHS'
402  CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
403  $ nrhs, a, lda, xact, lda, b, lda, iseed,
404  $ info )
405  CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
406 *
407  srnamt = 'SPPTRS'
408  CALL spptrs( uplo, n, nrhs, afac, x, lda, info )
409 *
410 * Check error code from SPPTRS.
411 *
412  IF( info.NE.0 )
413  $ CALL alaerh( path, 'SPPTRS', info, 0, uplo, n, n,
414  $ -1, -1, nrhs, imat, nfail, nerrs,
415  $ nout )
416 *
417  CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
418  CALL sppt02( uplo, n, nrhs, a, x, lda, work, lda,
419  $ rwork, result( 3 ) )
420 *
421 *+ TEST 4
422 * Check solution from generated exact solution.
423 *
424  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
425  $ result( 4 ) )
426 *
427 *+ TESTS 5, 6, and 7
428 * Use iterative refinement to improve the solution.
429 *
430  srnamt = 'SPPRFS'
431  CALL spprfs( uplo, n, nrhs, a, afac, b, lda, x, lda,
432  $ rwork, rwork( nrhs+1 ), work, iwork,
433  $ info )
434 *
435 * Check error code from SPPRFS.
436 *
437  IF( info.NE.0 )
438  $ CALL alaerh( path, 'SPPRFS', info, 0, uplo, n, n,
439  $ -1, -1, nrhs, imat, nfail, nerrs,
440  $ nout )
441 *
442  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
443  $ result( 5 ) )
444  CALL sppt05( uplo, n, nrhs, a, b, lda, x, lda, xact,
445  $ lda, rwork, rwork( nrhs+1 ),
446  $ result( 6 ) )
447 *
448 * Print information about the tests that did not pass
449 * the threshold.
450 *
451  DO 70 k = 3, 7
452  IF( result( k ).GE.thresh ) THEN
453  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
454  $ CALL alahd( nout, path )
455  WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
456  $ k, result( k )
457  nfail = nfail + 1
458  END IF
459  70 CONTINUE
460  nrun = nrun + 5
461  80 CONTINUE
462 *
463 *+ TEST 8
464 * Get an estimate of RCOND = 1/CNDNUM.
465 *
466  anorm = slansp( '1', uplo, n, a, rwork )
467  srnamt = 'SPPCON'
468  CALL sppcon( uplo, n, afac, anorm, rcond, work, iwork,
469  $ info )
470 *
471 * Check error code from SPPCON.
472 *
473  IF( info.NE.0 )
474  $ CALL alaerh( path, 'SPPCON', info, 0, uplo, n, n, -1,
475  $ -1, -1, imat, nfail, nerrs, nout )
476 *
477  result( 8 ) = sget06( rcond, rcondc )
478 *
479 * Print the test ratio if greater than or equal to THRESH.
480 *
481  IF( result( 8 ).GE.thresh ) THEN
482  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
483  $ CALL alahd( nout, path )
484  WRITE( nout, fmt = 9999 )uplo, n, imat, 8,
485  $ result( 8 )
486  nfail = nfail + 1
487  END IF
488  nrun = nrun + 1
489  90 CONTINUE
490  100 CONTINUE
491  110 CONTINUE
492 *
493 * Print a summary of the results.
494 *
495  CALL alasum( path, nout, nfail, nrun, nerrs )
496 *
497  9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', type ', i2, ', test ',
498  $ i2, ', ratio =', g12.5 )
499  9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
500  $ i2, ', test(', i2, ') =', g12.5 )
501  RETURN
502 *
503 * End of SCHKPP
504 *
sppcon
subroutine sppcon(UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO)
SPPCON
Definition: sppcon.f:120
alahd
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:95
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
slatb4
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
Definition: slatb4.f:122
spptrs
subroutine spptrs(UPLO, N, NRHS, AP, B, LDB, INFO)
SPPTRS
Definition: spptrs.f:110
slarhs
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
Definition: slarhs.f:206
sppt05
subroutine sppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPPT05
Definition: sppt05.f:158
sget06
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:57
slacpy
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:105
slatms
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:323
spptri
subroutine spptri(UPLO, N, AP, INFO)
SPPTRI
Definition: spptri.f:95
sget04
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
Definition: sget04.f:104
sppt03
subroutine sppt03(UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, RESID)
SPPT03
Definition: sppt03.f:112
slansp
real function slansp(NORM, UPLO, N, AP, WORK)
SLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix supplied in packed form.
Definition: slansp.f:116
sppt02
subroutine sppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
SPPT02
Definition: sppt02.f:124
spptrf
subroutine spptrf(UPLO, N, AP, INFO)
SPPTRF
Definition: spptrf.f:121
spprfs
subroutine spprfs(UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SPPRFS
Definition: spprfs.f:173
serrpo
subroutine serrpo(PATH, NUNIT)
SERRPO
Definition: serrpo.f:57
scopy
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:53
alasum
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:75
sppt01
subroutine sppt01(UPLO, N, A, AFAC, RWORK, RESID)
SPPT01
Definition: sppt01.f:95

Here is the call graph for this function:

Here is the caller graph for this function: