LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ schkpb()

subroutine schkpb ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNB,
integer, dimension( * )  NBVAL,
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 
)

SCHKPB

Purpose:
 SCHKPB tests SPBTRF, -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]NNB
          NNB is INTEGER
          The number of values of NB contained in the vector NBVAL.
[in]NBVAL
          NBVAL is INTEGER array, dimension (NNB)
          The values of the blocksize NB.
[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)
[out]AFAC
          AFAC is REAL array, dimension (NMAX*NMAX)
[out]AINV
          AINV is REAL array, dimension (NMAX*NMAX)
[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 169 of file schkpb.f.

172 *
173 * -- LAPACK test routine --
174 * -- LAPACK is a software package provided by Univ. of Tennessee, --
175 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176 *
177 * .. Scalar Arguments ..
178  LOGICAL TSTERR
179  INTEGER NMAX, NN, NNB, NNS, NOUT
180  REAL THRESH
181 * ..
182 * .. Array Arguments ..
183  LOGICAL DOTYPE( * )
184  INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
185  REAL A( * ), AFAC( * ), AINV( * ), B( * ),
186  $ RWORK( * ), WORK( * ), X( * ), XACT( * )
187 * ..
188 *
189 * =====================================================================
190 *
191 * .. Parameters ..
192  REAL ONE, ZERO
193  parameter( one = 1.0e+0, zero = 0.0e+0 )
194  INTEGER NTYPES, NTESTS
195  parameter( ntypes = 8, ntests = 7 )
196  INTEGER NBW
197  parameter( nbw = 4 )
198 * ..
199 * .. Local Scalars ..
200  LOGICAL ZEROT
201  CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
202  CHARACTER*3 PATH
203  INTEGER I, I1, I2, IKD, IMAT, IN, INB, INFO, IOFF,
204  $ IRHS, IUPLO, IW, IZERO, K, KD, KL, KOFF, KU,
205  $ LDA, LDAB, MODE, N, NB, NERRS, NFAIL, NIMAT,
206  $ NKD, NRHS, NRUN
207  REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
208 * ..
209 * .. Local Arrays ..
210  INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW )
211  REAL RESULT( NTESTS )
212 * ..
213 * .. External Functions ..
214  REAL SGET06, SLANGE, SLANSB
215  EXTERNAL sget06, slange, slansb
216 * ..
217 * .. External Subroutines ..
218  EXTERNAL alaerh, alahd, alasum, scopy, serrpo, sget04,
221  $ sswap, xlaenv
222 * ..
223 * .. Intrinsic Functions ..
224  INTRINSIC max, min
225 * ..
226 * .. Scalars in Common ..
227  LOGICAL LERR, OK
228  CHARACTER*32 SRNAMT
229  INTEGER INFOT, NUNIT
230 * ..
231 * .. Common blocks ..
232  COMMON / infoc / infot, nunit, ok, lerr
233  COMMON / srnamc / srnamt
234 * ..
235 * .. Data statements ..
236  DATA iseedy / 1988, 1989, 1990, 1991 /
237 * ..
238 * .. Executable Statements ..
239 *
240 * Initialize constants and the random number seed.
241 *
242  path( 1: 1 ) = 'Single precision'
243  path( 2: 3 ) = 'PB'
244  nrun = 0
245  nfail = 0
246  nerrs = 0
247  DO 10 i = 1, 4
248  iseed( i ) = iseedy( i )
249  10 CONTINUE
250 *
251 * Test the error exits
252 *
253  IF( tsterr )
254  $ CALL serrpo( path, nout )
255  infot = 0
256  CALL xlaenv( 2, 2 )
257  kdval( 1 ) = 0
258 *
259 * Do for each value of N in NVAL
260 *
261  DO 90 in = 1, nn
262  n = nval( in )
263  lda = max( n, 1 )
264  xtype = 'N'
265 *
266 * Set limits on the number of loop iterations.
267 *
268  nkd = max( 1, min( n, 4 ) )
269  nimat = ntypes
270  IF( n.EQ.0 )
271  $ nimat = 1
272 *
273  kdval( 2 ) = n + ( n+1 ) / 4
274  kdval( 3 ) = ( 3*n-1 ) / 4
275  kdval( 4 ) = ( n+1 ) / 4
276 *
277  DO 80 ikd = 1, nkd
278 *
279 * Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order
280 * makes it easier to skip redundant values for small values
281 * of N.
282 *
283  kd = kdval( ikd )
284  ldab = kd + 1
285 *
286 * Do first for UPLO = 'U', then for UPLO = 'L'
287 *
288  DO 70 iuplo = 1, 2
289  koff = 1
290  IF( iuplo.EQ.1 ) THEN
291  uplo = 'U'
292  koff = max( 1, kd+2-n )
293  packit = 'Q'
294  ELSE
295  uplo = 'L'
296  packit = 'B'
297  END IF
298 *
299  DO 60 imat = 1, nimat
300 *
301 * Do the tests only if DOTYPE( IMAT ) is true.
302 *
303  IF( .NOT.dotype( imat ) )
304  $ GO TO 60
305 *
306 * Skip types 2, 3, or 4 if the matrix size is too small.
307 *
308  zerot = imat.GE.2 .AND. imat.LE.4
309  IF( zerot .AND. n.LT.imat-1 )
310  $ GO TO 60
311 *
312  IF( .NOT.zerot .OR. .NOT.dotype( 1 ) ) THEN
313 *
314 * Set up parameters with SLATB4 and generate a test
315 * matrix with SLATMS.
316 *
317  CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
318  $ MODE, CNDNUM, DIST )
319 *
320  srnamt = 'SLATMS'
321  CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
322  $ CNDNUM, ANORM, KD, KD, PACKIT,
323  $ A( KOFF ), LDAB, WORK, INFO )
324 *
325 * Check error code from SLATMS.
326 *
327  IF( info.NE.0 ) THEN
328  CALL alaerh( path, 'SLATMS', info, 0, uplo, n,
329  $ n, kd, kd, -1, imat, nfail, nerrs,
330  $ nout )
331  GO TO 60
332  END IF
333  ELSE IF( izero.GT.0 ) THEN
334 *
335 * Use the same matrix for types 3 and 4 as for type
336 * 2 by copying back the zeroed out column,
337 *
338  iw = 2*lda + 1
339  IF( iuplo.EQ.1 ) THEN
340  ioff = ( izero-1 )*ldab + kd + 1
341  CALL scopy( izero-i1, work( iw ), 1,
342  $ a( ioff-izero+i1 ), 1 )
343  iw = iw + izero - i1
344  CALL scopy( i2-izero+1, work( iw ), 1,
345  $ a( ioff ), max( ldab-1, 1 ) )
346  ELSE
347  ioff = ( i1-1 )*ldab + 1
348  CALL scopy( izero-i1, work( iw ), 1,
349  $ a( ioff+izero-i1 ),
350  $ max( ldab-1, 1 ) )
351  ioff = ( izero-1 )*ldab + 1
352  iw = iw + izero - i1
353  CALL scopy( i2-izero+1, work( iw ), 1,
354  $ a( ioff ), 1 )
355  END IF
356  END IF
357 *
358 * For types 2-4, zero one row and column of the matrix
359 * to test that INFO is returned correctly.
360 *
361  izero = 0
362  IF( zerot ) THEN
363  IF( imat.EQ.2 ) THEN
364  izero = 1
365  ELSE IF( imat.EQ.3 ) THEN
366  izero = n
367  ELSE
368  izero = n / 2 + 1
369  END IF
370 *
371 * Save the zeroed out row and column in WORK(*,3)
372 *
373  iw = 2*lda
374  DO 20 i = 1, min( 2*kd+1, n )
375  work( iw+i ) = zero
376  20 CONTINUE
377  iw = iw + 1
378  i1 = max( izero-kd, 1 )
379  i2 = min( izero+kd, n )
380 *
381  IF( iuplo.EQ.1 ) THEN
382  ioff = ( izero-1 )*ldab + kd + 1
383  CALL sswap( izero-i1, a( ioff-izero+i1 ), 1,
384  $ work( iw ), 1 )
385  iw = iw + izero - i1
386  CALL sswap( i2-izero+1, a( ioff ),
387  $ max( ldab-1, 1 ), work( iw ), 1 )
388  ELSE
389  ioff = ( i1-1 )*ldab + 1
390  CALL sswap( izero-i1, a( ioff+izero-i1 ),
391  $ max( ldab-1, 1 ), work( iw ), 1 )
392  ioff = ( izero-1 )*ldab + 1
393  iw = iw + izero - i1
394  CALL sswap( i2-izero+1, a( ioff ), 1,
395  $ work( iw ), 1 )
396  END IF
397  END IF
398 *
399 * Do for each value of NB in NBVAL
400 *
401  DO 50 inb = 1, nnb
402  nb = nbval( inb )
403  CALL xlaenv( 1, nb )
404 *
405 * Compute the L*L' or U'*U factorization of the band
406 * matrix.
407 *
408  CALL slacpy( 'Full', kd+1, n, a, ldab, afac, ldab )
409  srnamt = 'SPBTRF'
410  CALL spbtrf( uplo, n, kd, afac, ldab, info )
411 *
412 * Check error code from SPBTRF.
413 *
414  IF( info.NE.izero ) THEN
415  CALL alaerh( path, 'SPBTRF', info, izero, uplo,
416  $ n, n, kd, kd, nb, imat, nfail,
417  $ nerrs, nout )
418  GO TO 50
419  END IF
420 *
421 * Skip the tests if INFO is not 0.
422 *
423  IF( info.NE.0 )
424  $ GO TO 50
425 *
426 *+ TEST 1
427 * Reconstruct matrix from factors and compute
428 * residual.
429 *
430  CALL slacpy( 'Full', kd+1, n, afac, ldab, ainv,
431  $ ldab )
432  CALL spbt01( uplo, n, kd, a, ldab, ainv, ldab,
433  $ rwork, result( 1 ) )
434 *
435 * Print the test ratio if it is .GE. THRESH.
436 *
437  IF( result( 1 ).GE.thresh ) THEN
438  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
439  $ CALL alahd( nout, path )
440  WRITE( nout, fmt = 9999 )uplo, n, kd, nb, imat,
441  $ 1, result( 1 )
442  nfail = nfail + 1
443  END IF
444  nrun = nrun + 1
445 *
446 * Only do other tests if this is the first blocksize.
447 *
448  IF( inb.GT.1 )
449  $ GO TO 50
450 *
451 * Form the inverse of A so we can get a good estimate
452 * of RCONDC = 1/(norm(A) * norm(inv(A))).
453 *
454  CALL slaset( 'Full', n, n, zero, one, ainv, lda )
455  srnamt = 'SPBTRS'
456  CALL spbtrs( uplo, n, kd, n, afac, ldab, ainv, lda,
457  $ info )
458 *
459 * Compute RCONDC = 1/(norm(A) * norm(inv(A))).
460 *
461  anorm = slansb( '1', uplo, n, kd, a, ldab, rwork )
462  ainvnm = slange( '1', n, n, ainv, lda, rwork )
463  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
464  rcondc = one
465  ELSE
466  rcondc = ( one / anorm ) / ainvnm
467  END IF
468 *
469  DO 40 irhs = 1, nns
470  nrhs = nsval( irhs )
471 *
472 *+ TEST 2
473 * Solve and compute residual for A * X = B.
474 *
475  srnamt = 'SLARHS'
476  CALL slarhs( path, xtype, uplo, ' ', n, n, kd,
477  $ kd, nrhs, a, ldab, xact, lda, b,
478  $ lda, iseed, info )
479  CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
480 *
481  srnamt = 'SPBTRS'
482  CALL spbtrs( uplo, n, kd, nrhs, afac, ldab, x,
483  $ lda, info )
484 *
485 * Check error code from SPBTRS.
486 *
487  IF( info.NE.0 )
488  $ CALL alaerh( path, 'SPBTRS', info, 0, uplo,
489  $ n, n, kd, kd, nrhs, imat, nfail,
490  $ nerrs, nout )
491 *
492  CALL slacpy( 'Full', n, nrhs, b, lda, work,
493  $ lda )
494  CALL spbt02( uplo, n, kd, nrhs, a, ldab, x, lda,
495  $ work, lda, rwork, result( 2 ) )
496 *
497 *+ TEST 3
498 * Check solution from generated exact solution.
499 *
500  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
501  $ result( 3 ) )
502 *
503 *+ TESTS 4, 5, and 6
504 * Use iterative refinement to improve the solution.
505 *
506  srnamt = 'SPBRFS'
507  CALL spbrfs( uplo, n, kd, nrhs, a, ldab, afac,
508  $ ldab, b, lda, x, lda, rwork,
509  $ rwork( nrhs+1 ), work, iwork,
510  $ info )
511 *
512 * Check error code from SPBRFS.
513 *
514  IF( info.NE.0 )
515  $ CALL alaerh( path, 'SPBRFS', info, 0, uplo,
516  $ n, n, kd, kd, nrhs, imat, nfail,
517  $ nerrs, nout )
518 *
519  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
520  $ result( 4 ) )
521  CALL spbt05( uplo, n, kd, nrhs, a, ldab, b, lda,
522  $ x, lda, xact, lda, rwork,
523  $ rwork( nrhs+1 ), result( 5 ) )
524 *
525 * Print information about the tests that did not
526 * pass the threshold.
527 *
528  DO 30 k = 2, 6
529  IF( result( k ).GE.thresh ) THEN
530  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
531  $ CALL alahd( nout, path )
532  WRITE( nout, fmt = 9998 )uplo, n, kd,
533  $ nrhs, imat, k, result( k )
534  nfail = nfail + 1
535  END IF
536  30 CONTINUE
537  nrun = nrun + 5
538  40 CONTINUE
539 *
540 *+ TEST 7
541 * Get an estimate of RCOND = 1/CNDNUM.
542 *
543  srnamt = 'SPBCON'
544  CALL spbcon( uplo, n, kd, afac, ldab, anorm, rcond,
545  $ work, iwork, info )
546 *
547 * Check error code from SPBCON.
548 *
549  IF( info.NE.0 )
550  $ CALL alaerh( path, 'SPBCON', info, 0, uplo, n,
551  $ n, kd, kd, -1, imat, nfail, nerrs,
552  $ nout )
553 *
554  result( 7 ) = sget06( rcond, rcondc )
555 *
556 * Print the test ratio if it is .GE. THRESH.
557 *
558  IF( result( 7 ).GE.thresh ) THEN
559  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
560  $ CALL alahd( nout, path )
561  WRITE( nout, fmt = 9997 )uplo, n, kd, imat, 7,
562  $ result( 7 )
563  nfail = nfail + 1
564  END IF
565  nrun = nrun + 1
566  50 CONTINUE
567  60 CONTINUE
568  70 CONTINUE
569  80 CONTINUE
570  90 CONTINUE
571 *
572 * Print a summary of the results.
573 *
574  CALL alasum( path, nout, nfail, nrun, nerrs )
575 *
576  9999 FORMAT( ' UPLO=''', a1, ''', N=', i5, ', KD=', i5, ', NB=', i4,
577  $ ', type ', i2, ', test ', i2, ', ratio= ', g12.5 )
578  9998 FORMAT( ' UPLO=''', a1, ''', N=', i5, ', KD=', i5, ', NRHS=', i3,
579  $ ', type ', i2, ', test(', i2, ') = ', g12.5 )
580  9997 FORMAT( ' UPLO=''', a1, ''', N=', i5, ', KD=', i5, ',', 10x,
581  $ ' type ', i2, ', test(', i2, ') = ', g12.5 )
582  RETURN
583 *
584 * End of SCHKPB
585 *
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition: slaset.f:110
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 xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:81
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 slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: slange.f:114
real function slansb(NORM, UPLO, N, K, AB, LDAB, WORK)
SLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition: slansb.f:129
subroutine spbrfs(UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SPBRFS
Definition: spbrfs.f:189
subroutine spbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
SPBTRS
Definition: spbtrs.f:121
subroutine spbcon(UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO)
SPBCON
Definition: spbcon.f:132
subroutine spbtrf(UPLO, N, KD, AB, LDAB, INFO)
SPBTRF
Definition: spbtrf.f:142
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
Definition: sswap.f:82
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 spbt02(UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SPBT02
Definition: spbt02.f:136
subroutine spbt01(UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, RESID)
SPBT01
Definition: spbt01.f:119
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 sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
Definition: sget04.f:102
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:55
subroutine spbt05(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPBT05
Definition: spbt05.f:171
Here is the call graph for this function:
Here is the caller graph for this function: