LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
cchkgt.f
Go to the documentation of this file.
1 *> \brief \b CCHKGT
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 CCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
12 * A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT )
13 *
14 * .. Scalar Arguments ..
15 * LOGICAL TSTERR
16 * INTEGER NN, NNS, NOUT
17 * REAL THRESH
18 * ..
19 * .. Array Arguments ..
20 * LOGICAL DOTYPE( * )
21 * INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
22 * REAL RWORK( * )
23 * COMPLEX A( * ), AF( * ), B( * ), WORK( * ), X( * ),
24 * $ XACT( * )
25 * ..
26 *
27 *
28 *> \par Purpose:
29 * =============
30 *>
31 *> \verbatim
32 *>
33 *> CCHKGT tests CGTTRF, -TRS, -RFS, and -CON
34 *> \endverbatim
35 *
36 * Arguments:
37 * ==========
38 *
39 *> \param[in] DOTYPE
40 *> \verbatim
41 *> DOTYPE is LOGICAL array, dimension (NTYPES)
42 *> The matrix types to be used for testing. Matrices of type j
43 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
44 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
45 *> \endverbatim
46 *>
47 *> \param[in] NN
48 *> \verbatim
49 *> NN is INTEGER
50 *> The number of values of N contained in the vector NVAL.
51 *> \endverbatim
52 *>
53 *> \param[in] NVAL
54 *> \verbatim
55 *> NVAL is INTEGER array, dimension (NN)
56 *> The values of the matrix dimension N.
57 *> \endverbatim
58 *>
59 *> \param[in] NNS
60 *> \verbatim
61 *> NNS is INTEGER
62 *> The number of values of NRHS contained in the vector NSVAL.
63 *> \endverbatim
64 *>
65 *> \param[in] NSVAL
66 *> \verbatim
67 *> NSVAL is INTEGER array, dimension (NNS)
68 *> The values of the number of right hand sides NRHS.
69 *> \endverbatim
70 *>
71 *> \param[in] THRESH
72 *> \verbatim
73 *> THRESH is REAL
74 *> The threshold value for the test ratios. A result is
75 *> included in the output file if RESULT >= THRESH. To have
76 *> every test ratio printed, use THRESH = 0.
77 *> \endverbatim
78 *>
79 *> \param[in] TSTERR
80 *> \verbatim
81 *> TSTERR is LOGICAL
82 *> Flag that indicates whether error exits are to be tested.
83 *> \endverbatim
84 *>
85 *> \param[out] A
86 *> \verbatim
87 *> A is COMPLEX array, dimension (NMAX*4)
88 *> \endverbatim
89 *>
90 *> \param[out] AF
91 *> \verbatim
92 *> AF is COMPLEX array, dimension (NMAX*4)
93 *> \endverbatim
94 *>
95 *> \param[out] B
96 *> \verbatim
97 *> B is COMPLEX array, dimension (NMAX*NSMAX)
98 *> where NSMAX is the largest entry in NSVAL.
99 *> \endverbatim
100 *>
101 *> \param[out] X
102 *> \verbatim
103 *> X is COMPLEX array, dimension (NMAX*NSMAX)
104 *> \endverbatim
105 *>
106 *> \param[out] XACT
107 *> \verbatim
108 *> XACT is COMPLEX array, dimension (NMAX*NSMAX)
109 *> \endverbatim
110 *>
111 *> \param[out] WORK
112 *> \verbatim
113 *> WORK is COMPLEX array, dimension
114 *> (NMAX*max(3,NSMAX))
115 *> \endverbatim
116 *>
117 *> \param[out] RWORK
118 *> \verbatim
119 *> RWORK is REAL array, dimension
120 *> (max(NMAX)+2*NSMAX)
121 *> \endverbatim
122 *>
123 *> \param[out] IWORK
124 *> \verbatim
125 *> IWORK is INTEGER array, dimension (NMAX)
126 *> \endverbatim
127 *>
128 *> \param[in] NOUT
129 *> \verbatim
130 *> NOUT is INTEGER
131 *> The unit number for output.
132 *> \endverbatim
133 *
134 * Authors:
135 * ========
136 *
137 *> \author Univ. of Tennessee
138 *> \author Univ. of California Berkeley
139 *> \author Univ. of Colorado Denver
140 *> \author NAG Ltd.
141 *
142 *> \date November 2011
143 *
144 *> \ingroup complex_lin
145 *
146 * =====================================================================
147  SUBROUTINE cchkgt( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
148  $ a, af, b, x, xact, work, rwork, iwork, nout )
149 *
150 * -- LAPACK test routine (version 3.4.0) --
151 * -- LAPACK is a software package provided by Univ. of Tennessee, --
152 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
153 * November 2011
154 *
155 * .. Scalar Arguments ..
156  LOGICAL tsterr
157  INTEGER nn, nns, nout
158  REAL thresh
159 * ..
160 * .. Array Arguments ..
161  LOGICAL dotype( * )
162  INTEGER iwork( * ), nsval( * ), nval( * )
163  REAL rwork( * )
164  COMPLEX a( * ), af( * ), b( * ), work( * ), x( * ),
165  $ xact( * )
166 * ..
167 *
168 * =====================================================================
169 *
170 * .. Parameters ..
171  REAL one, zero
172  parameter( one = 1.0e+0, zero = 0.0e+0 )
173  INTEGER ntypes
174  parameter( ntypes = 12 )
175  INTEGER ntests
176  parameter( ntests = 7 )
177 * ..
178 * .. Local Scalars ..
179  LOGICAL trfcon, zerot
180  CHARACTER dist, norm, trans, type
181  CHARACTER*3 path
182  INTEGER i, imat, in, info, irhs, itran, ix, izero, j,
183  $ k, kl, koff, ku, lda, m, mode, n, nerrs, nfail,
184  $ nimat, nrhs, nrun
185  REAL ainvnm, anorm, cond, rcond, rcondc, rcondi,
186  $ rcondo
187 * ..
188 * .. Local Arrays ..
189  CHARACTER transs( 3 )
190  INTEGER iseed( 4 ), iseedy( 4 )
191  REAL result( ntests )
192  COMPLEX z( 3 )
193 * ..
194 * .. External Functions ..
195  REAL clangt, scasum, sget06
196  EXTERNAL clangt, scasum, sget06
197 * ..
198 * .. External Subroutines ..
199  EXTERNAL alaerh, alahd, alasum, ccopy, cerrge, cget04,
200  $ cgtcon, cgtrfs, cgtt01, cgtt02, cgtt05, cgttrf,
201  $ cgttrs, clacpy, clagtm, clarnv, clatb4, clatms,
202  $ csscal
203 * ..
204 * .. Intrinsic Functions ..
205  INTRINSIC max
206 * ..
207 * .. Scalars in Common ..
208  LOGICAL lerr, ok
209  CHARACTER*32 srnamt
210  INTEGER infot, nunit
211 * ..
212 * .. Common blocks ..
213  common / infoc / infot, nunit, ok, lerr
214  common / srnamc / srnamt
215 * ..
216 * .. Data statements ..
217  DATA iseedy / 0, 0, 0, 1 / , transs / 'N', 'T',
218  $ 'C' /
219 * ..
220 * .. Executable Statements ..
221 *
222  path( 1: 1 ) = 'Complex precision'
223  path( 2: 3 ) = 'GT'
224  nrun = 0
225  nfail = 0
226  nerrs = 0
227  DO 10 i = 1, 4
228  iseed( i ) = iseedy( i )
229  10 continue
230 *
231 * Test the error exits
232 *
233  IF( tsterr )
234  $ CALL cerrge( path, nout )
235  infot = 0
236 *
237  DO 110 in = 1, nn
238 *
239 * Do for each value of N in NVAL.
240 *
241  n = nval( in )
242  m = max( n-1, 0 )
243  lda = max( 1, n )
244  nimat = ntypes
245  IF( n.LE.0 )
246  $ nimat = 1
247 *
248  DO 100 imat = 1, nimat
249 *
250 * Do the tests only if DOTYPE( IMAT ) is true.
251 *
252  IF( .NOT.dotype( imat ) )
253  $ go to 100
254 *
255 * Set up parameters with CLATB4.
256 *
257  CALL clatb4( path, imat, n, n, type, kl, ku, anorm, mode,
258  $ cond, dist )
259 *
260  zerot = imat.GE.8 .AND. imat.LE.10
261  IF( imat.LE.6 ) THEN
262 *
263 * Types 1-6: generate matrices of known condition number.
264 *
265  koff = max( 2-ku, 3-max( 1, n ) )
266  srnamt = 'CLATMS'
267  CALL clatms( n, n, dist, iseed, type, rwork, mode, cond,
268  $ anorm, kl, ku, 'Z', af( koff ), 3, work,
269  $ info )
270 *
271 * Check the error code from CLATMS.
272 *
273  IF( info.NE.0 ) THEN
274  CALL alaerh( path, 'CLATMS', info, 0, ' ', n, n, kl,
275  $ ku, -1, imat, nfail, nerrs, nout )
276  go to 100
277  END IF
278  izero = 0
279 *
280  IF( n.GT.1 ) THEN
281  CALL ccopy( n-1, af( 4 ), 3, a, 1 )
282  CALL ccopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
283  END IF
284  CALL ccopy( n, af( 2 ), 3, a( m+1 ), 1 )
285  ELSE
286 *
287 * Types 7-12: generate tridiagonal matrices with
288 * unknown condition numbers.
289 *
290  IF( .NOT.zerot .OR. .NOT.dotype( 7 ) ) THEN
291 *
292 * Generate a matrix with elements whose real and
293 * imaginary parts are from [-1,1].
294 *
295  CALL clarnv( 2, iseed, n+2*m, a )
296  IF( anorm.NE.one )
297  $ CALL csscal( n+2*m, anorm, a, 1 )
298  ELSE IF( izero.GT.0 ) THEN
299 *
300 * Reuse the last matrix by copying back the zeroed out
301 * elements.
302 *
303  IF( izero.EQ.1 ) THEN
304  a( n ) = z( 2 )
305  IF( n.GT.1 )
306  $ a( 1 ) = z( 3 )
307  ELSE IF( izero.EQ.n ) THEN
308  a( 3*n-2 ) = z( 1 )
309  a( 2*n-1 ) = z( 2 )
310  ELSE
311  a( 2*n-2+izero ) = z( 1 )
312  a( n-1+izero ) = z( 2 )
313  a( izero ) = z( 3 )
314  END IF
315  END IF
316 *
317 * If IMAT > 7, set one column of the matrix to 0.
318 *
319  IF( .NOT.zerot ) THEN
320  izero = 0
321  ELSE IF( imat.EQ.8 ) THEN
322  izero = 1
323  z( 2 ) = a( n )
324  a( n ) = zero
325  IF( n.GT.1 ) THEN
326  z( 3 ) = a( 1 )
327  a( 1 ) = zero
328  END IF
329  ELSE IF( imat.EQ.9 ) THEN
330  izero = n
331  z( 1 ) = a( 3*n-2 )
332  z( 2 ) = a( 2*n-1 )
333  a( 3*n-2 ) = zero
334  a( 2*n-1 ) = zero
335  ELSE
336  izero = ( n+1 ) / 2
337  DO 20 i = izero, n - 1
338  a( 2*n-2+i ) = zero
339  a( n-1+i ) = zero
340  a( i ) = zero
341  20 continue
342  a( 3*n-2 ) = zero
343  a( 2*n-1 ) = zero
344  END IF
345  END IF
346 *
347 *+ TEST 1
348 * Factor A as L*U and compute the ratio
349 * norm(L*U - A) / (n * norm(A) * EPS )
350 *
351  CALL ccopy( n+2*m, a, 1, af, 1 )
352  srnamt = 'CGTTRF'
353  CALL cgttrf( n, af, af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
354  $ iwork, info )
355 *
356 * Check error code from CGTTRF.
357 *
358  IF( info.NE.izero )
359  $ CALL alaerh( path, 'CGTTRF', info, izero, ' ', n, n, 1,
360  $ 1, -1, imat, nfail, nerrs, nout )
361  trfcon = info.NE.0
362 *
363  CALL cgtt01( n, a, a( m+1 ), a( n+m+1 ), af, af( m+1 ),
364  $ af( n+m+1 ), af( n+2*m+1 ), iwork, work, lda,
365  $ rwork, result( 1 ) )
366 *
367 * Print the test ratio if it is .GE. THRESH.
368 *
369  IF( result( 1 ).GE.thresh ) THEN
370  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
371  $ CALL alahd( nout, path )
372  WRITE( nout, fmt = 9999 )n, imat, 1, result( 1 )
373  nfail = nfail + 1
374  END IF
375  nrun = nrun + 1
376 *
377  DO 50 itran = 1, 2
378  trans = transs( itran )
379  IF( itran.EQ.1 ) THEN
380  norm = 'O'
381  ELSE
382  norm = 'I'
383  END IF
384  anorm = clangt( norm, n, a, a( m+1 ), a( n+m+1 ) )
385 *
386  IF( .NOT.trfcon ) THEN
387 *
388 * Use CGTTRS to solve for one column at a time of
389 * inv(A), computing the maximum column sum as we go.
390 *
391  ainvnm = zero
392  DO 40 i = 1, n
393  DO 30 j = 1, n
394  x( j ) = zero
395  30 continue
396  x( i ) = one
397  CALL cgttrs( trans, n, 1, af, af( m+1 ),
398  $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
399  $ lda, info )
400  ainvnm = max( ainvnm, scasum( n, x, 1 ) )
401  40 continue
402 *
403 * Compute RCONDC = 1 / (norm(A) * norm(inv(A))
404 *
405  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
406  rcondc = one
407  ELSE
408  rcondc = ( one / anorm ) / ainvnm
409  END IF
410  IF( itran.EQ.1 ) THEN
411  rcondo = rcondc
412  ELSE
413  rcondi = rcondc
414  END IF
415  ELSE
416  rcondc = zero
417  END IF
418 *
419 *+ TEST 7
420 * Estimate the reciprocal of the condition number of the
421 * matrix.
422 *
423  srnamt = 'CGTCON'
424  CALL cgtcon( norm, n, af, af( m+1 ), af( n+m+1 ),
425  $ af( n+2*m+1 ), iwork, anorm, rcond, work,
426  $ info )
427 *
428 * Check error code from CGTCON.
429 *
430  IF( info.NE.0 )
431  $ CALL alaerh( path, 'CGTCON', info, 0, norm, n, n, -1,
432  $ -1, -1, imat, nfail, nerrs, nout )
433 *
434  result( 7 ) = sget06( rcond, rcondc )
435 *
436 * Print the test ratio if it is .GE. THRESH.
437 *
438  IF( result( 7 ).GE.thresh ) THEN
439  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
440  $ CALL alahd( nout, path )
441  WRITE( nout, fmt = 9997 )norm, n, imat, 7,
442  $ result( 7 )
443  nfail = nfail + 1
444  END IF
445  nrun = nrun + 1
446  50 continue
447 *
448 * Skip the remaining tests if the matrix is singular.
449 *
450  IF( trfcon )
451  $ go to 100
452 *
453  DO 90 irhs = 1, nns
454  nrhs = nsval( irhs )
455 *
456 * Generate NRHS random solution vectors.
457 *
458  ix = 1
459  DO 60 j = 1, nrhs
460  CALL clarnv( 2, iseed, n, xact( ix ) )
461  ix = ix + lda
462  60 continue
463 *
464  DO 80 itran = 1, 3
465  trans = transs( itran )
466  IF( itran.EQ.1 ) THEN
467  rcondc = rcondo
468  ELSE
469  rcondc = rcondi
470  END IF
471 *
472 * Set the right hand side.
473 *
474  CALL clagtm( trans, n, nrhs, one, a,
475  $ a( m+1 ), a( n+m+1 ), xact, lda,
476  $ zero, b, lda )
477 *
478 *+ TEST 2
479 * Solve op(A) * X = B and compute the residual.
480 *
481  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
482  srnamt = 'CGTTRS'
483  CALL cgttrs( trans, n, nrhs, af, af( m+1 ),
484  $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
485  $ lda, info )
486 *
487 * Check error code from CGTTRS.
488 *
489  IF( info.NE.0 )
490  $ CALL alaerh( path, 'CGTTRS', info, 0, trans, n, n,
491  $ -1, -1, nrhs, imat, nfail, nerrs,
492  $ nout )
493 *
494  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
495  CALL cgtt02( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
496  $ x, lda, work, lda, result( 2 ) )
497 *
498 *+ TEST 3
499 * Check solution from generated exact solution.
500 *
501  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
502  $ result( 3 ) )
503 *
504 *+ TESTS 4, 5, and 6
505 * Use iterative refinement to improve the solution.
506 *
507  srnamt = 'CGTRFS'
508  CALL cgtrfs( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
509  $ af, af( m+1 ), af( n+m+1 ),
510  $ af( n+2*m+1 ), iwork, b, lda, x, lda,
511  $ rwork, rwork( nrhs+1 ), work,
512  $ rwork( 2*nrhs+1 ), info )
513 *
514 * Check error code from CGTRFS.
515 *
516  IF( info.NE.0 )
517  $ CALL alaerh( path, 'CGTRFS', info, 0, trans, n, n,
518  $ -1, -1, nrhs, imat, nfail, nerrs,
519  $ nout )
520 *
521  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
522  $ result( 4 ) )
523  CALL cgtt05( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
524  $ b, lda, x, lda, xact, lda, rwork,
525  $ rwork( nrhs+1 ), result( 5 ) )
526 *
527 * Print information about the tests that did not pass the
528 * threshold.
529 *
530  DO 70 k = 2, 6
531  IF( result( k ).GE.thresh ) THEN
532  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
533  $ CALL alahd( nout, path )
534  WRITE( nout, fmt = 9998 )trans, n, nrhs, imat,
535  $ k, result( k )
536  nfail = nfail + 1
537  END IF
538  70 continue
539  nrun = nrun + 5
540  80 continue
541  90 continue
542  100 continue
543  110 continue
544 *
545 * Print a summary of the results.
546 *
547  CALL alasum( path, nout, nfail, nrun, nerrs )
548 *
549  9999 format( 12x, 'N =', i5, ',', 10x, ' type ', i2, ', test(', i2,
550  $ ') = ', g12.5 )
551  9998 format( ' TRANS=''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
552  $ i2, ', test(', i2, ') = ', g12.5 )
553  9997 format( ' NORM =''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
554  $ ', test(', i2, ') = ', g12.5 )
555  return
556 *
557 * End of CCHKGT
558 *
559  END