LAPACK  3.9.0
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 (NBVAL)
          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.
Date
December 2016

Definition at line 170 of file zchkpb.f.

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