LAPACK  3.7.1
LAPACK: Linear Algebra PACKage

◆ dchkgt()

subroutine dchkgt ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNS,
integer, dimension( * )  NSVAL,
double precision  THRESH,
logical  TSTERR,
double precision, dimension( * )  A,
double precision, dimension( * )  AF,
double precision, dimension( * )  B,
double precision, dimension( * )  X,
double precision, dimension( * )  XACT,
double precision, dimension( * )  WORK,
double precision, dimension( * )  RWORK,
integer, dimension( * )  IWORK,
integer  NOUT 
)

DCHKGT

Purpose: 
 DCHKGT tests DGTTRF, -TRS, -RFS, and -CON
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 dimension N.
[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.
[out]A
          A is DOUBLE PRECISION array, dimension (NMAX*4)
[out]AF
          AF is DOUBLE PRECISION array, dimension (NMAX*4)
[out]B
          B is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
          where NSMAX is the largest entry in NSVAL.
[out]X
          X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
[out]XACT
          XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
[out]WORK
          WORK is DOUBLE PRECISION array, dimension
                      (NMAX*max(3,NSMAX))
[out]RWORK
          RWORK is DOUBLE PRECISION array, dimension
                      (max(NMAX,2*NSMAX))
[out]IWORK
          IWORK is INTEGER array, dimension (2*NMAX)
[in]NOUT
          NOUT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
December 2016

Definition at line 148 of file dchkgt.f.

148 *
149 * -- LAPACK test routine (version 3.7.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 * December 2016
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 *
dlacpy
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
Definition: dlacpy.f:105
dlatb4
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
Definition: dlatb4.f:122
alahd
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
dcopy
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
Definition: dcopy.f:84
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
dgtrfs
subroutine dgtrfs(TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DGTRFS
Definition: dgtrfs.f:211
dgtcon
subroutine dgtcon(NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
DGTCON
Definition: dgtcon.f:148
dgtt01
subroutine dgtt01(N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, LDWORK, RWORK, RESID)
DGTT01
Definition: dgtt01.f:136
dgtt05
subroutine dgtt05(TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DGTT05
Definition: dgtt05.f:167
dlatms
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
Definition: dlatms.f:323
dlarnv
subroutine dlarnv(IDIST, ISEED, N, X)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: dlarnv.f:99
derrge
subroutine derrge(PATH, NUNIT)
DERRGE
Definition: derrge.f:57
dlagtm
subroutine dlagtm(TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB)
DLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix...
Definition: dlagtm.f:147
dget04
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
Definition: dget04.f:104
dscal
subroutine dscal(N, DA, DX, INCX)
DSCAL
Definition: dscal.f:81
dasum
double precision function dasum(N, DX, INCX)
DASUM
Definition: dasum.f:73
dget06
double precision function dget06(RCOND, RCONDC)
DGET06
Definition: dget06.f:57
dgttrf
subroutine dgttrf(N, DL, D, DU, DU2, IPIV, INFO)
DGTTRF
Definition: dgttrf.f:126
dlangt
double precision function dlangt(NORM, N, DL, D, DU)
DLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: dlangt.f:108
dgtt02
subroutine dgtt02(TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, RESID)
DGTT02
Definition: dgtt02.f:126
dgttrs
subroutine dgttrs(TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO)
DGTTRS
Definition: dgttrs.f:140
alasum
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:75
Here is the call graph for this function:
Here is the caller graph for this function: