LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ dchkpb()

subroutine dchkpb ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNB,
integer, dimension( * )  NBVAL,
integer  NNS,
integer, dimension( * )  NSVAL,
double precision  THRESH,
logical  TSTERR,
integer  NMAX,
double precision, dimension( * )  A,
double precision, dimension( * )  AFAC,
double precision, dimension( * )  AINV,
double precision, dimension( * )  B,
double precision, dimension( * )  X,
double precision, dimension( * )  XACT,
double precision, dimension( * )  WORK,
double precision, dimension( * )  RWORK,
integer, dimension( * )  IWORK,
integer  NOUT 
)

DCHKPB

Purpose:
 DCHKPB tests DPBTRF, -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 DOUBLE PRECISION
          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 DOUBLE PRECISION array, dimension (NMAX*NMAX)
[out]AFAC
          AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX)
[out]AINV
          AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX)
[out]B
          B is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
          where NSMAX is the largest entry in NSVAL.
[out]X
          X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
[out]XACT
          XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
[out]WORK
          WORK is DOUBLE PRECISION array, dimension
                      (NMAX*max(3,NSMAX))
[out]RWORK
          RWORK is DOUBLE PRECISION 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 dchkpb.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  DOUBLE PRECISION THRESH
181 * ..
182 * .. Array Arguments ..
183  LOGICAL DOTYPE( * )
184  INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
185  DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
186  $ RWORK( * ), WORK( * ), X( * ), XACT( * )
187 * ..
188 *
189 * =====================================================================
190 *
191 * .. Parameters ..
192  DOUBLE PRECISION ONE, ZERO
193  parameter( one = 1.0d+0, zero = 0.0d+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  DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC
208 * ..
209 * .. Local Arrays ..
210  INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW )
211  DOUBLE PRECISION RESULT( NTESTS )
212 * ..
213 * .. External Functions ..
214  DOUBLE PRECISION DGET06, DLANGE, DLANSB
215  EXTERNAL dget06, dlange, dlansb
216 * ..
217 * .. External Subroutines ..
218  EXTERNAL alaerh, alahd, alasum, dcopy, derrpo, dget04,
221  $ dswap, 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 ) = 'Double 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 derrpo( 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 DLATB4 and generate a test
315 * matrix with DLATMS.
316 *
317  CALL dlatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
318  $ MODE, CNDNUM, DIST )
319 *
320  srnamt = 'DLATMS'
321  CALL dlatms( 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 DLATMS.
326 *
327  IF( info.NE.0 ) THEN
328  CALL alaerh( path, 'DLATMS', 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 dcopy( izero-i1, work( iw ), 1,
342  $ a( ioff-izero+i1 ), 1 )
343  iw = iw + izero - i1
344  CALL dcopy( i2-izero+1, work( iw ), 1,
345  $ a( ioff ), max( ldab-1, 1 ) )
346  ELSE
347  ioff = ( i1-1 )*ldab + 1
348  CALL dcopy( 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 dcopy( 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 dswap( izero-i1, a( ioff-izero+i1 ), 1,
384  $ work( iw ), 1 )
385  iw = iw + izero - i1
386  CALL dswap( i2-izero+1, a( ioff ),
387  $ max( ldab-1, 1 ), work( iw ), 1 )
388  ELSE
389  ioff = ( i1-1 )*ldab + 1
390  CALL dswap( 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 dswap( 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 dlacpy( 'Full', kd+1, n, a, ldab, afac, ldab )
409  srnamt = 'DPBTRF'
410  CALL dpbtrf( uplo, n, kd, afac, ldab, info )
411 *
412 * Check error code from DPBTRF.
413 *
414  IF( info.NE.izero ) THEN
415  CALL alaerh( path, 'DPBTRF', 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 dlacpy( 'Full', kd+1, n, afac, ldab, ainv,
431  $ ldab )
432  CALL dpbt01( 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 dlaset( 'Full', n, n, zero, one, ainv, lda )
455  srnamt = 'DPBTRS'
456  CALL dpbtrs( uplo, n, kd, n, afac, ldab, ainv, lda,
457  $ info )
458 *
459 * Compute RCONDC = 1/(norm(A) * norm(inv(A))).
460 *
461  anorm = dlansb( '1', uplo, n, kd, a, ldab, rwork )
462  ainvnm = dlange( '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 = 'DLARHS'
476  CALL dlarhs( path, xtype, uplo, ' ', n, n, kd,
477  $ kd, nrhs, a, ldab, xact, lda, b,
478  $ lda, iseed, info )
479  CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
480 *
481  srnamt = 'DPBTRS'
482  CALL dpbtrs( uplo, n, kd, nrhs, afac, ldab, x,
483  $ lda, info )
484 *
485 * Check error code from DPBTRS.
486 *
487  IF( info.NE.0 )
488  $ CALL alaerh( path, 'DPBTRS', info, 0, uplo,
489  $ n, n, kd, kd, nrhs, imat, nfail,
490  $ nerrs, nout )
491 *
492  CALL dlacpy( 'Full', n, nrhs, b, lda, work,
493  $ lda )
494  CALL dpbt02( 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 dget04( 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 = 'DPBRFS'
507  CALL dpbrfs( 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 DPBRFS.
513 *
514  IF( info.NE.0 )
515  $ CALL alaerh( path, 'DPBRFS', info, 0, uplo,
516  $ n, n, kd, kd, nrhs, imat, nfail,
517  $ nerrs, nout )
518 *
519  CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
520  $ result( 4 ) )
521  CALL dpbt05( 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 = 'DPBCON'
544  CALL dpbcon( uplo, n, kd, afac, ldab, anorm, rcond,
545  $ work, iwork, info )
546 *
547 * Check error code from DPBCON.
548 *
549  IF( info.NE.0 )
550  $ CALL alaerh( path, 'DPBCON', info, 0, uplo, n,
551  $ n, kd, kd, -1, imat, nfail, nerrs,
552  $ nout )
553 *
554  result( 7 ) = dget06( 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 DCHKPB
585 *
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
Definition: dlacpy.f:103
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition: dlaset.f:110
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 dcopy(N, DX, INCX, DY, INCY)
DCOPY
Definition: dcopy.f:82
subroutine dswap(N, DX, INCX, DY, INCY)
DSWAP
Definition: dswap.f:82
subroutine dlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
DLARHS
Definition: dlarhs.f:205
subroutine dpbt05(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DPBT05
Definition: dpbt05.f:171
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
Definition: dget04.f:102
subroutine derrpo(PATH, NUNIT)
DERRPO
Definition: derrpo.f:55
subroutine dpbt01(UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, RESID)
DPBT01
Definition: dpbt01.f:119
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
Definition: dlatb4.f:120
subroutine dpbt02(UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
DPBT02
Definition: dpbt02.f:136
double precision function dget06(RCOND, RCONDC)
DGET06
Definition: dget06.f:55
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
Definition: dlatms.f:321
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: dlange.f:114
double precision function dlansb(NORM, UPLO, N, K, AB, LDAB, WORK)
DLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition: dlansb.f:129
subroutine dpbcon(UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO)
DPBCON
Definition: dpbcon.f:132
subroutine dpbrfs(UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DPBRFS
Definition: dpbrfs.f:189
subroutine dpbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
DPBTRS
Definition: dpbtrs.f:121
subroutine dpbtrf(UPLO, N, KD, AB, LDAB, INFO)
DPBTRF
Definition: dpbtrf.f:142
Here is the call graph for this function:
Here is the caller graph for this function: