LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ 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 *
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
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:53
alasum
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:73
alahd
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:147
slatms
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:321
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
ssptrf
subroutine ssptrf(UPLO, N, AP, IPIV, INFO)
SSPTRF
Definition: ssptrf.f:157
sspcon
subroutine sspcon(UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
SSPCON
Definition: sspcon.f:125
ssptrs
subroutine ssptrs(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
SSPTRS
Definition: ssptrs.f:115
ssptri
subroutine ssptri(UPLO, N, AP, IPIV, WORK, INFO)
SSPTRI
Definition: ssptri.f:109
ssprfs
subroutine ssprfs(UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SSPRFS
Definition: ssprfs.f:179
scopy
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:82
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
slatb4
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
Definition: slatb4.f:120
serrsy
subroutine serrsy(PATH, NUNIT)
SERRSY
Definition: serrsy.f:55
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
sppt02
subroutine sppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
SPPT02
Definition: sppt02.f:122
sget04
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
Definition: sget04.f:102
sppt03
subroutine sppt03(UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, RESID)
SPPT03
Definition: sppt03.f:110
sget06
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: