LAPACK  3.8.0 LAPACK: Linear Algebra PACKage

## ◆ 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`
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.```
Date
December 2016

Definition at line 165 of file cchktr.f.

165 *
166 * -- LAPACK test routine (version 3.7.0) --
167 * -- LAPACK is a software package provided by Univ. of Tennessee, --
168 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
169 * December 2016
170 *
171 * .. Scalar Arguments ..
172  LOGICAL tsterr
173  INTEGER nmax, nn, nnb, nns, nout
174  REAL thresh
175 * ..
176 * .. Array Arguments ..
177  LOGICAL dotype( * )
178  INTEGER nbval( * ), nsval( * ), nval( * )
179  REAL rwork( * )
180  COMPLEX a( * ), ainv( * ), b( * ), work( * ), x( * ),
181  \$ xact( * )
182 * ..
183 *
184 * =====================================================================
185 *
186 * .. Parameters ..
187  INTEGER ntype1, ntypes
188  parameter( ntype1 = 10, ntypes = 18 )
189  INTEGER ntests
190  parameter( ntests = 9 )
191  INTEGER ntran
192  parameter( ntran = 3 )
193  REAL one, zero
194  parameter( one = 1.0e0, zero = 0.0e0 )
195 * ..
196 * .. Local Scalars ..
197  CHARACTER diag, norm, trans, uplo, xtype
198  CHARACTER*3 path
199  INTEGER i, idiag, imat, in, inb, info, irhs, itran,
200  \$ iuplo, k, lda, n, nb, nerrs, nfail, nrhs, nrun
201  REAL ainvnm, anorm, dummy, rcond, rcondc, rcondi,
202  \$ rcondo, scale
203 * ..
204 * .. Local Arrays ..
205  CHARACTER transs( ntran ), uplos( 2 )
206  INTEGER iseed( 4 ), iseedy( 4 )
207  REAL result( ntests )
208 * ..
209 * .. External Functions ..
210  LOGICAL lsame
211  REAL clantr
212  EXTERNAL lsame, clantr
213 * ..
214 * .. External Subroutines ..
215  EXTERNAL alaerh, alahd, alasum, ccopy, cerrtr, cget04,
218  \$ ctrtrs, xlaenv
219 * ..
220 * .. Scalars in Common ..
221  LOGICAL lerr, ok
222  CHARACTER*32 srnamt
223  INTEGER infot, iounit
224 * ..
225 * .. Common blocks ..
226  COMMON / infoc / infot, iounit, ok, lerr
227  COMMON / srnamc / srnamt
228 * ..
229 * .. Intrinsic Functions ..
230  INTRINSIC max
231 * ..
232 * .. Data statements ..
233  DATA iseedy / 1988, 1989, 1990, 1991 /
234  DATA uplos / 'U', 'L' / , transs / 'N', 'T', 'C' /
235 * ..
236 * .. Executable Statements ..
237 *
238 * Initialize constants and the random number seed.
239 *
240  path( 1: 1 ) = 'Complex precision'
241  path( 2: 3 ) = 'TR'
242  nrun = 0
243  nfail = 0
244  nerrs = 0
245  DO 10 i = 1, 4
246  iseed( i ) = iseedy( i )
247  10 CONTINUE
248 *
249 * Test the error exits
250 *
251  IF( tsterr )
252  \$ CALL cerrtr( path, nout )
253  infot = 0
254 *
255  DO 120 in = 1, nn
256 *
257 * Do for each value of N in NVAL
258 *
259  n = nval( in )
260  lda = max( 1, n )
261  xtype = 'N'
262 *
263  DO 80 imat = 1, ntype1
264 *
265 * Do the tests only if DOTYPE( IMAT ) is true.
266 *
267  IF( .NOT.dotype( imat ) )
268  \$ GO TO 80
269 *
270  DO 70 iuplo = 1, 2
271 *
272 * Do first for UPLO = 'U', then for UPLO = 'L'
273 *
274  uplo = uplos( iuplo )
275 *
276 * Call CLATTR to generate a triangular test matrix.
277 *
278  srnamt = 'CLATTR'
279  CALL clattr( imat, uplo, 'No transpose', diag, iseed, n,
280  \$ a, lda, x, work, rwork, info )
281 *
282 * Set IDIAG = 1 for non-unit matrices, 2 for unit.
283 *
284  IF( lsame( diag, 'N' ) ) THEN
285  idiag = 1
286  ELSE
287  idiag = 2
288  END IF
289 *
290  DO 60 inb = 1, nnb
291 *
292 * Do for each blocksize in NBVAL
293 *
294  nb = nbval( inb )
295  CALL xlaenv( 1, nb )
296 *
297 *+ TEST 1
298 * Form the inverse of A.
299 *
300  CALL clacpy( uplo, n, n, a, lda, ainv, lda )
301  srnamt = 'CTRTRI'
302  CALL ctrtri( uplo, diag, n, ainv, lda, info )
303 *
304 * Check error code from CTRTRI.
305 *
306  IF( info.NE.0 )
307  \$ CALL alaerh( path, 'CTRTRI', info, 0, uplo // diag,
308  \$ n, n, -1, -1, nb, imat, nfail, nerrs,
309  \$ nout )
310 *
311 * Compute the infinity-norm condition number of A.
312 *
313  anorm = clantr( 'I', uplo, diag, n, n, a, lda, rwork )
314  ainvnm = clantr( 'I', uplo, diag, n, n, ainv, lda,
315  \$ rwork )
316  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
317  rcondi = one
318  ELSE
319  rcondi = ( one / anorm ) / ainvnm
320  END IF
321 *
322 * Compute the residual for the triangular matrix times
323 * its inverse. Also compute the 1-norm condition number
324 * of A.
325 *
326  CALL ctrt01( uplo, diag, n, a, lda, ainv, lda, rcondo,
327  \$ rwork, result( 1 ) )
328 * Print the test ratio if it is .GE. THRESH.
329 *
330  IF( result( 1 ).GE.thresh ) THEN
331  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
332  \$ CALL alahd( nout, path )
333  WRITE( nout, fmt = 9999 )uplo, diag, n, nb, imat,
334  \$ 1, result( 1 )
335  nfail = nfail + 1
336  END IF
337  nrun = nrun + 1
338 *
339 * Skip remaining tests if not the first block size.
340 *
341  IF( inb.NE.1 )
342  \$ GO TO 60
343 *
344  DO 40 irhs = 1, nns
345  nrhs = nsval( irhs )
346  xtype = 'N'
347 *
348  DO 30 itran = 1, ntran
349 *
350 * Do for op(A) = A, A**T, or A**H.
351 *
352  trans = transs( itran )
353  IF( itran.EQ.1 ) THEN
354  norm = 'O'
355  rcondc = rcondo
356  ELSE
357  norm = 'I'
358  rcondc = rcondi
359  END IF
360 *
361 *+ TEST 2
362 * Solve and compute residual for op(A)*x = b.
363 *
364  srnamt = 'CLARHS'
365  CALL clarhs( path, xtype, uplo, trans, n, n, 0,
366  \$ idiag, nrhs, a, lda, xact, lda, b,
367  \$ lda, iseed, info )
368  xtype = 'C'
369  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
370 *
371  srnamt = 'CTRTRS'
372  CALL ctrtrs( uplo, trans, diag, n, nrhs, a, lda,
373  \$ x, lda, info )
374 *
375 * Check error code from CTRTRS.
376 *
377  IF( info.NE.0 )
378  \$ CALL alaerh( path, 'CTRTRS', info, 0,
379  \$ uplo // trans // diag, n, n, -1,
380  \$ -1, nrhs, imat, nfail, nerrs,
381  \$ nout )
382 *
383 * This line is needed on a Sun SPARCstation.
384 *
385  IF( n.GT.0 )
386  \$ dummy = a( 1 )
387 *
388  CALL ctrt02( uplo, trans, diag, n, nrhs, a, lda,
389  \$ x, lda, b, lda, work, rwork,
390  \$ result( 2 ) )
391 *
392 *+ TEST 3
393 * Check solution from generated exact solution.
394 *
395  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
396  \$ result( 3 ) )
397 *
398 *+ TESTS 4, 5, and 6
399 * Use iterative refinement to improve the solution
400 * and compute error bounds.
401 *
402  srnamt = 'CTRRFS'
403  CALL ctrrfs( uplo, trans, diag, n, nrhs, a, lda,
404  \$ b, lda, x, lda, rwork,
405  \$ rwork( nrhs+1 ), work,
406  \$ rwork( 2*nrhs+1 ), info )
407 *
408 * Check error code from CTRRFS.
409 *
410  IF( info.NE.0 )
411  \$ CALL alaerh( path, 'CTRRFS', info, 0,
412  \$ uplo // trans // diag, n, n, -1,
413  \$ -1, nrhs, imat, nfail, nerrs,
414  \$ nout )
415 *
416  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
417  \$ result( 4 ) )
418  CALL ctrt05( uplo, trans, diag, n, nrhs, a, lda,
419  \$ b, lda, x, lda, xact, lda, rwork,
420  \$ rwork( nrhs+1 ), result( 5 ) )
421 *
422 * Print information about the tests that did not
423 * pass the threshold.
424 *
425  DO 20 k = 2, 6
426  IF( result( k ).GE.thresh ) THEN
427  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
428  \$ CALL alahd( nout, path )
429  WRITE( nout, fmt = 9998 )uplo, trans,
430  \$ diag, n, nrhs, imat, k, result( k )
431  nfail = nfail + 1
432  END IF
433  20 CONTINUE
434  nrun = nrun + 5
435  30 CONTINUE
436  40 CONTINUE
437 *
438 *+ TEST 7
439 * Get an estimate of RCOND = 1/CNDNUM.
440 *
441  DO 50 itran = 1, 2
442  IF( itran.EQ.1 ) THEN
443  norm = 'O'
444  rcondc = rcondo
445  ELSE
446  norm = 'I'
447  rcondc = rcondi
448  END IF
449  srnamt = 'CTRCON'
450  CALL ctrcon( norm, uplo, diag, n, a, lda, rcond,
451  \$ work, rwork, info )
452 *
453 * Check error code from CTRCON.
454 *
455  IF( info.NE.0 )
456  \$ CALL alaerh( path, 'CTRCON', info, 0,
457  \$ norm // uplo // diag, n, n, -1, -1,
458  \$ -1, imat, nfail, nerrs, nout )
459 *
460  CALL ctrt06( rcond, rcondc, uplo, diag, n, a, lda,
461  \$ rwork, result( 7 ) )
462 *
463 * Print the test ratio if it is .GE. THRESH.
464 *
465  IF( result( 7 ).GE.thresh ) THEN
466  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
467  \$ CALL alahd( nout, path )
468  WRITE( nout, fmt = 9997 )norm, uplo, n, imat,
469  \$ 7, result( 7 )
470  nfail = nfail + 1
471  END IF
472  nrun = nrun + 1
473  50 CONTINUE
474  60 CONTINUE
475  70 CONTINUE
476  80 CONTINUE
477 *
478 * Use pathological test matrices to test CLATRS.
479 *
480  DO 110 imat = ntype1 + 1, ntypes
481 *
482 * Do the tests only if DOTYPE( IMAT ) is true.
483 *
484  IF( .NOT.dotype( imat ) )
485  \$ GO TO 110
486 *
487  DO 100 iuplo = 1, 2
488 *
489 * Do first for UPLO = 'U', then for UPLO = 'L'
490 *
491  uplo = uplos( iuplo )
492  DO 90 itran = 1, ntran
493 *
494 * Do for op(A) = A, A**T, and A**H.
495 *
496  trans = transs( itran )
497 *
498 * Call CLATTR to generate a triangular test matrix.
499 *
500  srnamt = 'CLATTR'
501  CALL clattr( imat, uplo, trans, diag, iseed, n, a,
502  \$ lda, x, work, rwork, info )
503 *
504 *+ TEST 8
505 * Solve the system op(A)*x = b.
506 *
507  srnamt = 'CLATRS'
508  CALL ccopy( n, x, 1, b, 1 )
509  CALL clatrs( uplo, trans, diag, 'N', n, a, lda, b,
510  \$ scale, rwork, info )
511 *
512 * Check error code from CLATRS.
513 *
514  IF( info.NE.0 )
515  \$ CALL alaerh( path, 'CLATRS', info, 0,
516  \$ uplo // trans // diag // 'N', n, n,
517  \$ -1, -1, -1, imat, nfail, nerrs, nout )
518 *
519  CALL ctrt03( uplo, trans, diag, n, 1, a, lda, scale,
520  \$ rwork, one, b, lda, x, lda, work,
521  \$ result( 8 ) )
522 *
523 *+ TEST 9
524 * Solve op(A)*X = b again with NORMIN = 'Y'.
525 *
526  CALL ccopy( n, x, 1, b( n+1 ), 1 )
527  CALL clatrs( uplo, trans, diag, 'Y', n, a, lda,
528  \$ b( n+1 ), scale, rwork, info )
529 *
530 * Check error code from CLATRS.
531 *
532  IF( info.NE.0 )
533  \$ CALL alaerh( path, 'CLATRS', info, 0,
534  \$ uplo // trans // diag // 'Y', n, n,
535  \$ -1, -1, -1, imat, nfail, nerrs, nout )
536 *
537  CALL ctrt03( uplo, trans, diag, n, 1, a, lda, scale,
538  \$ rwork, one, b( n+1 ), lda, x, lda, work,
539  \$ result( 9 ) )
540 *
541 * Print information about the tests that did not pass
542 * the threshold.
543 *
544  IF( result( 8 ).GE.thresh ) THEN
545  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
546  \$ CALL alahd( nout, path )
547  WRITE( nout, fmt = 9996 )'CLATRS', uplo, trans,
548  \$ diag, 'N', n, imat, 8, result( 8 )
549  nfail = nfail + 1
550  END IF
551  IF( result( 9 ).GE.thresh ) THEN
552  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
553  \$ CALL alahd( nout, path )
554  WRITE( nout, fmt = 9996 )'CLATRS', uplo, trans,
555  \$ diag, 'Y', n, imat, 9, result( 9 )
556  nfail = nfail + 1
557  END IF
558  nrun = nrun + 2
559  90 CONTINUE
560  100 CONTINUE
561  110 CONTINUE
562  120 CONTINUE
563 *
564 * Print a summary of the results.
565 *
566  CALL alasum( path, nout, nfail, nrun, nerrs )
567 *
568  9999 FORMAT( ' UPLO=''', a1, ''', DIAG=''', a1, ''', N=', i5, ', NB=',
569  \$ i4, ', type ', i2, ', test(', i2, ')= ', g12.5 )
570  9998 FORMAT( ' UPLO=''', a1, ''', TRANS=''', a1, ''', DIAG=''', a1,
571  \$ ''', N=', i5, ', NB=', i4, ', type ', i2, ',
572  \$ test(', i2, ')= ', g12.5 )
573  9997 FORMAT( ' NORM=''', a1, ''', UPLO =''', a1, ''', N=', i5, ',',
574  \$ 11x, ' type ', i2, ', test(', i2, ')=', g12.5 )
575  9996 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''', ''',
576  \$ a1, ''',', i5, ', ... ), type ', i2, ', test(', i2, ')=',
577  \$ g12.5 )
578  RETURN
579 *
580 * End of CCHKTR
581 *
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
subroutine ctrt06(RCOND, RCONDC, UPLO, DIAG, N, A, LDA, RWORK, RAT)
CTRT06
Definition: ctrt06.f:124
subroutine ctrt01(UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND, RWORK, RESID)
CTRT01
Definition: ctrt01.f:127
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
subroutine ctrcon(NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, RWORK, INFO)
CTRCON
Definition: ctrcon.f:139
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, or the element of largest absolute value of a trapezoidal or triangular matrix.
Definition: clantr.f:144
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:241
subroutine ctrrfs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CTRRFS
Definition: ctrrfs.f:184
subroutine ctrt05(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CTRT05
Definition: ctrt05.f:184
subroutine cerrtr(PATH, NUNIT)
CERRTR
Definition: cerrtr.f:56
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
subroutine ctrt02(UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B, LDB, WORK, RWORK, RESID)
CTRT02
Definition: ctrt02.f:159
subroutine ctrtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
CTRTRS
Definition: ctrtrs.f:142
subroutine ctrt03(UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
CTRT03
Definition: ctrt03.f:173
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
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
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:83
subroutine clattr(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, WORK, RWORK, INFO)
CLATTR
Definition: clattr.f:140
subroutine ctrtri(UPLO, DIAG, N, A, LDA, INFO)
CTRTRI
Definition: ctrtri.f:111
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
Definition: clarhs.f:211
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:104
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:75
Here is the call graph for this function:
Here is the caller graph for this function: