LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
dchkgt.f
Go to the documentation of this file.
1 *> \brief \b DCHKGT
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 DCHKGT( 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 * DOUBLE PRECISION THRESH
18 * ..
19 * .. Array Arguments ..
20 * LOGICAL DOTYPE( * )
21 * INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
22 * DOUBLE PRECISION A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ),
23 * $ X( * ), XACT( * )
24 * ..
25 *
26 *
27 *> \par Purpose:
28 * =============
29 *>
30 *> \verbatim
31 *>
32 *> DCHKGT tests DGTTRF, -TRS, -RFS, and -CON
33 *> \endverbatim
34 *
35 * Arguments:
36 * ==========
37 *
38 *> \param[in] DOTYPE
39 *> \verbatim
40 *> DOTYPE is LOGICAL array, dimension (NTYPES)
41 *> The matrix types to be used for testing. Matrices of type j
42 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
43 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
44 *> \endverbatim
45 *>
46 *> \param[in] NN
47 *> \verbatim
48 *> NN is INTEGER
49 *> The number of values of N contained in the vector NVAL.
50 *> \endverbatim
51 *>
52 *> \param[in] NVAL
53 *> \verbatim
54 *> NVAL is INTEGER array, dimension (NN)
55 *> The values of the matrix dimension N.
56 *> \endverbatim
57 *>
58 *> \param[in] NNS
59 *> \verbatim
60 *> NNS is INTEGER
61 *> The number of values of NRHS contained in the vector NSVAL.
62 *> \endverbatim
63 *>
64 *> \param[in] NSVAL
65 *> \verbatim
66 *> NSVAL is INTEGER array, dimension (NNS)
67 *> The values of the number of right hand sides NRHS.
68 *> \endverbatim
69 *>
70 *> \param[in] THRESH
71 *> \verbatim
72 *> THRESH is DOUBLE PRECISION
73 *> The threshold value for the test ratios. A result is
74 *> included in the output file if RESULT >= THRESH. To have
75 *> every test ratio printed, use THRESH = 0.
76 *> \endverbatim
77 *>
78 *> \param[in] TSTERR
79 *> \verbatim
80 *> TSTERR is LOGICAL
81 *> Flag that indicates whether error exits are to be tested.
82 *> \endverbatim
83 *>
84 *> \param[out] A
85 *> \verbatim
86 *> A is DOUBLE PRECISION array, dimension (NMAX*4)
87 *> \endverbatim
88 *>
89 *> \param[out] AF
90 *> \verbatim
91 *> AF is DOUBLE PRECISION array, dimension (NMAX*4)
92 *> \endverbatim
93 *>
94 *> \param[out] B
95 *> \verbatim
96 *> B is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
97 *> where NSMAX is the largest entry in NSVAL.
98 *> \endverbatim
99 *>
100 *> \param[out] X
101 *> \verbatim
102 *> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
103 *> \endverbatim
104 *>
105 *> \param[out] XACT
106 *> \verbatim
107 *> XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
108 *> \endverbatim
109 *>
110 *> \param[out] WORK
111 *> \verbatim
112 *> WORK is DOUBLE PRECISION array, dimension
113 *> (NMAX*max(3,NSMAX))
114 *> \endverbatim
115 *>
116 *> \param[out] RWORK
117 *> \verbatim
118 *> RWORK is DOUBLE PRECISION array, dimension
119 *> (max(NMAX,2*NSMAX))
120 *> \endverbatim
121 *>
122 *> \param[out] IWORK
123 *> \verbatim
124 *> IWORK is INTEGER array, dimension (2*NMAX)
125 *> \endverbatim
126 *>
127 *> \param[in] NOUT
128 *> \verbatim
129 *> NOUT is INTEGER
130 *> The unit number for output.
131 *> \endverbatim
132 *
133 * Authors:
134 * ========
135 *
136 *> \author Univ. of Tennessee
137 *> \author Univ. of California Berkeley
138 *> \author Univ. of Colorado Denver
139 *> \author NAG Ltd.
140 *
141 *> \date November 2011
142 *
143 *> \ingroup double_lin
144 *
145 * =====================================================================
146  SUBROUTINE dchkgt( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
147  $ a, af, b, x, xact, work, rwork, iwork, nout )
148 *
149 * -- LAPACK test routine (version 3.4.0) --
150 * -- LAPACK is a software package provided by Univ. of Tennessee, --
151 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
152 * November 2011
153 *
154 * .. Scalar Arguments ..
155  LOGICAL tsterr
156  INTEGER nn, nns, nout
157  DOUBLE PRECISION thresh
158 * ..
159 * .. Array Arguments ..
160  LOGICAL dotype( * )
161  INTEGER iwork( * ), nsval( * ), nval( * )
162  DOUBLE PRECISION a( * ), af( * ), b( * ), rwork( * ), work( * ),
163  $ x( * ), xact( * )
164 * ..
165 *
166 * =====================================================================
167 *
168 * .. Parameters ..
169  DOUBLE PRECISION one, zero
170  parameter( one = 1.0d+0, zero = 0.0d+0 )
171  INTEGER ntypes
172  parameter( ntypes = 12 )
173  INTEGER ntests
174  parameter( ntests = 7 )
175 * ..
176 * .. Local Scalars ..
177  LOGICAL trfcon, zerot
178  CHARACTER dist, norm, trans, type
179  CHARACTER*3 path
180  INTEGER i, imat, in, info, irhs, itran, ix, izero, j,
181  $ k, kl, koff, ku, lda, m, mode, n, nerrs, nfail,
182  $ nimat, nrhs, nrun
183  DOUBLE PRECISION ainvnm, anorm, cond, rcond, rcondc, rcondi,
184  $ rcondo
185 * ..
186 * .. Local Arrays ..
187  CHARACTER transs( 3 )
188  INTEGER iseed( 4 ), iseedy( 4 )
189  DOUBLE PRECISION result( ntests ), z( 3 )
190 * ..
191 * .. External Functions ..
192  DOUBLE PRECISION dasum, dget06, dlangt
193  EXTERNAL dasum, dget06, dlangt
194 * ..
195 * .. External Subroutines ..
196  EXTERNAL alaerh, alahd, alasum, dcopy, derrge, dget04,
197  $ dgtcon, dgtrfs, dgtt01, dgtt02, dgtt05, dgttrf,
198  $ dgttrs, dlacpy, dlagtm, dlarnv, dlatb4, dlatms,
199  $ dscal
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 ) = 'Double 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 derrge( 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 DLATB4.
253 *
254  CALL dlatb4( 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 = 'DLATMS'
264  CALL dlatms( 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 DLATMS.
269 *
270  IF( info.NE.0 ) THEN
271  CALL alaerh( path, 'DLATMS', 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 dcopy( n-1, af( 4 ), 3, a, 1 )
279  CALL dcopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
280  END IF
281  CALL dcopy( 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 from [-1,1].
290 *
291  CALL dlarnv( 2, iseed, n+2*m, a )
292  IF( anorm.NE.one )
293  $ CALL dscal( n+2*m, anorm, a, 1 )
294  ELSE IF( izero.GT.0 ) THEN
295 *
296 * Reuse the last matrix by copying back the zeroed out
297 * elements.
298 *
299  IF( izero.EQ.1 ) THEN
300  a( n ) = z( 2 )
301  IF( n.GT.1 )
302  $ a( 1 ) = z( 3 )
303  ELSE IF( izero.EQ.n ) THEN
304  a( 3*n-2 ) = z( 1 )
305  a( 2*n-1 ) = z( 2 )
306  ELSE
307  a( 2*n-2+izero ) = z( 1 )
308  a( n-1+izero ) = z( 2 )
309  a( izero ) = z( 3 )
310  END IF
311  END IF
312 *
313 * If IMAT > 7, set one column of the matrix to 0.
314 *
315  IF( .NOT.zerot ) THEN
316  izero = 0
317  ELSE IF( imat.EQ.8 ) THEN
318  izero = 1
319  z( 2 ) = a( n )
320  a( n ) = zero
321  IF( n.GT.1 ) THEN
322  z( 3 ) = a( 1 )
323  a( 1 ) = zero
324  END IF
325  ELSE IF( imat.EQ.9 ) THEN
326  izero = n
327  z( 1 ) = a( 3*n-2 )
328  z( 2 ) = a( 2*n-1 )
329  a( 3*n-2 ) = zero
330  a( 2*n-1 ) = zero
331  ELSE
332  izero = ( n+1 ) / 2
333  DO 20 i = izero, n - 1
334  a( 2*n-2+i ) = zero
335  a( n-1+i ) = zero
336  a( i ) = zero
337  20 continue
338  a( 3*n-2 ) = zero
339  a( 2*n-1 ) = zero
340  END IF
341  END IF
342 *
343 *+ TEST 1
344 * Factor A as L*U and compute the ratio
345 * norm(L*U - A) / (n * norm(A) * EPS )
346 *
347  CALL dcopy( n+2*m, a, 1, af, 1 )
348  srnamt = 'DGTTRF'
349  CALL dgttrf( n, af, af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
350  $ iwork, info )
351 *
352 * Check error code from DGTTRF.
353 *
354  IF( info.NE.izero )
355  $ CALL alaerh( path, 'DGTTRF', info, izero, ' ', n, n, 1,
356  $ 1, -1, imat, nfail, nerrs, nout )
357  trfcon = info.NE.0
358 *
359  CALL dgtt01( n, a, a( m+1 ), a( n+m+1 ), af, af( m+1 ),
360  $ af( n+m+1 ), af( n+2*m+1 ), iwork, work, lda,
361  $ rwork, result( 1 ) )
362 *
363 * Print the test ratio if it is .GE. THRESH.
364 *
365  IF( result( 1 ).GE.thresh ) THEN
366  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
367  $ CALL alahd( nout, path )
368  WRITE( nout, fmt = 9999 )n, imat, 1, result( 1 )
369  nfail = nfail + 1
370  END IF
371  nrun = nrun + 1
372 *
373  DO 50 itran = 1, 2
374  trans = transs( itran )
375  IF( itran.EQ.1 ) THEN
376  norm = 'O'
377  ELSE
378  norm = 'I'
379  END IF
380  anorm = dlangt( norm, n, a, a( m+1 ), a( n+m+1 ) )
381 *
382  IF( .NOT.trfcon ) THEN
383 *
384 * Use DGTTRS to solve for one column at a time of inv(A)
385 * or inv(A^T), computing the maximum column sum as we
386 * 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 dgttrs( 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, dasum( 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 = 'DGTCON'
421  CALL dgtcon( norm, n, af, af( m+1 ), af( n+m+1 ),
422  $ af( n+2*m+1 ), iwork, anorm, rcond, work,
423  $ iwork( n+1 ), info )
424 *
425 * Check error code from DGTCON.
426 *
427  IF( info.NE.0 )
428  $ CALL alaerh( path, 'DGTCON', info, 0, norm, n, n, -1,
429  $ -1, -1, imat, nfail, nerrs, nout )
430 *
431  result( 7 ) = dget06( 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 dlarnv( 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 dlagtm( trans, n, nrhs, one, a, a( m+1 ),
472  $ a( n+m+1 ), xact, lda, zero, b, lda )
473 *
474 *+ TEST 2
475 * Solve op(A) * X = B and compute the residual.
476 *
477  CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
478  srnamt = 'DGTTRS'
479  CALL dgttrs( trans, n, nrhs, af, af( m+1 ),
480  $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
481  $ lda, info )
482 *
483 * Check error code from DGTTRS.
484 *
485  IF( info.NE.0 )
486  $ CALL alaerh( path, 'DGTTRS', info, 0, trans, n, n,
487  $ -1, -1, nrhs, imat, nfail, nerrs,
488  $ nout )
489 *
490  CALL dlacpy( 'Full', n, nrhs, b, lda, work, lda )
491  CALL dgtt02( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
492  $ x, lda, work, lda, result( 2 ) )
493 *
494 *+ TEST 3
495 * Check solution from generated exact solution.
496 *
497  CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
498  $ result( 3 ) )
499 *
500 *+ TESTS 4, 5, and 6
501 * Use iterative refinement to improve the solution.
502 *
503  srnamt = 'DGTRFS'
504  CALL dgtrfs( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
505  $ af, af( m+1 ), af( n+m+1 ),
506  $ af( n+2*m+1 ), iwork, b, lda, x, lda,
507  $ rwork, rwork( nrhs+1 ), work,
508  $ iwork( n+1 ), info )
509 *
510 * Check error code from DGTRFS.
511 *
512  IF( info.NE.0 )
513  $ CALL alaerh( path, 'DGTRFS', info, 0, trans, n, n,
514  $ -1, -1, nrhs, imat, nfail, nerrs,
515  $ nout )
516 *
517  CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
518  $ result( 4 ) )
519  CALL dgtt05( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
520  $ b, lda, x, lda, xact, lda, rwork,
521  $ rwork( nrhs+1 ), result( 5 ) )
522 *
523 * Print information about the tests that did not pass
524 * the threshold.
525 *
526  DO 70 k = 2, 6
527  IF( result( k ).GE.thresh ) THEN
528  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
529  $ CALL alahd( nout, path )
530  WRITE( nout, fmt = 9998 )trans, n, nrhs, imat,
531  $ k, result( k )
532  nfail = nfail + 1
533  END IF
534  70 continue
535  nrun = nrun + 5
536  80 continue
537  90 continue
538 *
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 DCHKGT
555 *
556  END