LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
cchktr.f
Go to the documentation of this file.
1 *> \brief \b CCHKTR
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE CCHKTR( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
12 * THRESH, TSTERR, NMAX, A, AINV, B, X, XACT,
13 * WORK, RWORK, NOUT )
14 *
15 * .. Scalar Arguments ..
16 * LOGICAL TSTERR
17 * INTEGER NMAX, NN, NNB, NNS, NOUT
18 * REAL THRESH
19 * ..
20 * .. Array Arguments ..
21 * LOGICAL DOTYPE( * )
22 * INTEGER NBVAL( * ), NSVAL( * ), NVAL( * )
23 * REAL RWORK( * )
24 * COMPLEX A( * ), AINV( * ), B( * ), WORK( * ), X( * ),
25 * $ XACT( * )
26 * ..
27 *
28 *
29 *> \par Purpose:
30 * =============
31 *>
32 *> \verbatim
33 *>
34 *> CCHKTR tests CTRTRI, -TRS, -RFS, and -CON, and CLATRS
35 *> \endverbatim
36 *
37 * Arguments:
38 * ==========
39 *
40 *> \param[in] DOTYPE
41 *> \verbatim
42 *> DOTYPE is LOGICAL array, dimension (NTYPES)
43 *> The matrix types to be used for testing. Matrices of type j
44 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
45 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
46 *> \endverbatim
47 *>
48 *> \param[in] NN
49 *> \verbatim
50 *> NN is INTEGER
51 *> The number of values of N contained in the vector NVAL.
52 *> \endverbatim
53 *>
54 *> \param[in] NVAL
55 *> \verbatim
56 *> NVAL is INTEGER array, dimension (NN)
57 *> The values of the matrix column dimension N.
58 *> \endverbatim
59 *>
60 *> \param[in] NNB
61 *> \verbatim
62 *> NNB is INTEGER
63 *> The number of values of NB contained in the vector NBVAL.
64 *> \endverbatim
65 *>
66 *> \param[in] NBVAL
67 *> \verbatim
68 *> NBVAL is INTEGER array, dimension (NNB)
69 *> The values of the blocksize NB.
70 *> \endverbatim
71 *>
72 *> \param[in] NNS
73 *> \verbatim
74 *> NNS is INTEGER
75 *> The number of values of NRHS contained in the vector NSVAL.
76 *> \endverbatim
77 *>
78 *> \param[in] NSVAL
79 *> \verbatim
80 *> NSVAL is INTEGER array, dimension (NNS)
81 *> The values of the number of right hand sides NRHS.
82 *> \endverbatim
83 *>
84 *> \param[in] THRESH
85 *> \verbatim
86 *> THRESH is REAL
87 *> The threshold value for the test ratios. A result is
88 *> included in the output file if RESULT >= THRESH. To have
89 *> every test ratio printed, use THRESH = 0.
90 *> \endverbatim
91 *>
92 *> \param[in] TSTERR
93 *> \verbatim
94 *> TSTERR is LOGICAL
95 *> Flag that indicates whether error exits are to be tested.
96 *> \endverbatim
97 *>
98 *> \param[in] NMAX
99 *> \verbatim
100 *> NMAX is INTEGER
101 *> The leading dimension of the work arrays.
102 *> NMAX >= the maximum value of N in NVAL.
103 *> \endverbatim
104 *>
105 *> \param[out] A
106 *> \verbatim
107 *> A is COMPLEX array, dimension (NMAX*NMAX)
108 *> \endverbatim
109 *>
110 *> \param[out] AINV
111 *> \verbatim
112 *> AINV is COMPLEX array, dimension (NMAX*NMAX)
113 *> \endverbatim
114 *>
115 *> \param[out] B
116 *> \verbatim
117 *> B is COMPLEX array, dimension (NMAX*NSMAX)
118 *> where NSMAX is the largest entry in NSVAL.
119 *> \endverbatim
120 *>
121 *> \param[out] X
122 *> \verbatim
123 *> X is COMPLEX array, dimension (NMAX*NSMAX)
124 *> \endverbatim
125 *>
126 *> \param[out] XACT
127 *> \verbatim
128 *> XACT is COMPLEX array, dimension (NMAX*NSMAX)
129 *> \endverbatim
130 *>
131 *> \param[out] WORK
132 *> \verbatim
133 *> WORK is COMPLEX array, dimension
134 *> (NMAX*max(3,NSMAX))
135 *> \endverbatim
136 *>
137 *> \param[out] RWORK
138 *> \verbatim
139 *> RWORK is REAL array, dimension
140 *> (max(NMAX,2*NSMAX))
141 *> \endverbatim
142 *>
143 *> \param[in] NOUT
144 *> \verbatim
145 *> NOUT is INTEGER
146 *> The unit number for output.
147 *> \endverbatim
148 *
149 * Authors:
150 * ========
151 *
152 *> \author Univ. of Tennessee
153 *> \author Univ. of California Berkeley
154 *> \author Univ. of Colorado Denver
155 *> \author NAG Ltd.
156 *
157 *> \date November 2011
158 *
159 *> \ingroup complex_lin
160 *
161 * =====================================================================
162  SUBROUTINE cchktr( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
163  $ thresh, tsterr, nmax, a, ainv, b, x, xact,
164  $ work, rwork, nout )
165 *
166 * -- LAPACK test routine (version 3.4.0) --
167 * -- LAPACK is a software package provided by Univ. of Tennessee, --
168 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
169 * November 2011
170 *
171 * .. Scalar Arguments ..
172  LOGICAL tsterr
173  INTEGER nmax, nn, nnb, nns, nout
174  REAL thresh
175 * ..
176 * .. Array Arguments ..
177  LOGICAL dotype( * )
178  INTEGER nbval( * ), nsval( * ), nval( * )
179  REAL rwork( * )
180  COMPLEX a( * ), ainv( * ), b( * ), work( * ), x( * ),
181  $ 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  REAL one, zero
194  parameter( one = 1.0e0, zero = 0.0e0 )
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  REAL 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  REAL result( ntests )
208 * ..
209 * .. External Functions ..
210  LOGICAL lsame
211  REAL clantr
212  EXTERNAL lsame, clantr
213 * ..
214 * .. External Subroutines ..
215  EXTERNAL alaerh, alahd, alasum, ccopy, cerrtr, cget04,
216  $ clacpy, clarhs, clatrs, clattr, ctrcon, ctrrfs,
217  $ ctrt01, ctrt02, ctrt03, ctrt05, ctrt06, ctrtri,
218  $ ctrtrs, 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 ) = 'Complex 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 cerrtr( path, nout )
253  infot = 0
254 *
255  DO 120 in = 1, nn
256 *
257 * Do for each value of N in NVAL
258 *
259  n = nval( in )
260  lda = max( 1, n )
261  xtype = 'N'
262 *
263  DO 80 imat = 1, ntype1
264 *
265 * Do the tests only if DOTYPE( IMAT ) is true.
266 *
267  IF( .NOT.dotype( imat ) )
268  $ go to 80
269 *
270  DO 70 iuplo = 1, 2
271 *
272 * Do first for UPLO = 'U', then for UPLO = 'L'
273 *
274  uplo = uplos( iuplo )
275 *
276 * Call CLATTR to generate a triangular test matrix.
277 *
278  srnamt = 'CLATTR'
279  CALL clattr( imat, uplo, 'No transpose', diag, iseed, n,
280  $ a, lda, x, work, rwork, info )
281 *
282 * Set IDIAG = 1 for non-unit matrices, 2 for unit.
283 *
284  IF( lsame( diag, 'N' ) ) THEN
285  idiag = 1
286  ELSE
287  idiag = 2
288  END IF
289 *
290  DO 60 inb = 1, nnb
291 *
292 * Do for each blocksize in NBVAL
293 *
294  nb = nbval( inb )
295  CALL xlaenv( 1, nb )
296 *
297 *+ TEST 1
298 * Form the inverse of A.
299 *
300  CALL clacpy( uplo, n, n, a, lda, ainv, lda )
301  srnamt = 'CTRTRI'
302  CALL ctrtri( uplo, diag, n, ainv, lda, info )
303 *
304 * Check error code from CTRTRI.
305 *
306  IF( info.NE.0 )
307  $ CALL alaerh( path, 'CTRTRI', info, 0, uplo // diag,
308  $ n, n, -1, -1, nb, imat, nfail, nerrs,
309  $ nout )
310 *
311 * Compute the infinity-norm condition number of A.
312 *
313  anorm = clantr( 'I', uplo, diag, n, n, a, lda, rwork )
314  ainvnm = clantr( 'I', uplo, diag, n, n, ainv, lda,
315  $ rwork )
316  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
317  rcondi = one
318  ELSE
319  rcondi = ( one / anorm ) / ainvnm
320  END IF
321 *
322 * Compute the residual for the triangular matrix times
323 * its inverse. Also compute the 1-norm condition number
324 * of A.
325 *
326  CALL ctrt01( uplo, diag, n, a, lda, ainv, lda, rcondo,
327  $ rwork, result( 1 ) )
328 * Print the test ratio if it is .GE. THRESH.
329 *
330  IF( result( 1 ).GE.thresh ) THEN
331  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
332  $ CALL alahd( nout, path )
333  WRITE( nout, fmt = 9999 )uplo, diag, n, nb, imat,
334  $ 1, result( 1 )
335  nfail = nfail + 1
336  END IF
337  nrun = nrun + 1
338 *
339 * Skip remaining tests if not the first block size.
340 *
341  IF( inb.NE.1 )
342  $ go to 60
343 *
344  DO 40 irhs = 1, nns
345  nrhs = nsval( irhs )
346  xtype = 'N'
347 *
348  DO 30 itran = 1, ntran
349 *
350 * Do for op(A) = A, A**T, or A**H.
351 *
352  trans = transs( itran )
353  IF( itran.EQ.1 ) THEN
354  norm = 'O'
355  rcondc = rcondo
356  ELSE
357  norm = 'I'
358  rcondc = rcondi
359  END IF
360 *
361 *+ TEST 2
362 * Solve and compute residual for op(A)*x = b.
363 *
364  srnamt = 'CLARHS'
365  CALL clarhs( path, xtype, uplo, trans, n, n, 0,
366  $ idiag, nrhs, a, lda, xact, lda, b,
367  $ lda, iseed, info )
368  xtype = 'C'
369  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
370 *
371  srnamt = 'CTRTRS'
372  CALL ctrtrs( uplo, trans, diag, n, nrhs, a, lda,
373  $ x, lda, info )
374 *
375 * Check error code from CTRTRS.
376 *
377  IF( info.NE.0 )
378  $ CALL alaerh( path, 'CTRTRS', info, 0,
379  $ uplo // trans // diag, n, n, -1,
380  $ -1, nrhs, imat, nfail, nerrs,
381  $ nout )
382 *
383 * This line is needed on a Sun SPARCstation.
384 *
385  IF( n.GT.0 )
386  $ dummy = a( 1 )
387 *
388  CALL ctrt02( uplo, trans, diag, n, nrhs, a, lda,
389  $ x, lda, b, lda, work, rwork,
390  $ result( 2 ) )
391 *
392 *+ TEST 3
393 * Check solution from generated exact solution.
394 *
395  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
396  $ result( 3 ) )
397 *
398 *+ TESTS 4, 5, and 6
399 * Use iterative refinement to improve the solution
400 * and compute error bounds.
401 *
402  srnamt = 'CTRRFS'
403  CALL ctrrfs( uplo, trans, diag, n, nrhs, a, lda,
404  $ b, lda, x, lda, rwork,
405  $ rwork( nrhs+1 ), work,
406  $ rwork( 2*nrhs+1 ), info )
407 *
408 * Check error code from CTRRFS.
409 *
410  IF( info.NE.0 )
411  $ CALL alaerh( path, 'CTRRFS', info, 0,
412  $ uplo // trans // diag, n, n, -1,
413  $ -1, nrhs, imat, nfail, nerrs,
414  $ nout )
415 *
416  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
417  $ result( 4 ) )
418  CALL ctrt05( uplo, trans, diag, n, nrhs, a, lda,
419  $ b, lda, x, lda, xact, lda, rwork,
420  $ rwork( nrhs+1 ), result( 5 ) )
421 *
422 * Print information about the tests that did not
423 * pass the threshold.
424 *
425  DO 20 k = 2, 6
426  IF( result( k ).GE.thresh ) THEN
427  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
428  $ CALL alahd( nout, path )
429  WRITE( nout, fmt = 9998 )uplo, trans,
430  $ diag, n, nrhs, imat, k, result( k )
431  nfail = nfail + 1
432  END IF
433  20 continue
434  nrun = nrun + 5
435  30 continue
436  40 continue
437 *
438 *+ TEST 7
439 * Get an estimate of RCOND = 1/CNDNUM.
440 *
441  DO 50 itran = 1, 2
442  IF( itran.EQ.1 ) THEN
443  norm = 'O'
444  rcondc = rcondo
445  ELSE
446  norm = 'I'
447  rcondc = rcondi
448  END IF
449  srnamt = 'CTRCON'
450  CALL ctrcon( norm, uplo, diag, n, a, lda, rcond,
451  $ work, rwork, info )
452 *
453 * Check error code from CTRCON.
454 *
455  IF( info.NE.0 )
456  $ CALL alaerh( path, 'CTRCON', info, 0,
457  $ norm // uplo // diag, n, n, -1, -1,
458  $ -1, imat, nfail, nerrs, nout )
459 *
460  CALL ctrt06( rcond, rcondc, uplo, diag, n, a, lda,
461  $ rwork, result( 7 ) )
462 *
463 * Print the test ratio if it is .GE. THRESH.
464 *
465  IF( result( 7 ).GE.thresh ) THEN
466  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
467  $ CALL alahd( nout, path )
468  WRITE( nout, fmt = 9997 )norm, uplo, n, imat,
469  $ 7, result( 7 )
470  nfail = nfail + 1
471  END IF
472  nrun = nrun + 1
473  50 continue
474  60 continue
475  70 continue
476  80 continue
477 *
478 * Use pathological test matrices to test CLATRS.
479 *
480  DO 110 imat = ntype1 + 1, ntypes
481 *
482 * Do the tests only if DOTYPE( IMAT ) is true.
483 *
484  IF( .NOT.dotype( imat ) )
485  $ go to 110
486 *
487  DO 100 iuplo = 1, 2
488 *
489 * Do first for UPLO = 'U', then for UPLO = 'L'
490 *
491  uplo = uplos( iuplo )
492  DO 90 itran = 1, ntran
493 *
494 * Do for op(A) = A, A**T, and A**H.
495 *
496  trans = transs( itran )
497 *
498 * Call CLATTR to generate a triangular test matrix.
499 *
500  srnamt = 'CLATTR'
501  CALL clattr( imat, uplo, trans, diag, iseed, n, a,
502  $ lda, x, work, rwork, info )
503 *
504 *+ TEST 8
505 * Solve the system op(A)*x = b.
506 *
507  srnamt = 'CLATRS'
508  CALL ccopy( n, x, 1, b, 1 )
509  CALL clatrs( uplo, trans, diag, 'N', n, a, lda, b,
510  $ scale, rwork, info )
511 *
512 * Check error code from CLATRS.
513 *
514  IF( info.NE.0 )
515  $ CALL alaerh( path, 'CLATRS', info, 0,
516  $ uplo // trans // diag // 'N', n, n,
517  $ -1, -1, -1, imat, nfail, nerrs, nout )
518 *
519  CALL ctrt03( uplo, trans, diag, n, 1, a, lda, scale,
520  $ rwork, one, b, lda, x, lda, work,
521  $ result( 8 ) )
522 *
523 *+ TEST 9
524 * Solve op(A)*X = b again with NORMIN = 'Y'.
525 *
526  CALL ccopy( n, x, 1, b( n+1 ), 1 )
527  CALL clatrs( uplo, trans, diag, 'Y', n, a, lda,
528  $ b( n+1 ), scale, rwork, info )
529 *
530 * Check error code from CLATRS.
531 *
532  IF( info.NE.0 )
533  $ CALL alaerh( path, 'CLATRS', info, 0,
534  $ uplo // trans // diag // 'Y', n, n,
535  $ -1, -1, -1, imat, nfail, nerrs, nout )
536 *
537  CALL ctrt03( uplo, trans, diag, n, 1, a, lda, scale,
538  $ rwork, one, b( n+1 ), lda, x, lda, work,
539  $ result( 9 ) )
540 *
541 * Print information about the tests that did not pass
542 * the threshold.
543 *
544  IF( result( 8 ).GE.thresh ) THEN
545  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
546  $ CALL alahd( nout, path )
547  WRITE( nout, fmt = 9996 )'CLATRS', uplo, trans,
548  $ diag, 'N', n, imat, 8, result( 8 )
549  nfail = nfail + 1
550  END IF
551  IF( result( 9 ).GE.thresh ) THEN
552  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
553  $ CALL alahd( nout, path )
554  WRITE( nout, fmt = 9996 )'CLATRS', uplo, trans,
555  $ diag, 'Y', n, imat, 9, result( 9 )
556  nfail = nfail + 1
557  END IF
558  nrun = nrun + 2
559  90 continue
560  100 continue
561  110 continue
562  120 continue
563 *
564 * Print a summary of the results.
565 *
566  CALL alasum( path, nout, nfail, nrun, nerrs )
567 *
568  9999 format( ' UPLO=''', a1, ''', DIAG=''', a1, ''', N=', i5, ', NB=',
569  $ i4, ', type ', i2, ', test(', i2, ')= ', g12.5 )
570  9998 format( ' UPLO=''', a1, ''', TRANS=''', a1, ''', DIAG=''', a1,
571  $ ''', N=', i5, ', NB=', i4, ', type ', i2,
572 ', $ test(', i2, ')= ', g12.5 )
573  9997 format( ' NORM=''', a1, ''', UPLO =''', a1, ''', N=', i5, ',',
574  $ 11x, ' type ', i2, ', test(', i2, ')=', g12.5 )
575  9996 format( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''', ''',
576  $ a1, ''',', i5, ', ... ), type ', i2, ', test(', i2, ')=',
577  $ g12.5 )
578  return
579 *
580 * End of CCHKTR
581 *
582  END