LAPACK 3.11.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ cchkpb()

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 (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))
[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 cchkpb.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 REAL THRESH
177* ..
178* .. Array Arguments ..
179 LOGICAL DOTYPE( * )
180 INTEGER NBVAL( * ), NSVAL( * ), NVAL( * )
181 REAL RWORK( * )
182 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
183 $ WORK( * ), X( * ), XACT( * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 REAL ONE, ZERO
190 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
205* ..
206* .. Local Arrays ..
207 INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW )
208 REAL RESULT( NTESTS )
209* ..
210* .. External Functions ..
211 REAL CLANGE, CLANHB, SGET06
212 EXTERNAL clange, clanhb, sget06
213* ..
214* .. External Subroutines ..
215 EXTERNAL alaerh, alahd, alasum, ccopy, cerrpo, cget04,
219* ..
220* .. Intrinsic Functions ..
221 INTRINSIC cmplx, 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 ) = 'Complex 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 cerrpo( 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 CLATB4 and generate a test
311* matrix with CLATMS.
312*
313 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
314 $ MODE, CNDNUM, DIST )
315*
316 srnamt = 'CLATMS'
317 CALL clatms( 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 CLATMS.
322*
323 IF( info.NE.0 ) THEN
324 CALL alaerh( path, 'CLATMS', 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 ccopy( izero-i1, work( iw ), 1,
338 $ a( ioff-izero+i1 ), 1 )
339 iw = iw + izero - i1
340 CALL ccopy( i2-izero+1, work( iw ), 1,
341 $ a( ioff ), max( ldab-1, 1 ) )
342 ELSE
343 ioff = ( i1-1 )*ldab + 1
344 CALL ccopy( 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 ccopy( 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 cswap( izero-i1, a( ioff-izero+i1 ), 1,
380 $ work( iw ), 1 )
381 iw = iw + izero - i1
382 CALL cswap( i2-izero+1, a( ioff ),
383 $ max( ldab-1, 1 ), work( iw ), 1 )
384 ELSE
385 ioff = ( i1-1 )*ldab + 1
386 CALL cswap( 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 cswap( 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 claipd( n, a( kd+1 ), ldab, 0 )
399 ELSE
400 CALL claipd( 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 clacpy( 'Full', kd+1, n, a, ldab, afac, ldab )
413 srnamt = 'CPBTRF'
414 CALL cpbtrf( uplo, n, kd, afac, ldab, info )
415*
416* Check error code from CPBTRF.
417*
418 IF( info.NE.izero ) THEN
419 CALL alaerh( path, 'CPBTRF', 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 clacpy( 'Full', kd+1, n, afac, ldab, ainv,
435 $ ldab )
436 CALL cpbt01( 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 claset( 'Full', n, n, cmplx( zero ),
459 $ cmplx( one ), ainv, lda )
460 srnamt = 'CPBTRS'
461 CALL cpbtrs( uplo, n, kd, n, afac, ldab, ainv, lda,
462 $ info )
463*
464* Compute RCONDC = 1/(norm(A) * norm(inv(A))).
465*
466 anorm = clanhb( '1', uplo, n, kd, a, ldab, rwork )
467 ainvnm = clange( '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 = 'CLARHS'
481 CALL clarhs( path, xtype, uplo, ' ', n, n, kd,
482 $ kd, nrhs, a, ldab, xact, lda, b,
483 $ lda, iseed, info )
484 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
485*
486 srnamt = 'CPBTRS'
487 CALL cpbtrs( uplo, n, kd, nrhs, afac, ldab, x,
488 $ lda, info )
489*
490* Check error code from CPBTRS.
491*
492 IF( info.NE.0 )
493 $ CALL alaerh( path, 'CPBTRS', info, 0, uplo,
494 $ n, n, kd, kd, nrhs, imat, nfail,
495 $ nerrs, nout )
496*
497 CALL clacpy( 'Full', n, nrhs, b, lda, work,
498 $ lda )
499 CALL cpbt02( 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 cget04( 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 = 'CPBRFS'
512 CALL cpbrfs( 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 CPBRFS.
518*
519 IF( info.NE.0 )
520 $ CALL alaerh( path, 'CPBRFS', info, 0, uplo,
521 $ n, n, kd, kd, nrhs, imat, nfail,
522 $ nerrs, nout )
523*
524 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
525 $ result( 4 ) )
526 CALL cpbt05( 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 = 'CPBCON'
549 CALL cpbcon( uplo, n, kd, afac, ldab, anorm, rcond,
550 $ work, rwork, info )
551*
552* Check error code from CPBCON.
553*
554 IF( info.NE.0 )
555 $ CALL alaerh( path, 'CPBCON', info, 0, uplo, n,
556 $ n, kd, kd, -1, imat, nfail, nerrs,
557 $ nout )
558*
559 result( 7 ) = sget06( 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 CCHKPB
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 ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:81
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
Definition: cswap.f:81
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
Definition: clarhs.f:208
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:121
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:102
subroutine cpbt02(UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CPBT02
Definition: cpbt02.f:136
subroutine cerrpo(PATH, NUNIT)
CERRPO
Definition: cerrpo.f:55
subroutine cpbt01(UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, RESID)
CPBT01
Definition: cpbt01.f:120
subroutine claipd(N, A, INDA, VINDA)
CLAIPD
Definition: claipd.f:83
subroutine cpbt05(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPBT05
Definition: cpbt05.f:171
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:332
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:115
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:106
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,...
Definition: clanhb.f:132
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:103
subroutine cpbrfs(UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CPBRFS
Definition: cpbrfs.f:189
subroutine cpbcon(UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, RWORK, INFO)
CPBCON
Definition: cpbcon.f:133
subroutine cpbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
CPBTRS
Definition: cpbtrs.f:121
subroutine cpbtrf(UPLO, N, KD, AB, LDAB, INFO)
CPBTRF
Definition: cpbtrf.f:142
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:55
Here is the call graph for this function:
Here is the caller graph for this function: