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

◆ schksp()

subroutine schksp ( 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 
)

SCHKSP

Purpose:
 SCHKSP tests SSPTRF, -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(2,NSMAX))
[out]RWORK
          RWORK is REAL array,
                                 dimension (NMAX+2*NSMAX)
[out]IWORK
          IWORK is INTEGER array, dimension (2*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 schksp.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 = 10 )
187 INTEGER NTESTS
188 parameter( ntests = 8 )
189* ..
190* .. Local Scalars ..
191 LOGICAL TRFCON, ZEROT
192 CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
193 CHARACTER*3 PATH
194 INTEGER I, I1, I2, IMAT, IN, INFO, IOFF, IRHS, IUPLO,
195 $ IZERO, J, K, KL, KU, LDA, MODE, N, NERRS,
196 $ NFAIL, NIMAT, NPP, NRHS, NRUN, NT
197 REAL ANORM, CNDNUM, RCOND, RCONDC
198* ..
199* .. Local Arrays ..
200 CHARACTER UPLOS( 2 )
201 INTEGER ISEED( 4 ), ISEEDY( 4 )
202 REAL RESULT( NTESTS )
203* ..
204* .. External Functions ..
205 LOGICAL LSAME
206 REAL SGET06, SLANSP
207 EXTERNAL lsame, sget06, slansp
208* ..
209* .. External Subroutines ..
210 EXTERNAL alaerh, alahd, alasum, scopy, serrsy, sget04,
211 $ slacpy, slarhs, slatb4, slatms, sppt02, sppt03,
212 $ sppt05, sspcon, ssprfs, sspt01, ssptrf, ssptri,
213 $ ssptrs
214* ..
215* .. Intrinsic Functions ..
216 INTRINSIC max, min
217* ..
218* .. Scalars in Common ..
219 LOGICAL LERR, OK
220 CHARACTER*32 SRNAMT
221 INTEGER INFOT, NUNIT
222* ..
223* .. Common blocks ..
224 COMMON / infoc / infot, nunit, ok, lerr
225 COMMON / srnamc / srnamt
226* ..
227* .. Data statements ..
228 DATA iseedy / 1988, 1989, 1990, 1991 /
229 DATA uplos / 'U', 'L' /
230* ..
231* .. Executable Statements ..
232*
233* Initialize constants and the random number seed.
234*
235 path( 1: 1 ) = 'Single precision'
236 path( 2: 3 ) = 'SP'
237 nrun = 0
238 nfail = 0
239 nerrs = 0
240 DO 10 i = 1, 4
241 iseed( i ) = iseedy( i )
242 10 CONTINUE
243*
244* Test the error exits
245*
246 IF( tsterr )
247 $ CALL serrsy( path, nout )
248 infot = 0
249*
250* Do for each value of N in NVAL
251*
252 DO 170 in = 1, nn
253 n = nval( in )
254 lda = max( n, 1 )
255 xtype = 'N'
256 nimat = ntypes
257 IF( n.LE.0 )
258 $ nimat = 1
259*
260 izero = 0
261 DO 160 imat = 1, nimat
262*
263* Do the tests only if DOTYPE( IMAT ) is true.
264*
265 IF( .NOT.dotype( imat ) )
266 $ GO TO 160
267*
268* Skip types 3, 4, 5, or 6 if the matrix size is too small.
269*
270 zerot = imat.GE.3 .AND. imat.LE.6
271 IF( zerot .AND. n.LT.imat-2 )
272 $ GO TO 160
273*
274* Do first for UPLO = 'U', then for UPLO = 'L'
275*
276 DO 150 iuplo = 1, 2
277 uplo = uplos( iuplo )
278 IF( lsame( uplo, 'U' ) ) THEN
279 packit = 'C'
280 ELSE
281 packit = 'R'
282 END IF
283*
284* Set up parameters with SLATB4 and generate a test matrix
285* with SLATMS.
286*
287 CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
288 $ CNDNUM, DIST )
289*
290 srnamt = 'SLATMS'
291 CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
292 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
293 $ INFO )
294*
295* Check error code from SLATMS.
296*
297 IF( info.NE.0 ) THEN
298 CALL alaerh( path, 'SLATMS', info, 0, uplo, n, n, -1,
299 $ -1, -1, imat, nfail, nerrs, nout )
300 GO TO 150
301 END IF
302*
303* For types 3-6, zero one or more rows and columns of
304* the matrix to test that INFO is returned correctly.
305*
306 IF( zerot ) THEN
307 IF( imat.EQ.3 ) THEN
308 izero = 1
309 ELSE IF( imat.EQ.4 ) THEN
310 izero = n
311 ELSE
312 izero = n / 2 + 1
313 END IF
314*
315 IF( imat.LT.6 ) THEN
316*
317* Set row and column IZERO to zero.
318*
319 IF( iuplo.EQ.1 ) THEN
320 ioff = ( izero-1 )*izero / 2
321 DO 20 i = 1, izero - 1
322 a( ioff+i ) = zero
323 20 CONTINUE
324 ioff = ioff + izero
325 DO 30 i = izero, n
326 a( ioff ) = zero
327 ioff = ioff + i
328 30 CONTINUE
329 ELSE
330 ioff = izero
331 DO 40 i = 1, izero - 1
332 a( ioff ) = zero
333 ioff = ioff + n - i
334 40 CONTINUE
335 ioff = ioff - izero
336 DO 50 i = izero, n
337 a( ioff+i ) = zero
338 50 CONTINUE
339 END IF
340 ELSE
341 ioff = 0
342 IF( iuplo.EQ.1 ) THEN
343*
344* Set the first IZERO rows and columns to zero.
345*
346 DO 70 j = 1, n
347 i2 = min( j, izero )
348 DO 60 i = 1, i2
349 a( ioff+i ) = zero
350 60 CONTINUE
351 ioff = ioff + j
352 70 CONTINUE
353 ELSE
354*
355* Set the last IZERO rows and columns to zero.
356*
357 DO 90 j = 1, n
358 i1 = max( j, izero )
359 DO 80 i = i1, n
360 a( ioff+i ) = zero
361 80 CONTINUE
362 ioff = ioff + n - j
363 90 CONTINUE
364 END IF
365 END IF
366 ELSE
367 izero = 0
368 END IF
369*
370* Compute the L*D*L' or U*D*U' factorization of the matrix.
371*
372 npp = n*( n+1 ) / 2
373 CALL scopy( npp, a, 1, afac, 1 )
374 srnamt = 'SSPTRF'
375 CALL ssptrf( uplo, n, afac, iwork, info )
376*
377* Adjust the expected value of INFO to account for
378* pivoting.
379*
380 k = izero
381 IF( k.GT.0 ) THEN
382 100 CONTINUE
383 IF( iwork( k ).LT.0 ) THEN
384 IF( iwork( k ).NE.-k ) THEN
385 k = -iwork( k )
386 GO TO 100
387 END IF
388 ELSE IF( iwork( k ).NE.k ) THEN
389 k = iwork( k )
390 GO TO 100
391 END IF
392 END IF
393*
394* Check error code from SSPTRF.
395*
396 IF( info.NE.k )
397 $ CALL alaerh( path, 'SSPTRF', info, k, uplo, n, n, -1,
398 $ -1, -1, imat, nfail, nerrs, nout )
399 IF( info.NE.0 ) THEN
400 trfcon = .true.
401 ELSE
402 trfcon = .false.
403 END IF
404*
405*+ TEST 1
406* Reconstruct matrix from factors and compute residual.
407*
408 CALL sspt01( uplo, n, a, afac, iwork, ainv, lda, rwork,
409 $ result( 1 ) )
410 nt = 1
411*
412*+ TEST 2
413* Form the inverse and compute the residual.
414*
415 IF( .NOT.trfcon ) THEN
416 CALL scopy( npp, afac, 1, ainv, 1 )
417 srnamt = 'SSPTRI'
418 CALL ssptri( uplo, n, ainv, iwork, work, info )
419*
420* Check error code from SSPTRI.
421*
422 IF( info.NE.0 )
423 $ CALL alaerh( path, 'SSPTRI', info, 0, uplo, n, n,
424 $ -1, -1, -1, imat, nfail, nerrs, nout )
425*
426 CALL sppt03( uplo, n, a, ainv, work, lda, rwork,
427 $ rcondc, result( 2 ) )
428 nt = 2
429 END IF
430*
431* Print information about the tests that did not pass
432* the threshold.
433*
434 DO 110 k = 1, nt
435 IF( result( k ).GE.thresh ) THEN
436 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
437 $ CALL alahd( nout, path )
438 WRITE( nout, fmt = 9999 )uplo, n, imat, k,
439 $ result( k )
440 nfail = nfail + 1
441 END IF
442 110 CONTINUE
443 nrun = nrun + nt
444*
445* Do only the condition estimate if INFO is not 0.
446*
447 IF( trfcon ) THEN
448 rcondc = zero
449 GO TO 140
450 END IF
451*
452 DO 130 irhs = 1, nns
453 nrhs = nsval( irhs )
454*
455*+ TEST 3
456* Solve and compute residual for A * X = B.
457*
458 srnamt = 'SLARHS'
459 CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
460 $ nrhs, a, lda, xact, lda, b, lda, iseed,
461 $ info )
462 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
463*
464 srnamt = 'SSPTRS'
465 CALL ssptrs( uplo, n, nrhs, afac, iwork, x, lda,
466 $ info )
467*
468* Check error code from SSPTRS.
469*
470 IF( info.NE.0 )
471 $ CALL alaerh( path, 'SSPTRS', info, 0, uplo, n, n,
472 $ -1, -1, nrhs, imat, nfail, nerrs,
473 $ nout )
474*
475 CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
476 CALL sppt02( uplo, n, nrhs, a, x, lda, work, lda,
477 $ rwork, result( 3 ) )
478*
479*+ TEST 4
480* Check solution from generated exact solution.
481*
482 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
483 $ result( 4 ) )
484*
485*+ TESTS 5, 6, and 7
486* Use iterative refinement to improve the solution.
487*
488 srnamt = 'SSPRFS'
489 CALL ssprfs( uplo, n, nrhs, a, afac, iwork, b, lda, x,
490 $ lda, rwork, rwork( nrhs+1 ), work,
491 $ iwork( n+1 ), info )
492*
493* Check error code from SSPRFS.
494*
495 IF( info.NE.0 )
496 $ CALL alaerh( path, 'SSPRFS', info, 0, uplo, n, n,
497 $ -1, -1, nrhs, imat, nfail, nerrs,
498 $ nout )
499*
500 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
501 $ result( 5 ) )
502 CALL sppt05( uplo, n, nrhs, a, b, lda, x, lda, xact,
503 $ lda, rwork, rwork( nrhs+1 ),
504 $ result( 6 ) )
505*
506* Print information about the tests that did not pass
507* the threshold.
508*
509 DO 120 k = 3, 7
510 IF( result( k ).GE.thresh ) THEN
511 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
512 $ CALL alahd( nout, path )
513 WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
514 $ k, result( k )
515 nfail = nfail + 1
516 END IF
517 120 CONTINUE
518 nrun = nrun + 5
519 130 CONTINUE
520*
521*+ TEST 8
522* Get an estimate of RCOND = 1/CNDNUM.
523*
524 140 CONTINUE
525 anorm = slansp( '1', uplo, n, a, rwork )
526 srnamt = 'SSPCON'
527 CALL sspcon( uplo, n, afac, iwork, anorm, rcond, work,
528 $ iwork( n+1 ), info )
529*
530* Check error code from SSPCON.
531*
532 IF( info.NE.0 )
533 $ CALL alaerh( path, 'SSPCON', info, 0, uplo, n, n, -1,
534 $ -1, -1, imat, nfail, nerrs, nout )
535*
536 result( 8 ) = sget06( rcond, rcondc )
537*
538* Print the test ratio if it is .GE. THRESH.
539*
540 IF( result( 8 ).GE.thresh ) THEN
541 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
542 $ CALL alahd( nout, path )
543 WRITE( nout, fmt = 9999 )uplo, n, imat, 8,
544 $ result( 8 )
545 nfail = nfail + 1
546 END IF
547 nrun = nrun + 1
548 150 CONTINUE
549 160 CONTINUE
550 170 CONTINUE
551*
552* Print a summary of the results.
553*
554 CALL alasum( path, nout, nfail, nrun, nerrs )
555*
556 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', type ', i2, ', test ',
557 $ i2, ', ratio =', g12.5 )
558 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
559 $ i2, ', test(', i2, ') =', g12.5 )
560 RETURN
561*
562* End of SCHKSP
563*
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
sspcon
subroutine sspcon(uplo, n, ap, ipiv, anorm, rcond, work, iwork, info)
SSPCON
Definition sspcon.f:125
ssprfs
subroutine ssprfs(uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
SSPRFS
Definition ssprfs.f:179
ssptrf
subroutine ssptrf(uplo, n, ap, ipiv, info)
SSPTRF
Definition ssptrf.f:157
ssptri
subroutine ssptri(uplo, n, ap, ipiv, work, info)
SSPTRI
Definition ssptri.f:109
ssptrs
subroutine ssptrs(uplo, n, nrhs, ap, ipiv, b, ldb, info)
SSPTRS
Definition ssptrs.f:115
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
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
serrsy
subroutine serrsy(path, nunit)
SERRSY
Definition serrsy.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
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
sspt01
subroutine sspt01(uplo, n, a, afac, ipiv, c, ldc, rwork, resid)
SSPT01
Definition sspt01.f:110
Here is the call graph for this function:
Here is the caller graph for this function: