LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ schkpp()

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.

Definition at line 160 of file schkpp.f.

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