LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ 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,
210 $ slacpy, slarhs, slatb4, slatms, sppcon, spprfs,
211 $ sppt01, sppt02, sppt03, sppt05, spptrf, spptri,
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*
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
slarhs
subroutine slarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
SLARHS
Definition slarhs.f:205
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
alahd
subroutine alahd(iounit, path)
ALAHD
Definition alahd.f:107
scopy
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
Definition scopy.f:82
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:103
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,...
Definition slansp.f:114
sppcon
subroutine sppcon(uplo, n, ap, anorm, rcond, work, iwork, info)
SPPCON
Definition sppcon.f:118
spprfs
subroutine spprfs(uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr, work, iwork, info)
SPPRFS
Definition spprfs.f:171
spptrf
subroutine spptrf(uplo, n, ap, info)
SPPTRF
Definition spptrf.f:119
spptri
subroutine spptri(uplo, n, ap, info)
SPPTRI
Definition spptri.f:93
spptrs
subroutine spptrs(uplo, n, nrhs, ap, b, ldb, info)
SPPTRS
Definition spptrs.f:108
serrpo
subroutine serrpo(path, nunit)
SERRPO
Definition serrpo.f:55
sget04
subroutine sget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
SGET04
Definition sget04.f:102
sget06
real function sget06(rcond, rcondc)
SGET06
Definition sget06.f:55
slatb4
subroutine slatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
SLATB4
Definition slatb4.f:120
slatms
subroutine slatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
SLATMS
Definition slatms.f:321
sppt01
subroutine sppt01(uplo, n, a, afac, rwork, resid)
SPPT01
Definition sppt01.f:93
sppt02
subroutine sppt02(uplo, n, nrhs, a, x, ldx, b, ldb, rwork, resid)
SPPT02
Definition sppt02.f:122
sppt03
subroutine sppt03(uplo, n, a, ainv, work, ldwork, rwork, rcond, resid)
SPPT03
Definition sppt03.f:110
sppt05
subroutine sppt05(uplo, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
SPPT05
Definition sppt05.f:156
Here is the call graph for this function:
Here is the caller graph for this function: