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