LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine schkgt ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNS,
integer, dimension( * )  NSVAL,
real  THRESH,
logical  TSTERR,
real, dimension( * )  A,
real, dimension( * )  AF,
real, dimension( * )  B,
real, dimension( * )  X,
real, dimension( * )  XACT,
real, dimension( * )  WORK,
real, dimension( * )  RWORK,
integer, dimension( * )  IWORK,
integer  NOUT 
)

SCHKGT

Purpose: 
 SCHKGT tests SGTTRF, -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 REAL
          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 REAL array, dimension (NMAX*4)
[out]AF
          AF is REAL array, dimension (NMAX*4)
[out]B
          B is REAL array, dimension (NMAX*NSMAX)
          where NSMAX is the largest entry in NSVAL.
[out]X
          X is REAL array, dimension (NMAX*NSMAX)
[out]XACT
          XACT is REAL array, dimension (NMAX*NSMAX)
[out]WORK
          WORK is REAL array, dimension
                      (NMAX*max(3,NSMAX))
[out]RWORK
          RWORK is REAL 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
November 2011

Definition at line 148 of file schkgt.f.

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  REAL thresh
158 * ..
159 * .. Array Arguments ..
160  LOGICAL dotype( * )
161  INTEGER iwork( * ), nsval( * ), nval( * )
162  REAL a( * ), af( * ), b( * ), rwork( * ), work( * ),
163  $ x( * ), xact( * )
164 * ..
165 *
166 * =====================================================================
167 *
168 * .. Parameters ..
169  REAL one, zero
170  parameter ( one = 1.0e+0, zero = 0.0e+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  REAL ainvnm, anorm, cond, rcond, rcondc, rcondi,
184  $ rcondo
185 * ..
186 * .. Local Arrays ..
187  CHARACTER transs( 3 )
188  INTEGER iseed( 4 ), iseedy( 4 )
189  REAL result( ntests ), z( 3 )
190 * ..
191 * .. External Functions ..
192  REAL sasum, sget06, slangt
193  EXTERNAL sasum, sget06, slangt
194 * ..
195 * .. External Subroutines ..
196  EXTERNAL alaerh, alahd, alasum, scopy, serrge, sget04,
197  $ sgtcon, sgtrfs, sgtt01, sgtt02, sgtt05, sgttrf,
198  $ sgttrs, slacpy, slagtm, slarnv, slatb4, slatms,
199  $ sscal
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 ) = 'Single 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 serrge( 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 SLATB4.
253 *
254  CALL slatb4( 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 = 'SLATMS'
264  CALL slatms( 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 SLATMS.
269 *
270  IF( info.NE.0 ) THEN
271  CALL alaerh( path, 'SLATMS', 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 scopy( n-1, af( 4 ), 3, a, 1 )
279  CALL scopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
280  END IF
281  CALL scopy( 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 slarnv( 2, iseed, n+2*m, a )
292  IF( anorm.NE.one )
293  $ CALL sscal( 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 scopy( n+2*m, a, 1, af, 1 )
348  srnamt = 'SGTTRF'
349  CALL sgttrf( n, af, af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
350  $ iwork, info )
351 *
352 * Check error code from SGTTRF.
353 *
354  IF( info.NE.izero )
355  $ CALL alaerh( path, 'SGTTRF', info, izero, ' ', n, n, 1,
356  $ 1, -1, imat, nfail, nerrs, nout )
357  trfcon = info.NE.0
358 *
359  CALL sgtt01( 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 = slangt( norm, n, a, a( m+1 ), a( n+m+1 ) )
381 *
382  IF( .NOT.trfcon ) THEN
383 *
384 * Use SGTTRS 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 sgttrs( 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, sasum( 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 = 'SGTCON'
421  CALL sgtcon( 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 SGTCON.
426 *
427  IF( info.NE.0 )
428  $ CALL alaerh( path, 'SGTCON', 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 slarnv( 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 slagtm( 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 slacpy( 'Full', n, nrhs, b, lda, x, lda )
478  srnamt = 'SGTTRS'
479  CALL sgttrs( 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 SGTTRS.
484 *
485  IF( info.NE.0 )
486  $ CALL alaerh( path, 'SGTTRS', info, 0, trans, n, n,
487  $ -1, -1, nrhs, imat, nfail, nerrs,
488  $ nout )
489 *
490  CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
491  CALL sgtt02( 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 sget04( 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 = 'SGTRFS'
504  CALL sgtrfs( 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 SGTRFS.
511 *
512  IF( info.NE.0 )
513  $ CALL alaerh( path, 'SGTRFS', info, 0, trans, n, n,
514  $ -1, -1, nrhs, imat, nfail, nerrs,
515  $ nout )
516 *
517  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
518  $ result( 4 ) )
519  CALL sgtt05( 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 SCHKGT
555 *
sgtrfs
subroutine sgtrfs(TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SGTRFS
Definition: sgtrfs.f:211
alahd
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:95
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
slatb4
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
Definition: slatb4.f:122
sgtcon
subroutine sgtcon(NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
SGTCON
Definition: sgtcon.f:148
slangt
real function slangt(NORM, N, DL, D, DU)
SLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: slangt.f:108
sgtt02
subroutine sgtt02(TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, RESID)
SGTT02
Definition: sgtt02.f:126
slarnv
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: slarnv.f:99
serrge
subroutine serrge(PATH, NUNIT)
SERRGE
Definition: serrge.f:57
sget06
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:57
sgttrf
subroutine sgttrf(N, DL, D, DU, DU2, IPIV, INFO)
SGTTRF
Definition: sgttrf.f:126
slacpy
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:105
slagtm
subroutine slagtm(TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB)
SLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix...
Definition: slagtm.f:147
slatms
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:323
sgtt01
subroutine sgtt01(N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, LDWORK, RWORK, RESID)
SGTT01
Definition: sgtt01.f:136
sget04
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
Definition: sget04.f:104
sasum
real function sasum(N, SX, INCX)
SASUM
Definition: sasum.f:54
sgtt05
subroutine sgtt05(TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SGTT05
Definition: sgtt05.f:167
sgttrs
subroutine sgttrs(TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO)
SGTTRS
Definition: sgttrs.f:140
sscal
subroutine sscal(N, SA, SX, INCX)
SSCAL
Definition: sscal.f:55
scopy
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:53
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: