LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ zchkpb()

subroutine zchkpb ( 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,
complex*16, dimension( * )  A,
complex*16, dimension( * )  AFAC,
complex*16, dimension( * )  AINV,
complex*16, dimension( * )  B,
complex*16, dimension( * )  X,
complex*16, dimension( * )  XACT,
complex*16, dimension( * )  WORK,
double precision, dimension( * )  RWORK,
integer  NOUT 
)

ZCHKPB

Purpose:
 ZCHKPB tests ZPBTRF, -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))
[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 165 of file zchkpb.f.

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