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.```

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,
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*
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
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 xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
subroutine alahd(iounit, path)
ALAHD
Definition alahd.f:107
subroutine cerrtr(path, nunit)
CERRTR
Definition cerrtr.f:54
subroutine cget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
CGET04
Definition cget04.f:102
subroutine clattr(imat, uplo, trans, diag, iseed, n, a, lda, b, work, rwork, info)
CLATTR
Definition clattr.f:138
subroutine ctrt01(uplo, diag, n, a, lda, ainv, ldainv, rcond, rwork, resid)
CTRT01
Definition ctrt01.f:125
subroutine ctrt02(uplo, trans, diag, n, nrhs, a, lda, x, ldx, b, ldb, work, rwork, resid)
CTRT02
Definition ctrt02.f:155
subroutine ctrt03(uplo, trans, diag, n, nrhs, a, lda, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
CTRT03
Definition ctrt03.f:171
subroutine ctrt05(uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CTRT05
Definition ctrt05.f:182
subroutine ctrt06(rcond, rcondc, uplo, diag, n, a, lda, rwork, rat)
CTRT06
Definition ctrt06.f:122
subroutine ccopy(n, cx, incx, cy, incy)
CCOPY
Definition ccopy.f:81
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
real function slamch(cmach)
SLAMCH
Definition slamch.f:68
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
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
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
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
subroutine csscal(n, sa, cx, incx)
CSSCAL
Definition csscal.f:78
subroutine ctrcon(norm, uplo, diag, n, a, lda, rcond, work, rwork, info)
CTRCON
Definition ctrcon.f:137
subroutine ctrrfs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CTRRFS
Definition ctrrfs.f:182
subroutine ctrtri(uplo, diag, n, a, lda, info)
CTRTRI
Definition ctrtri.f:109
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: