LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine dchktr ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNB,
integer, dimension( * )  NBVAL,
integer  NNS,
integer, dimension( * )  NSVAL,
double precision  THRESH,
logical  TSTERR,
integer  NMAX,
double precision, dimension( * )  A,
double precision, dimension( * )  AINV,
double precision, dimension( * )  B,
double precision, dimension( * )  X,
double precision, dimension( * )  XACT,
double precision, dimension( * )  WORK,
double precision, dimension( * )  RWORK,
integer, dimension( * )  IWORK,
integer  NOUT 
)

DCHKTR

Purpose: 
 DCHKTR tests DTRTRI, -TRS, -RFS, and -CON, and DLATRS
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 DOUBLE PRECISION
          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 DOUBLE PRECISION array, dimension (NMAX*NMAX)
[out]AINV
          AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX)
[out]B
          B is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
          where NSMAX is the largest entry in NSVAL.
[out]X
          X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
[out]XACT
          XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
[out]WORK
          WORK is DOUBLE PRECISION array, dimension
                      (NMAX*max(3,NSMAX))
[out]RWORK
          RWORK is DOUBLE PRECISION array, dimension
                      (max(NMAX,2*NSMAX))
[out]IWORK
          IWORK is INTEGER array, dimension (NMAX)
[in]NOUT
          NOUT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
November 2011

Definition at line 169 of file dchktr.f.

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