LAPACK 3.12.0
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:103
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:142
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:230
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:239
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:137
ctrrfs
subroutine ctrrfs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CTRRFS
Definition ctrrfs.f:182
ctrtri
subroutine ctrtri(uplo, diag, n, a, lda, info)
CTRTRI
Definition ctrtri.f:109
ctrtrs
subroutine ctrtrs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, info)
CTRTRS
Definition ctrtrs.f:140
Here is the call graph for this function:
Here is the caller graph for this function: