LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cchkpb ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNB,
integer, dimension( * )  NBVAL,
integer  NNS,
integer, dimension( * )  NSVAL,
real  THRESH,
logical  TSTERR,
integer  NMAX,
complex, dimension( * )  A,
complex, dimension( * )  AFAC,
complex, dimension( * )  AINV,
complex, dimension( * )  B,
complex, dimension( * )  X,
complex, dimension( * )  XACT,
complex, dimension( * )  WORK,
real, dimension( * )  RWORK,
integer  NOUT 
)

CCHKPB

Purpose: 
 CCHKPB tests CPBTRF, -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 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))
[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
November 2011

Definition at line 170 of file cchkpb.f.

170 *
171 * -- LAPACK test routine (version 3.4.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 * November 2011
175 *
176 * .. Scalar Arguments ..
177  LOGICAL tsterr
178  INTEGER nmax, nn, nnb, nns, nout
179  REAL thresh
180 * ..
181 * .. Array Arguments ..
182  LOGICAL dotype( * )
183  INTEGER nbval( * ), nsval( * ), nval( * )
184  REAL rwork( * )
185  COMPLEX a( * ), afac( * ), ainv( * ), b( * ),
186  $ 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 clange, clanhb, sget06
215  EXTERNAL clange, clanhb, sget06
216 * ..
217 * .. External Subroutines ..
218  EXTERNAL alaerh, alahd, alasum, ccopy, cerrpo, cget04,
219  $ clacpy, claipd, clarhs, claset, clatb4, clatms,
220  $ cpbcon, cpbrfs, cpbt01, cpbt02, cpbt05, cpbtrf,
221  $ cpbtrs, cswap, xlaenv
222 * ..
223 * .. Intrinsic Functions ..
224  INTRINSIC cmplx, 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 ) = 'Complex 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 cerrpo( 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 CLATB4 and generate a test
314 * matrix with CLATMS.
315 *
316  CALL clatb4( path, imat, n, n, TYPE, kl, ku, anorm,
317  $ mode, cndnum, dist )
318 *
319  srnamt = 'CLATMS'
320  CALL clatms( 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 CLATMS.
325 *
326  IF( info.NE.0 ) THEN
327  CALL alaerh( path, 'CLATMS', 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 ccopy( izero-i1, work( iw ), 1,
341  $ a( ioff-izero+i1 ), 1 )
342  iw = iw + izero - i1
343  CALL ccopy( i2-izero+1, work( iw ), 1,
344  $ a( ioff ), max( ldab-1, 1 ) )
345  ELSE
346  ioff = ( i1-1 )*ldab + 1
347  CALL ccopy( 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 ccopy( 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 cswap( izero-i1, a( ioff-izero+i1 ), 1,
383  $ work( iw ), 1 )
384  iw = iw + izero - i1
385  CALL cswap( i2-izero+1, a( ioff ),
386  $ max( ldab-1, 1 ), work( iw ), 1 )
387  ELSE
388  ioff = ( i1-1 )*ldab + 1
389  CALL cswap( 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 cswap( 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 claipd( n, a( kd+1 ), ldab, 0 )
402  ELSE
403  CALL claipd( 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 clacpy( 'Full', kd+1, n, a, ldab, afac, ldab )
416  srnamt = 'CPBTRF'
417  CALL cpbtrf( uplo, n, kd, afac, ldab, info )
418 *
419 * Check error code from CPBTRF.
420 *
421  IF( info.NE.izero ) THEN
422  CALL alaerh( path, 'CPBTRF', 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 clacpy( 'Full', kd+1, n, afac, ldab, ainv,
438  $ ldab )
439  CALL cpbt01( 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 claset( 'Full', n, n, cmplx( zero ),
462  $ cmplx( one ), ainv, lda )
463  srnamt = 'CPBTRS'
464  CALL cpbtrs( uplo, n, kd, n, afac, ldab, ainv, lda,
465  $ info )
466 *
467 * Compute RCONDC = 1/(norm(A) * norm(inv(A))).
468 *
469  anorm = clanhb( '1', uplo, n, kd, a, ldab, rwork )
470  ainvnm = clange( '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 = 'CLARHS'
484  CALL clarhs( path, xtype, uplo, ' ', n, n, kd,
485  $ kd, nrhs, a, ldab, xact, lda, b,
486  $ lda, iseed, info )
487  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
488 *
489  srnamt = 'CPBTRS'
490  CALL cpbtrs( uplo, n, kd, nrhs, afac, ldab, x,
491  $ lda, info )
492 *
493 * Check error code from CPBTRS.
494 *
495  IF( info.NE.0 )
496  $ CALL alaerh( path, 'CPBTRS', info, 0, uplo,
497  $ n, n, kd, kd, nrhs, imat, nfail,
498  $ nerrs, nout )
499 *
500  CALL clacpy( 'Full', n, nrhs, b, lda, work,
501  $ lda )
502  CALL cpbt02( 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 cget04( 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 = 'CPBRFS'
515  CALL cpbrfs( 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 CPBRFS.
521 *
522  IF( info.NE.0 )
523  $ CALL alaerh( path, 'CPBRFS', info, 0, uplo,
524  $ n, n, kd, kd, nrhs, imat, nfail,
525  $ nerrs, nout )
526 *
527  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
528  $ result( 4 ) )
529  CALL cpbt05( 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 = 'CPBCON'
552  CALL cpbcon( uplo, n, kd, afac, ldab, anorm, rcond,
553  $ work, rwork, info )
554 *
555 * Check error code from CPBCON.
556 *
557  IF( info.NE.0 )
558  $ CALL alaerh( path, 'CPBCON', info, 0, uplo, n,
559  $ n, kd, kd, -1, imat, nfail, nerrs,
560  $ nout )
561 *
562  result( 7 ) = sget06( 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 CCHKPB
593 *
alahd
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:95
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
clarhs
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
Definition: clarhs.f:211
claipd
subroutine claipd(N, A, INDA, VINDA)
CLAIPD
Definition: claipd.f:85
cpbcon
subroutine cpbcon(UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, RWORK, INFO)
CPBCON
Definition: cpbcon.f:135
cpbt05
subroutine cpbt05(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPBT05
Definition: cpbt05.f:173
sget06
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:57
clange
real function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: clange.f:117
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
cpbrfs
subroutine cpbrfs(UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CPBRFS
Definition: cpbrfs.f:191
claset
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: claset.f:108
clatms
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:334
clanhb
real function clanhb(NORM, UPLO, N, K, AB, LDAB, WORK)
CLANHB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a Hermitian band matrix.
Definition: clanhb.f:134
cpbt01
subroutine cpbt01(UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, RESID)
CPBT01
Definition: cpbt01.f:122
clacpy
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:105
ccopy
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:52
cpbt02
subroutine cpbt02(UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CPBT02
Definition: cpbt02.f:138
cpbtrf
subroutine cpbtrf(UPLO, N, KD, AB, LDAB, INFO)
CPBTRF
Definition: cpbtrf.f:144
cswap
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
Definition: cswap.f:52
clatb4
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:123
cget04
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:104
cerrpo
subroutine cerrpo(PATH, NUNIT)
CERRPO
Definition: cerrpo.f:57
alasum
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:75
cpbtrs
subroutine cpbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
CPBTRS
Definition: cpbtrs.f:123

Here is the call graph for this function:

Here is the caller graph for this function: