LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ dchktr()

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.

Definition at line 164 of file dchktr.f.

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