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.```

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,
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 *
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 zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
Definition: zcopy.f:81
subroutine zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
Definition: zlarhs.f:208
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
Definition: zget04.f:102
subroutine ztrt06(RCOND, RCONDC, UPLO, DIAG, N, A, LDA, RWORK, RAT)
ZTRT06
Definition: ztrt06.f:122
subroutine ztrt03(UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
ZTRT03
Definition: ztrt03.f:171
subroutine ztrt01(UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND, RWORK, RESID)
ZTRT01
Definition: ztrt01.f:125
subroutine ztrt05(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
ZTRT05
Definition: ztrt05.f:182
subroutine zlattr(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, WORK, RWORK, INFO)
ZLATTR
Definition: zlattr.f:138
subroutine zerrtr(PATH, NUNIT)
ZERRTR
Definition: zerrtr.f:54
subroutine ztrt02(UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B, LDB, WORK, RWORK, RESID)
ZTRT02
Definition: ztrt02.f:155
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
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
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
subroutine ztrtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
ZTRTRS
Definition: ztrtrs.f:140
subroutine ztrcon(NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, RWORK, INFO)
ZTRCON
Definition: ztrcon.f:137
subroutine ztrrfs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZTRRFS
Definition: ztrrfs.f:182
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: