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

◆ cchktr()

subroutine cchktr ( 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( * ) ainv,
complex, dimension( * ) b,
complex, dimension( * ) x,
complex, dimension( * ) xact,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer nout )

CCHKTR

Purpose:
!>
!> CCHKTR tests CTRTRI, -TRS, -RFS, and -CON, and CLATRS(3)
!>
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 column 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 leading dimension of the work arrays.
!>          NMAX >= the maximum value of N in NVAL.
!>
[out]A
!>          A is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX 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 160 of file cchktr.f.

163*
164* -- LAPACK test routine --
165* -- LAPACK is a software package provided by Univ. of Tennessee, --
166* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
167*
168* .. Scalar Arguments ..
169 LOGICAL TSTERR
170 INTEGER NMAX, NN, NNB, NNS, NOUT
171 REAL THRESH
172* ..
173* .. Array Arguments ..
174 LOGICAL DOTYPE( * )
175 INTEGER NBVAL( * ), NSVAL( * ), NVAL( * )
176 REAL RWORK( * )
177 COMPLEX A( * ), AINV( * ), B( * ), WORK( * ), X( * ),
178 $ XACT( * )
179* ..
180*
181* =====================================================================
182*
183* .. Parameters ..
184 INTEGER NTYPE1, NTYPES
185 parameter( ntype1 = 10, ntypes = 18 )
186 INTEGER NTESTS
187 parameter( ntests = 10 )
188 INTEGER NTRAN
189 parameter( ntran = 3 )
190 REAL ONE, ZERO
191 parameter( one = 1.0e0, zero = 0.0e0 )
192* ..
193* .. Local Scalars ..
194 CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
195 CHARACTER*3 PATH
196 INTEGER I, IDIAG, IMAT, IN, INB, INFO, IRHS, ITRAN,
197 $ IUPLO, K, LDA, N, NB, NERRS, NFAIL, NRHS, NRUN
198 REAL AINVNM, ANORM, BIGNUM, DUMMY, RCOND, RCONDC,
199 $ RCONDI, RCONDO, RES, SCALE, SLAMCH
200* ..
201* .. Local Arrays ..
202 CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
203 INTEGER ISEED( 4 ), ISEEDY( 4 )
204 REAL RESULT( NTESTS ), RWORK2( 2*NMAX ),
205 $ SCALE3( 2 )
206* ..
207* .. External Functions ..
208 LOGICAL LSAME
209 REAL CLANTR
210 EXTERNAL lsame, clantr
211* ..
212* .. External Subroutines ..
213 EXTERNAL alaerh, alahd, alasum, ccopy, cerrtr, cget04,
214 $ clacpy, clarhs, clatrs, clatrs3, clattr,
215 $ csscal, ctrcon, ctrrfs, ctrt01, ctrt02, ctrt03,
216 $ ctrt05, ctrt06, ctrtri, ctrtrs, xlaenv, slamch
217* ..
218* .. Scalars in Common ..
219 LOGICAL LERR, OK
220 CHARACTER*32 SRNAMT
221 INTEGER INFOT, IOUNIT
222* ..
223* .. Common blocks ..
224 COMMON / infoc / infot, iounit, ok, lerr
225 COMMON / srnamc / srnamt
226* ..
227* .. Intrinsic Functions ..
228 INTRINSIC max
229* ..
230* .. Data statements ..
231 DATA iseedy / 1988, 1989, 1990, 1991 /
232 DATA uplos / 'U', 'L' / , transs / 'N', 'T', 'C' /
233* ..
234* .. Executable Statements ..
235*
236* Initialize constants and the random number seed.
237*
238 path( 1: 1 ) = 'Complex precision'
239 path( 2: 3 ) = 'TR'
240 bignum = slamch('Overflow') / slamch('Precision')
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 cerrtr( path, nout )
252 infot = 0
253*
254 DO 120 in = 1, nn
255*
256* Do for each value of N in NVAL
257*
258 n = nval( in )
259 lda = max( 1, n )
260 xtype = 'N'
261*
262 DO 80 imat = 1, ntype1
263*
264* Do the tests only if DOTYPE( IMAT ) is true.
265*
266 IF( .NOT.dotype( imat ) )
267 $ GO TO 80
268*
269 DO 70 iuplo = 1, 2
270*
271* Do first for UPLO = 'U', then for UPLO = 'L'
272*
273 uplo = uplos( iuplo )
274*
275* Call CLATTR to generate a triangular test matrix.
276*
277 srnamt = 'CLATTR'
278 CALL clattr( imat, uplo, 'No transpose', diag, iseed, n,
279 $ a, lda, x, work, rwork, info )
280*
281* Set IDIAG = 1 for non-unit matrices, 2 for unit.
282*
283 IF( lsame( diag, 'N' ) ) THEN
284 idiag = 1
285 ELSE
286 idiag = 2
287 END IF
288*
289 DO 60 inb = 1, nnb
290*
291* Do for each blocksize in NBVAL
292*
293 nb = nbval( inb )
294 CALL xlaenv( 1, nb )
295*
296*+ TEST 1
297* Form the inverse of A.
298*
299 CALL clacpy( uplo, n, n, a, lda, ainv, lda )
300 srnamt = 'CTRTRI'
301 CALL ctrtri( uplo, diag, n, ainv, lda, info )
302*
303* Check error code from CTRTRI.
304*
305 IF( info.NE.0 )
306 $ CALL alaerh( path, 'CTRTRI', info, 0, uplo // diag,
307 $ n, n, -1, -1, nb, imat, nfail, nerrs,
308 $ nout )
309*
310* Compute the infinity-norm condition number of A.
311*
312 anorm = clantr( 'I', uplo, diag, n, n, a, lda, rwork )
313 ainvnm = clantr( 'I', uplo, diag, n, n, ainv, lda,
314 $ rwork )
315 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
316 rcondi = one
317 ELSE
318 rcondi = ( one / anorm ) / ainvnm
319 END IF
320*
321* Compute the residual for the triangular matrix times
322* its inverse. Also compute the 1-norm condition number
323* of A.
324*
325 CALL ctrt01( uplo, diag, n, a, lda, ainv, lda, rcondo,
326 $ rwork, result( 1 ) )
327* Print the test ratio if it is .GE. THRESH.
328*
329 IF( result( 1 ).GE.thresh ) THEN
330 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
331 $ CALL alahd( nout, path )
332 WRITE( nout, fmt = 9999 )uplo, diag, n, nb, imat,
333 $ 1, result( 1 )
334 nfail = nfail + 1
335 END IF
336 nrun = nrun + 1
337*
338* Skip remaining tests if not the first block size.
339*
340 IF( inb.NE.1 )
341 $ GO TO 60
342*
343 DO 40 irhs = 1, nns
344 nrhs = nsval( irhs )
345 xtype = 'N'
346*
347 DO 30 itran = 1, ntran
348*
349* Do for op(A) = A, A**T, or A**H.
350*
351 trans = transs( itran )
352 IF( itran.EQ.1 ) THEN
353 norm = 'O'
354 rcondc = rcondo
355 ELSE
356 norm = 'I'
357 rcondc = rcondi
358 END IF
359*
360*+ TEST 2
361* Solve and compute residual for op(A)*x = b.
362*
363 srnamt = 'CLARHS'
364 CALL clarhs( path, xtype, uplo, trans, n, n, 0,
365 $ idiag, nrhs, a, lda, xact, lda, b,
366 $ lda, iseed, info )
367 xtype = 'C'
368 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
369*
370 srnamt = 'CTRTRS'
371 CALL ctrtrs( uplo, trans, diag, n, nrhs, a, lda,
372 $ x, lda, info )
373*
374* Check error code from CTRTRS.
375*
376 IF( info.NE.0 )
377 $ CALL alaerh( path, 'CTRTRS', info, 0,
378 $ uplo // trans // diag, n, n, -1,
379 $ -1, nrhs, imat, nfail, nerrs,
380 $ nout )
381*
382* This line is needed on a Sun SPARCstation.
383*
384 IF( n.GT.0 )
385 $ dummy = real( a( 1 ) )
386*
387 CALL ctrt02( uplo, trans, diag, n, nrhs, a, lda,
388 $ x, lda, b, lda, work, rwork,
389 $ result( 2 ) )
390*
391*+ TEST 3
392* Check solution from generated exact solution.
393*
394 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
395 $ result( 3 ) )
396*
397*+ TESTS 4, 5, and 6
398* Use iterative refinement to improve the solution
399* and compute error bounds.
400*
401 srnamt = 'CTRRFS'
402 CALL ctrrfs( uplo, trans, diag, n, nrhs, a, lda,
403 $ b, lda, x, lda, rwork,
404 $ rwork( nrhs+1 ), work,
405 $ rwork( 2*nrhs+1 ), info )
406*
407* Check error code from CTRRFS.
408*
409 IF( info.NE.0 )
410 $ CALL alaerh( path, 'CTRRFS', info, 0,
411 $ uplo // trans // diag, n, n, -1,
412 $ -1, nrhs, imat, nfail, nerrs,
413 $ nout )
414*
415 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
416 $ result( 4 ) )
417 CALL ctrt05( uplo, trans, diag, n, nrhs, a, lda,
418 $ b, lda, x, lda, xact, lda, rwork,
419 $ rwork( nrhs+1 ), result( 5 ) )
420*
421* Print information about the tests that did not
422* pass the threshold.
423*
424 DO 20 k = 2, 6
425 IF( result( k ).GE.thresh ) THEN
426 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
427 $ CALL alahd( nout, path )
428 WRITE( nout, fmt = 9998 )uplo, trans,
429 $ diag, n, nrhs, imat, k, result( k )
430 nfail = nfail + 1
431 END IF
432 20 CONTINUE
433 nrun = nrun + 5
434 30 CONTINUE
435 40 CONTINUE
436*
437*+ TEST 7
438* Get an estimate of RCOND = 1/CNDNUM.
439*
440 DO 50 itran = 1, 2
441 IF( itran.EQ.1 ) THEN
442 norm = 'O'
443 rcondc = rcondo
444 ELSE
445 norm = 'I'
446 rcondc = rcondi
447 END IF
448 srnamt = 'CTRCON'
449 CALL ctrcon( norm, uplo, diag, n, a, lda, rcond,
450 $ work, rwork, info )
451*
452* Check error code from CTRCON.
453*
454 IF( info.NE.0 )
455 $ CALL alaerh( path, 'CTRCON', info, 0,
456 $ norm // uplo // diag, n, n, -1, -1,
457 $ -1, imat, nfail, nerrs, nout )
458*
459 CALL ctrt06( rcond, rcondc, uplo, diag, n, a, lda,
460 $ rwork, result( 7 ) )
461*
462* Print the test ratio if it is .GE. THRESH.
463*
464 IF( result( 7 ).GE.thresh ) THEN
465 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
466 $ CALL alahd( nout, path )
467 WRITE( nout, fmt = 9997 )norm, uplo, n, imat,
468 $ 7, result( 7 )
469 nfail = nfail + 1
470 END IF
471 nrun = nrun + 1
472 50 CONTINUE
473 60 CONTINUE
474 70 CONTINUE
475 80 CONTINUE
476*
477* Use pathological test matrices to test CLATRS.
478*
479 DO 110 imat = ntype1 + 1, ntypes
480*
481* Do the tests only if DOTYPE( IMAT ) is true.
482*
483 IF( .NOT.dotype( imat ) )
484 $ GO TO 110
485*
486 DO 100 iuplo = 1, 2
487*
488* Do first for UPLO = 'U', then for UPLO = 'L'
489*
490 uplo = uplos( iuplo )
491 DO 90 itran = 1, ntran
492*
493* Do for op(A) = A, A**T, and A**H.
494*
495 trans = transs( itran )
496*
497* Call CLATTR to generate a triangular test matrix.
498*
499 srnamt = 'CLATTR'
500 CALL clattr( imat, uplo, trans, diag, iseed, n, a,
501 $ lda, x, work, rwork, info )
502*
503*+ TEST 8
504* Solve the system op(A)*x = b.
505*
506 srnamt = 'CLATRS'
507 CALL ccopy( n, x, 1, b, 1 )
508 CALL clatrs( uplo, trans, diag, 'N', n, a, lda, b,
509 $ scale, rwork, info )
510*
511* Check error code from CLATRS.
512*
513 IF( info.NE.0 )
514 $ CALL alaerh( path, 'CLATRS', info, 0,
515 $ uplo // trans // diag // 'N', n, n,
516 $ -1, -1, -1, imat, nfail, nerrs, nout )
517*
518 CALL ctrt03( uplo, trans, diag, n, 1, a, lda, scale,
519 $ rwork, one, b, lda, x, lda, work,
520 $ result( 8 ) )
521*
522*+ TEST 9
523* Solve op(A)*X = b again with NORMIN = 'Y'.
524*
525 CALL ccopy( n, x, 1, b( n+1 ), 1 )
526 CALL clatrs( uplo, trans, diag, 'Y', n, a, lda,
527 $ b( n+1 ), scale, rwork, info )
528*
529* Check error code from CLATRS.
530*
531 IF( info.NE.0 )
532 $ CALL alaerh( path, 'CLATRS', info, 0,
533 $ uplo // trans // diag // 'Y', n, n,
534 $ -1, -1, -1, imat, nfail, nerrs, nout )
535*
536 CALL ctrt03( uplo, trans, diag, n, 1, a, lda, scale,
537 $ rwork, one, b( n+1 ), lda, x, lda, work,
538 $ result( 9 ) )
539*
540*+ TEST 10
541* Solve op(A)*X = B.
542*
543 srnamt = 'CLATRS3'
544 CALL ccopy( n, x, 1, b, 1 )
545 CALL ccopy( n, x, 1, b( n+1 ), 1 )
546 CALL csscal( n, bignum, b( n+1 ), 1 )
547 CALL clatrs3( uplo, trans, diag, 'N', n, 2, a, lda,
548 $ b, max(1, n), scale3, rwork, rwork2,
549 $ 2*nmax, info )
550*
551* Check error code from CLATRS3.
552*
553 IF( info.NE.0 )
554 $ CALL alaerh( path, 'CLATRS3', info, 0,
555 $ uplo // trans // diag // 'N', n, n,
556 $ -1, -1, -1, imat, nfail, nerrs, nout )
557 CALL ctrt03( uplo, trans, diag, n, 1, a, lda,
558 $ scale3( 1 ), rwork, one, b( 1 ), lda,
559 $ x, lda, work, result( 10 ) )
560 CALL csscal( n, bignum, x, 1 )
561 CALL ctrt03( uplo, trans, diag, n, 1, a, lda,
562 $ scale3( 2 ), rwork, one, b( n+1 ), lda,
563 $ x, lda, work, res )
564 result( 10 ) = max( result( 10 ), res )
565*
566* Print information about the tests that did not pass
567* the threshold.
568*
569 IF( result( 8 ).GE.thresh ) THEN
570 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
571 $ CALL alahd( nout, path )
572 WRITE( nout, fmt = 9996 )'CLATRS', uplo, trans,
573 $ diag, 'N', n, imat, 8, result( 8 )
574 nfail = nfail + 1
575 END IF
576 IF( result( 9 ).GE.thresh ) THEN
577 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
578 $ CALL alahd( nout, path )
579 WRITE( nout, fmt = 9996 )'CLATRS', uplo, trans,
580 $ diag, 'Y', n, imat, 9, result( 9 )
581 nfail = nfail + 1
582 END IF
583 IF( result( 10 ).GE.thresh ) THEN
584 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
585 $ CALL alahd( nout, path )
586 WRITE( nout, fmt = 9996 )'CLATRS3', uplo, trans,
587 $ diag, 'N', n, imat, 10, result( 10 )
588 nfail = nfail + 1
589 END IF
590 nrun = nrun + 3
591 90 CONTINUE
592 100 CONTINUE
593 110 CONTINUE
594 120 CONTINUE
595*
596* Print a summary of the results.
597*
598 CALL alasum( path, nout, nfail, nrun, nerrs )
599*
600 9999 FORMAT( ' UPLO=''', a1, ''', DIAG=''', a1, ''', N=', i5, ', NB=',
601 $ i4, ', type ', i2, ', test(', i2, ')= ', g12.5 )
602 9998 FORMAT( ' UPLO=''', a1, ''', TRANS=''', a1, ''', DIAG=''', a1,
603 $ ''', N=', i5, ', NB=', i4, ', type ', i2, ',
604 $ test(', i2, ')= ', g12.5 )
605 9997 FORMAT( ' NORM=''', a1, ''', UPLO =''', a1, ''', N=', i5, ',',
606 $ 11x, ' type ', i2, ', test(', i2, ')=', g12.5 )
607 9996 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''', ''',
608 $ a1, ''',', i5, ', ... ), type ', i2, ', test(', i2, ')=',
609 $ g12.5 )
610 RETURN
611*
612* End of CCHKTR
613*
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
clarhs
subroutine clarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
CLARHS
Definition clarhs.f:208
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
alahd
subroutine alahd(iounit, path)
ALAHD
Definition alahd.f:107
cerrtr
subroutine cerrtr(path, nunit)
CERRTR
Definition cerrtr.f:54
cget04
subroutine cget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
CGET04
Definition cget04.f:102
clattr
subroutine clattr(imat, uplo, trans, diag, iseed, n, a, lda, b, work, rwork, info)
CLATTR
Definition clattr.f:138
ctrt01
subroutine ctrt01(uplo, diag, n, a, lda, ainv, ldainv, rcond, rwork, resid)
CTRT01
Definition ctrt01.f:125
ctrt02
subroutine ctrt02(uplo, trans, diag, n, nrhs, a, lda, x, ldx, b, ldb, work, rwork, resid)
CTRT02
Definition ctrt02.f:155
ctrt03
subroutine ctrt03(uplo, trans, diag, n, nrhs, a, lda, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
CTRT03
Definition ctrt03.f:171
ctrt05
subroutine ctrt05(uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CTRT05
Definition ctrt05.f:182
ctrt06
subroutine ctrt06(rcond, rcondc, uplo, diag, n, a, lda, rwork, rat)
CTRT06
Definition ctrt06.f:122
ccopy
subroutine ccopy(n, cx, incx, cy, incy)
CCOPY
Definition ccopy.f:81
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:101
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68
clantr
real function clantr(norm, uplo, diag, m, n, a, lda, work)
CLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clantr.f:141
clatrs3
subroutine clatrs3(uplo, trans, diag, normin, n, nrhs, a, lda, x, ldx, scale, cnorm, work, lwork, info)
CLATRS3 solves a triangular system of equations with the scale factors set to prevent overflow.
Definition clatrs3.f:235
clatrs
subroutine clatrs(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
CLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
Definition clatrs.f:238
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
csscal
subroutine csscal(n, sa, cx, incx)
CSSCAL
Definition csscal.f:78
ctrcon
subroutine ctrcon(norm, uplo, diag, n, a, lda, rcond, work, rwork, info)
CTRCON
Definition ctrcon.f:135
ctrrfs
subroutine ctrrfs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CTRRFS
Definition ctrrfs.f:181
ctrtri
subroutine ctrtri(uplo, diag, n, a, lda, info)
CTRTRI
Definition ctrtri.f:107
ctrtrs
subroutine ctrtrs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, info)
CTRTRS
Definition ctrtrs.f:144
Here is the call graph for this function:
Here is the caller graph for this function: