LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
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 *> \ingroup complex_lin
143 *
144 * =====================================================================
145  SUBROUTINE cchkgt( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
146  $ A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT )
147 *
148 * -- LAPACK test routine --
149 * -- LAPACK is a software package provided by Univ. of Tennessee, --
150 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
151 *
152 * .. Scalar Arguments ..
153  LOGICAL TSTERR
154  INTEGER NN, NNS, NOUT
155  REAL THRESH
156 * ..
157 * .. Array Arguments ..
158  LOGICAL DOTYPE( * )
159  INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
160  REAL RWORK( * )
161  COMPLEX A( * ), AF( * ), B( * ), WORK( * ), X( * ),
162  $ xact( * )
163 * ..
164 *
165 * =====================================================================
166 *
167 * .. Parameters ..
168  REAL ONE, ZERO
169  parameter( one = 1.0e+0, zero = 0.0e+0 )
170  INTEGER NTYPES
171  parameter( ntypes = 12 )
172  INTEGER NTESTS
173  parameter( ntests = 7 )
174 * ..
175 * .. Local Scalars ..
176  LOGICAL TRFCON, ZEROT
177  CHARACTER DIST, NORM, TRANS, TYPE
178  CHARACTER*3 PATH
179  INTEGER I, IMAT, IN, INFO, IRHS, ITRAN, IX, IZERO, J,
180  $ k, kl, koff, ku, lda, m, mode, n, nerrs, nfail,
181  $ nimat, nrhs, nrun
182  REAL AINVNM, ANORM, COND, RCOND, RCONDC, RCONDI,
183  $ rcondo
184 * ..
185 * .. Local Arrays ..
186  CHARACTER TRANSS( 3 )
187  INTEGER ISEED( 4 ), ISEEDY( 4 )
188  REAL RESULT( NTESTS )
189  COMPLEX Z( 3 )
190 * ..
191 * .. External Functions ..
192  REAL CLANGT, SCASUM, SGET06
193  EXTERNAL clangt, scasum, sget06
194 * ..
195 * .. External Subroutines ..
196  EXTERNAL alaerh, alahd, alasum, ccopy, cerrge, cget04,
199  $ csscal
200 * ..
201 * .. Intrinsic Functions ..
202  INTRINSIC max
203 * ..
204 * .. Scalars in Common ..
205  LOGICAL LERR, OK
206  CHARACTER*32 SRNAMT
207  INTEGER INFOT, NUNIT
208 * ..
209 * .. Common blocks ..
210  COMMON / infoc / infot, nunit, ok, lerr
211  COMMON / srnamc / srnamt
212 * ..
213 * .. Data statements ..
214  DATA iseedy / 0, 0, 0, 1 / , transs / 'N', 'T',
215  $ 'C' /
216 * ..
217 * .. Executable Statements ..
218 *
219  path( 1: 1 ) = 'Complex precision'
220  path( 2: 3 ) = 'GT'
221  nrun = 0
222  nfail = 0
223  nerrs = 0
224  DO 10 i = 1, 4
225  iseed( i ) = iseedy( i )
226  10 CONTINUE
227 *
228 * Test the error exits
229 *
230  IF( tsterr )
231  $ CALL cerrge( path, nout )
232  infot = 0
233 *
234  DO 110 in = 1, nn
235 *
236 * Do for each value of N in NVAL.
237 *
238  n = nval( in )
239  m = max( n-1, 0 )
240  lda = max( 1, n )
241  nimat = ntypes
242  IF( n.LE.0 )
243  $ nimat = 1
244 *
245  DO 100 imat = 1, nimat
246 *
247 * Do the tests only if DOTYPE( IMAT ) is true.
248 *
249  IF( .NOT.dotype( imat ) )
250  $ GO TO 100
251 *
252 * Set up parameters with CLATB4.
253 *
254  CALL clatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
255  $ cond, dist )
256 *
257  zerot = imat.GE.8 .AND. imat.LE.10
258  IF( imat.LE.6 ) THEN
259 *
260 * Types 1-6: generate matrices of known condition number.
261 *
262  koff = max( 2-ku, 3-max( 1, n ) )
263  srnamt = 'CLATMS'
264  CALL clatms( n, n, dist, iseed, TYPE, rwork, mode, cond,
265  $ anorm, kl, ku, 'Z', af( koff ), 3, work,
266  $ info )
267 *
268 * Check the error code from CLATMS.
269 *
270  IF( info.NE.0 ) THEN
271  CALL alaerh( path, 'CLATMS', info, 0, ' ', n, n, kl,
272  $ ku, -1, imat, nfail, nerrs, nout )
273  GO TO 100
274  END IF
275  izero = 0
276 *
277  IF( n.GT.1 ) THEN
278  CALL ccopy( n-1, af( 4 ), 3, a, 1 )
279  CALL ccopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
280  END IF
281  CALL ccopy( n, af( 2 ), 3, a( m+1 ), 1 )
282  ELSE
283 *
284 * Types 7-12: generate tridiagonal matrices with
285 * unknown condition numbers.
286 *
287  IF( .NOT.zerot .OR. .NOT.dotype( 7 ) ) THEN
288 *
289 * Generate a matrix with elements whose real and
290 * imaginary parts are from [-1,1].
291 *
292  CALL clarnv( 2, iseed, n+2*m, a )
293  IF( anorm.NE.one )
294  $ CALL csscal( n+2*m, anorm, a, 1 )
295  ELSE IF( izero.GT.0 ) THEN
296 *
297 * Reuse the last matrix by copying back the zeroed out
298 * elements.
299 *
300  IF( izero.EQ.1 ) THEN
301  a( n ) = z( 2 )
302  IF( n.GT.1 )
303  $ a( 1 ) = z( 3 )
304  ELSE IF( izero.EQ.n ) THEN
305  a( 3*n-2 ) = z( 1 )
306  a( 2*n-1 ) = z( 2 )
307  ELSE
308  a( 2*n-2+izero ) = z( 1 )
309  a( n-1+izero ) = z( 2 )
310  a( izero ) = z( 3 )
311  END IF
312  END IF
313 *
314 * If IMAT > 7, set one column of the matrix to 0.
315 *
316  IF( .NOT.zerot ) THEN
317  izero = 0
318  ELSE IF( imat.EQ.8 ) THEN
319  izero = 1
320  z( 2 ) = a( n )
321  a( n ) = zero
322  IF( n.GT.1 ) THEN
323  z( 3 ) = a( 1 )
324  a( 1 ) = zero
325  END IF
326  ELSE IF( imat.EQ.9 ) THEN
327  izero = n
328  z( 1 ) = a( 3*n-2 )
329  z( 2 ) = a( 2*n-1 )
330  a( 3*n-2 ) = zero
331  a( 2*n-1 ) = zero
332  ELSE
333  izero = ( n+1 ) / 2
334  DO 20 i = izero, n - 1
335  a( 2*n-2+i ) = zero
336  a( n-1+i ) = zero
337  a( i ) = zero
338  20 CONTINUE
339  a( 3*n-2 ) = zero
340  a( 2*n-1 ) = zero
341  END IF
342  END IF
343 *
344 *+ TEST 1
345 * Factor A as L*U and compute the ratio
346 * norm(L*U - A) / (n * norm(A) * EPS )
347 *
348  CALL ccopy( n+2*m, a, 1, af, 1 )
349  srnamt = 'CGTTRF'
350  CALL cgttrf( n, af, af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
351  $ iwork, info )
352 *
353 * Check error code from CGTTRF.
354 *
355  IF( info.NE.izero )
356  $ CALL alaerh( path, 'CGTTRF', info, izero, ' ', n, n, 1,
357  $ 1, -1, imat, nfail, nerrs, nout )
358  trfcon = info.NE.0
359 *
360  CALL cgtt01( n, a, a( m+1 ), a( n+m+1 ), af, af( m+1 ),
361  $ af( n+m+1 ), af( n+2*m+1 ), iwork, work, lda,
362  $ rwork, result( 1 ) )
363 *
364 * Print the test ratio if it is .GE. THRESH.
365 *
366  IF( result( 1 ).GE.thresh ) THEN
367  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
368  $ CALL alahd( nout, path )
369  WRITE( nout, fmt = 9999 )n, imat, 1, result( 1 )
370  nfail = nfail + 1
371  END IF
372  nrun = nrun + 1
373 *
374  DO 50 itran = 1, 2
375  trans = transs( itran )
376  IF( itran.EQ.1 ) THEN
377  norm = 'O'
378  ELSE
379  norm = 'I'
380  END IF
381  anorm = clangt( norm, n, a, a( m+1 ), a( n+m+1 ) )
382 *
383  IF( .NOT.trfcon ) THEN
384 *
385 * Use CGTTRS to solve for one column at a time of
386 * inv(A), computing the maximum column sum as we go.
387 *
388  ainvnm = zero
389  DO 40 i = 1, n
390  DO 30 j = 1, n
391  x( j ) = zero
392  30 CONTINUE
393  x( i ) = one
394  CALL cgttrs( trans, n, 1, af, af( m+1 ),
395  $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
396  $ lda, info )
397  ainvnm = max( ainvnm, scasum( n, x, 1 ) )
398  40 CONTINUE
399 *
400 * Compute RCONDC = 1 / (norm(A) * norm(inv(A))
401 *
402  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
403  rcondc = one
404  ELSE
405  rcondc = ( one / anorm ) / ainvnm
406  END IF
407  IF( itran.EQ.1 ) THEN
408  rcondo = rcondc
409  ELSE
410  rcondi = rcondc
411  END IF
412  ELSE
413  rcondc = zero
414  END IF
415 *
416 *+ TEST 7
417 * Estimate the reciprocal of the condition number of the
418 * matrix.
419 *
420  srnamt = 'CGTCON'
421  CALL cgtcon( norm, n, af, af( m+1 ), af( n+m+1 ),
422  $ af( n+2*m+1 ), iwork, anorm, rcond, work,
423  $ info )
424 *
425 * Check error code from CGTCON.
426 *
427  IF( info.NE.0 )
428  $ CALL alaerh( path, 'CGTCON', info, 0, norm, n, n, -1,
429  $ -1, -1, imat, nfail, nerrs, nout )
430 *
431  result( 7 ) = sget06( rcond, rcondc )
432 *
433 * Print the test ratio if it is .GE. THRESH.
434 *
435  IF( result( 7 ).GE.thresh ) THEN
436  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
437  $ CALL alahd( nout, path )
438  WRITE( nout, fmt = 9997 )norm, n, imat, 7,
439  $ result( 7 )
440  nfail = nfail + 1
441  END IF
442  nrun = nrun + 1
443  50 CONTINUE
444 *
445 * Skip the remaining tests if the matrix is singular.
446 *
447  IF( trfcon )
448  $ GO TO 100
449 *
450  DO 90 irhs = 1, nns
451  nrhs = nsval( irhs )
452 *
453 * Generate NRHS random solution vectors.
454 *
455  ix = 1
456  DO 60 j = 1, nrhs
457  CALL clarnv( 2, iseed, n, xact( ix ) )
458  ix = ix + lda
459  60 CONTINUE
460 *
461  DO 80 itran = 1, 3
462  trans = transs( itran )
463  IF( itran.EQ.1 ) THEN
464  rcondc = rcondo
465  ELSE
466  rcondc = rcondi
467  END IF
468 *
469 * Set the right hand side.
470 *
471  CALL clagtm( trans, n, nrhs, one, a,
472  $ a( m+1 ), a( n+m+1 ), xact, lda,
473  $ zero, b, lda )
474 *
475 *+ TEST 2
476 * Solve op(A) * X = B and compute the residual.
477 *
478  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
479  srnamt = 'CGTTRS'
480  CALL cgttrs( trans, n, nrhs, af, af( m+1 ),
481  $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
482  $ lda, info )
483 *
484 * Check error code from CGTTRS.
485 *
486  IF( info.NE.0 )
487  $ CALL alaerh( path, 'CGTTRS', info, 0, trans, n, n,
488  $ -1, -1, nrhs, imat, nfail, nerrs,
489  $ nout )
490 *
491  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
492  CALL cgtt02( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
493  $ x, lda, work, lda, result( 2 ) )
494 *
495 *+ TEST 3
496 * Check solution from generated exact solution.
497 *
498  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
499  $ result( 3 ) )
500 *
501 *+ TESTS 4, 5, and 6
502 * Use iterative refinement to improve the solution.
503 *
504  srnamt = 'CGTRFS'
505  CALL cgtrfs( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
506  $ af, af( m+1 ), af( n+m+1 ),
507  $ af( n+2*m+1 ), iwork, b, lda, x, lda,
508  $ rwork, rwork( nrhs+1 ), work,
509  $ rwork( 2*nrhs+1 ), info )
510 *
511 * Check error code from CGTRFS.
512 *
513  IF( info.NE.0 )
514  $ CALL alaerh( path, 'CGTRFS', info, 0, trans, n, n,
515  $ -1, -1, nrhs, imat, nfail, nerrs,
516  $ nout )
517 *
518  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
519  $ result( 4 ) )
520  CALL cgtt05( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
521  $ b, lda, x, lda, xact, lda, rwork,
522  $ rwork( nrhs+1 ), result( 5 ) )
523 *
524 * Print information about the tests that did not pass the
525 * threshold.
526 *
527  DO 70 k = 2, 6
528  IF( result( k ).GE.thresh ) THEN
529  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
530  $ CALL alahd( nout, path )
531  WRITE( nout, fmt = 9998 )trans, n, nrhs, imat,
532  $ k, result( k )
533  nfail = nfail + 1
534  END IF
535  70 CONTINUE
536  nrun = nrun + 5
537  80 CONTINUE
538  90 CONTINUE
539  100 CONTINUE
540  110 CONTINUE
541 *
542 * Print a summary of the results.
543 *
544  CALL alasum( path, nout, nfail, nrun, nerrs )
545 *
546  9999 FORMAT( 12x, 'N =', i5, ',', 10x, ' type ', i2, ', test(', i2,
547  $ ') = ', g12.5 )
548  9998 FORMAT( ' TRANS=''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
549  $ i2, ', test(', i2, ') = ', g12.5 )
550  9997 FORMAT( ' NORM =''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
551  $ ', test(', i2, ') = ', g12.5 )
552  RETURN
553 *
554 * End of CCHKGT
555 *
556  END
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:73
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 ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:81
subroutine csscal(N, SA, CX, INCX)
CSSCAL
Definition: csscal.f:78
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:121
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:102
subroutine cerrge(PATH, NUNIT)
CERRGE
Definition: cerrge.f:55
subroutine cgtt02(TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, RESID)
CGTT02
Definition: cgtt02.f:124
subroutine cgtt05(TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CGTT05
Definition: cgtt05.f:165
subroutine cgtt01(N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, LDWORK, RWORK, RESID)
CGTT01
Definition: cgtt01.f:134
subroutine cchkgt(DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT)
CCHKGT
Definition: cchkgt.f:147
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:332
subroutine cgttrf(N, DL, D, DU, DU2, IPIV, INFO)
CGTTRF
Definition: cgttrf.f:124
subroutine cgtcon(NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, INFO)
CGTCON
Definition: cgtcon.f:141
subroutine cgtrfs(TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CGTRFS
Definition: cgtrfs.f:210
subroutine cgttrs(TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO)
CGTTRS
Definition: cgttrs.f:138
subroutine clagtm(TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB)
CLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix,...
Definition: clagtm.f:145
subroutine clarnv(IDIST, ISEED, N, X)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: clarnv.f:99
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:103