LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ zchktr()

subroutine zchktr ( 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,
complex*16, dimension( * )  A,
complex*16, dimension( * )  AINV,
complex*16, dimension( * )  B,
complex*16, dimension( * )  X,
complex*16, dimension( * )  XACT,
complex*16, dimension( * )  WORK,
double precision, dimension( * )  RWORK,
integer  NOUT 
)

ZCHKTR

Purpose:
 ZCHKTR tests ZTRTRI, -TRS, -RFS, and -CON, and ZLATRS
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 COMPLEX*16 array, dimension (NMAX*NMAX)
[out]AINV
          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
[out]B
          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
          where NSMAX is the largest entry in NSVAL.
[out]X
          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
[out]XACT
          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
[out]WORK
          WORK is COMPLEX*16 array, dimension
                      (NMAX*max(3,NSMAX))
[out]RWORK
          RWORK is DOUBLE PRECISION 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 zchktr.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  DOUBLE PRECISION THRESH
172 * ..
173 * .. Array Arguments ..
174  LOGICAL DOTYPE( * )
175  INTEGER NBVAL( * ), NSVAL( * ), NVAL( * )
176  DOUBLE PRECISION RWORK( * )
177  COMPLEX*16 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  DOUBLE PRECISION ONE, ZERO
191  parameter( one = 1.0d0, zero = 0.0d0 )
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  DOUBLE PRECISION 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  DOUBLE PRECISION RESULT( NTESTS )
205 * ..
206 * .. External Functions ..
207  LOGICAL LSAME
208  DOUBLE PRECISION ZLANTR
209  EXTERNAL lsame, zlantr
210 * ..
211 * .. External Subroutines ..
212  EXTERNAL alaerh, alahd, alasum, xlaenv, zcopy, zerrtr,
213  $ zget04, zlacpy, zlarhs, zlatrs, zlattr, ztrcon,
214  $ ztrrfs, ztrt01, ztrt02, ztrt03, ztrt05, ztrt06,
215  $ ztrtri, ztrtrs
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 ) = 'Zomplex 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 zerrtr( 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 ZLATTR to generate a triangular test matrix.
274 *
275  srnamt = 'ZLATTR'
276  CALL zlattr( 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 zlacpy( uplo, n, n, a, lda, ainv, lda )
298  srnamt = 'ZTRTRI'
299  CALL ztrtri( uplo, diag, n, ainv, lda, info )
300 *
301 * Check error code from ZTRTRI.
302 *
303  IF( info.NE.0 )
304  $ CALL alaerh( path, 'ZTRTRI', 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 = zlantr( 'I', uplo, diag, n, n, a, lda, rwork )
311  ainvnm = zlantr( '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 ztrt01( 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 = 'ZLARHS'
362  CALL zlarhs( path, xtype, uplo, trans, n, n, 0,
363  $ idiag, nrhs, a, lda, xact, lda, b,
364  $ lda, iseed, info )
365  xtype = 'C'
366  CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
367 *
368  srnamt = 'ZTRTRS'
369  CALL ztrtrs( uplo, trans, diag, n, nrhs, a, lda,
370  $ x, lda, info )
371 *
372 * Check error code from ZTRTRS.
373 *
374  IF( info.NE.0 )
375  $ CALL alaerh( path, 'ZTRTRS', 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 ztrt02( 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 zget04( 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 = 'ZTRRFS'
400  CALL ztrrfs( 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 ZTRRFS.
406 *
407  IF( info.NE.0 )
408  $ CALL alaerh( path, 'ZTRRFS', info, 0,
409  $ uplo // trans // diag, n, n, -1,
410  $ -1, nrhs, imat, nfail, nerrs,
411  $ nout )
412 *
413  CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
414  $ result( 4 ) )
415  CALL ztrt05( 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 = 'ZTRCON'
447  CALL ztrcon( norm, uplo, diag, n, a, lda, rcond,
448  $ work, rwork, info )
449 *
450 * Check error code from ZTRCON.
451 *
452  IF( info.NE.0 )
453  $ CALL alaerh( path, 'ZTRCON', info, 0,
454  $ norm // uplo // diag, n, n, -1, -1,
455  $ -1, imat, nfail, nerrs, nout )
456 *
457  CALL ztrt06( 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 ZLATRS.
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 ZLATTR to generate a triangular test matrix.
496 *
497  srnamt = 'ZLATTR'
498  CALL zlattr( 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 = 'ZLATRS'
505  CALL zcopy( n, x, 1, b, 1 )
506  CALL zlatrs( uplo, trans, diag, 'N', n, a, lda, b,
507  $ scale, rwork, info )
508 *
509 * Check error code from ZLATRS.
510 *
511  IF( info.NE.0 )
512  $ CALL alaerh( path, 'ZLATRS', info, 0,
513  $ uplo // trans // diag // 'N', n, n,
514  $ -1, -1, -1, imat, nfail, nerrs, nout )
515 *
516  CALL ztrt03( 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 zcopy( n, x, 1, b( n+1 ), 1 )
524  CALL zlatrs( uplo, trans, diag, 'Y', n, a, lda,
525  $ b( n+1 ), scale, rwork, info )
526 *
527 * Check error code from ZLATRS.
528 *
529  IF( info.NE.0 )
530  $ CALL alaerh( path, 'ZLATRS', info, 0,
531  $ uplo // trans // diag // 'Y', n, n,
532  $ -1, -1, -1, imat, nfail, nerrs, nout )
533 *
534  CALL ztrt03( 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 )'ZLATRS', 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 )'ZLATRS', 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 ZCHKTR
578 *
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:53
alasum
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:73
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:81
alahd
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:147
zcopy
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
Definition: zcopy.f:81
zlarhs
subroutine zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
Definition: zlarhs.f:208
zget04
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
Definition: zget04.f:102
ztrt06
subroutine ztrt06(RCOND, RCONDC, UPLO, DIAG, N, A, LDA, RWORK, RAT)
ZTRT06
Definition: ztrt06.f:122
ztrt03
subroutine ztrt03(UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
ZTRT03
Definition: ztrt03.f:171
ztrt01
subroutine ztrt01(UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND, RWORK, RESID)
ZTRT01
Definition: ztrt01.f:125
ztrt05
subroutine ztrt05(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
ZTRT05
Definition: ztrt05.f:182
zlattr
subroutine zlattr(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, WORK, RWORK, INFO)
ZLATTR
Definition: zlattr.f:138
zerrtr
subroutine zerrtr(PATH, NUNIT)
ZERRTR
Definition: zerrtr.f:54
ztrt02
subroutine ztrt02(UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B, LDB, WORK, RWORK, RESID)
ZTRT02
Definition: ztrt02.f:155
zlantr
double precision function zlantr(NORM, UPLO, DIAG, M, N, A, LDA, WORK)
ZLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition: zlantr.f:142
zlacpy
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
Definition: zlacpy.f:103
zlatrs
subroutine zlatrs(UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO)
ZLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
Definition: zlatrs.f:239
ztrtrs
subroutine ztrtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
ZTRTRS
Definition: ztrtrs.f:140
ztrcon
subroutine ztrcon(NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, RWORK, INFO)
ZTRCON
Definition: ztrcon.f:137
ztrrfs
subroutine ztrrfs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZTRRFS
Definition: ztrrfs.f:182
ztrtri
subroutine ztrtri(UPLO, DIAG, N, A, LDA, INFO)
ZTRTRI
Definition: ztrtri.f:109
Here is the call graph for this function:
Here is the caller graph for this function: