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

SCHKPT

Purpose: 
 SCHKPT tests SPTTRF, -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*2)
[out]D
          D is REAL array, dimension (NMAX*2)
[out]E
          E is REAL array, dimension (NMAX*2)
[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))
[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 schkpt.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 nsval( * ), nval( * )
162  REAL a( * ), b( * ), d( * ), e( * ), rwork( * ),
163  $ work( * ), 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 zerot
178  CHARACTER dist, type
179  CHARACTER*3 path
180  INTEGER i, ia, imat, in, info, irhs, ix, izero, j, k,
181  $ kl, ku, lda, mode, n, nerrs, nfail, nimat,
182  $ nrhs, nrun
183  REAL ainvnm, anorm, cond, dmax, rcond, rcondc
184 * ..
185 * .. Local Arrays ..
186  INTEGER iseed( 4 ), iseedy( 4 )
187  REAL result( ntests ), z( 3 )
188 * ..
189 * .. External Functions ..
190  INTEGER isamax
191  REAL sasum, sget06, slanst
192  EXTERNAL isamax, sasum, sget06, slanst
193 * ..
194 * .. External Subroutines ..
195  EXTERNAL alaerh, alahd, alasum, scopy, serrgt, sget04,
196  $ slacpy, slaptm, slarnv, slatb4, slatms, sptcon,
197  $ sptrfs, sptt01, sptt02, sptt05, spttrf, spttrs,
198  $ sscal
199 * ..
200 * .. Intrinsic Functions ..
201  INTRINSIC abs, max
202 * ..
203 * .. Scalars in Common ..
204  LOGICAL lerr, ok
205  CHARACTER*32 srnamt
206  INTEGER infot, nunit
207 * ..
208 * .. Common blocks ..
209  COMMON / infoc / infot, nunit, ok, lerr
210  COMMON / srnamc / srnamt
211 * ..
212 * .. Data statements ..
213  DATA iseedy / 0, 0, 0, 1 /
214 * ..
215 * .. Executable Statements ..
216 *
217  path( 1: 1 ) = 'Single precision'
218  path( 2: 3 ) = 'PT'
219  nrun = 0
220  nfail = 0
221  nerrs = 0
222  DO 10 i = 1, 4
223  iseed( i ) = iseedy( i )
224  10 CONTINUE
225 *
226 * Test the error exits
227 *
228  IF( tsterr )
229  $ CALL serrgt( path, nout )
230  infot = 0
231 *
232  DO 110 in = 1, nn
233 *
234 * Do for each value of N in NVAL.
235 *
236  n = nval( in )
237  lda = max( 1, n )
238  nimat = ntypes
239  IF( n.LE.0 )
240  $ nimat = 1
241 *
242  DO 100 imat = 1, nimat
243 *
244 * Do the tests only if DOTYPE( IMAT ) is true.
245 *
246  IF( n.GT.0 .AND. .NOT.dotype( imat ) )
247  $ GO TO 100
248 *
249 * Set up parameters with SLATB4.
250 *
251  CALL slatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
252  $ cond, dist )
253 *
254  zerot = imat.GE.8 .AND. imat.LE.10
255  IF( imat.LE.6 ) THEN
256 *
257 * Type 1-6: generate a symmetric tridiagonal matrix of
258 * known condition number in lower triangular band storage.
259 *
260  srnamt = 'SLATMS'
261  CALL slatms( n, n, dist, iseed, TYPE, rwork, mode, cond,
262  $ anorm, kl, ku, 'B', a, 2, work, info )
263 *
264 * Check the error code from SLATMS.
265 *
266  IF( info.NE.0 ) THEN
267  CALL alaerh( path, 'SLATMS', info, 0, ' ', n, n, kl,
268  $ ku, -1, imat, nfail, nerrs, nout )
269  GO TO 100
270  END IF
271  izero = 0
272 *
273 * Copy the matrix to D and E.
274 *
275  ia = 1
276  DO 20 i = 1, n - 1
277  d( i ) = a( ia )
278  e( i ) = a( ia+1 )
279  ia = ia + 2
280  20 CONTINUE
281  IF( n.GT.0 )
282  $ d( n ) = a( ia )
283  ELSE
284 *
285 * Type 7-12: generate a diagonally dominant matrix with
286 * unknown condition number in the vectors D and E.
287 *
288  IF( .NOT.zerot .OR. .NOT.dotype( 7 ) ) THEN
289 *
290 * Let D and E have values from [-1,1].
291 *
292  CALL slarnv( 2, iseed, n, d )
293  CALL slarnv( 2, iseed, n-1, e )
294 *
295 * Make the tridiagonal matrix diagonally dominant.
296 *
297  IF( n.EQ.1 ) THEN
298  d( 1 ) = abs( d( 1 ) )
299  ELSE
300  d( 1 ) = abs( d( 1 ) ) + abs( e( 1 ) )
301  d( n ) = abs( d( n ) ) + abs( e( n-1 ) )
302  DO 30 i = 2, n - 1
303  d( i ) = abs( d( i ) ) + abs( e( i ) ) +
304  $ abs( e( i-1 ) )
305  30 CONTINUE
306  END IF
307 *
308 * Scale D and E so the maximum element is ANORM.
309 *
310  ix = isamax( n, d, 1 )
311  dmax = d( ix )
312  CALL sscal( n, anorm / dmax, d, 1 )
313  CALL sscal( n-1, anorm / dmax, e, 1 )
314 *
315  ELSE IF( izero.GT.0 ) THEN
316 *
317 * Reuse the last matrix by copying back the zeroed out
318 * elements.
319 *
320  IF( izero.EQ.1 ) THEN
321  d( 1 ) = z( 2 )
322  IF( n.GT.1 )
323  $ e( 1 ) = z( 3 )
324  ELSE IF( izero.EQ.n ) THEN
325  e( n-1 ) = z( 1 )
326  d( n ) = z( 2 )
327  ELSE
328  e( izero-1 ) = z( 1 )
329  d( izero ) = z( 2 )
330  e( izero ) = z( 3 )
331  END IF
332  END IF
333 *
334 * For types 8-10, set one row and column of the matrix to
335 * zero.
336 *
337  izero = 0
338  IF( imat.EQ.8 ) THEN
339  izero = 1
340  z( 2 ) = d( 1 )
341  d( 1 ) = zero
342  IF( n.GT.1 ) THEN
343  z( 3 ) = e( 1 )
344  e( 1 ) = zero
345  END IF
346  ELSE IF( imat.EQ.9 ) THEN
347  izero = n
348  IF( n.GT.1 ) THEN
349  z( 1 ) = e( n-1 )
350  e( n-1 ) = zero
351  END IF
352  z( 2 ) = d( n )
353  d( n ) = zero
354  ELSE IF( imat.EQ.10 ) THEN
355  izero = ( n+1 ) / 2
356  IF( izero.GT.1 ) THEN
357  z( 1 ) = e( izero-1 )
358  e( izero-1 ) = zero
359  z( 3 ) = e( izero )
360  e( izero ) = zero
361  END IF
362  z( 2 ) = d( izero )
363  d( izero ) = zero
364  END IF
365  END IF
366 *
367  CALL scopy( n, d, 1, d( n+1 ), 1 )
368  IF( n.GT.1 )
369  $ CALL scopy( n-1, e, 1, e( n+1 ), 1 )
370 *
371 *+ TEST 1
372 * Factor A as L*D*L' and compute the ratio
373 * norm(L*D*L' - A) / (n * norm(A) * EPS )
374 *
375  CALL spttrf( n, d( n+1 ), e( n+1 ), info )
376 *
377 * Check error code from SPTTRF.
378 *
379  IF( info.NE.izero ) THEN
380  CALL alaerh( path, 'SPTTRF', info, izero, ' ', n, n, -1,
381  $ -1, -1, imat, nfail, nerrs, nout )
382  GO TO 100
383  END IF
384 *
385  IF( info.GT.0 ) THEN
386  rcondc = zero
387  GO TO 90
388  END IF
389 *
390  CALL sptt01( n, d, e, d( n+1 ), e( n+1 ), work,
391  $ result( 1 ) )
392 *
393 * Print the test ratio if greater than or equal to THRESH.
394 *
395  IF( result( 1 ).GE.thresh ) THEN
396  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
397  $ CALL alahd( nout, path )
398  WRITE( nout, fmt = 9999 )n, imat, 1, result( 1 )
399  nfail = nfail + 1
400  END IF
401  nrun = nrun + 1
402 *
403 * Compute RCONDC = 1 / (norm(A) * norm(inv(A))
404 *
405 * Compute norm(A).
406 *
407  anorm = slanst( '1', n, d, e )
408 *
409 * Use SPTTRS to solve for one column at a time of inv(A),
410 * computing the maximum column sum as we go.
411 *
412  ainvnm = zero
413  DO 50 i = 1, n
414  DO 40 j = 1, n
415  x( j ) = zero
416  40 CONTINUE
417  x( i ) = one
418  CALL spttrs( n, 1, d( n+1 ), e( n+1 ), x, lda, info )
419  ainvnm = max( ainvnm, sasum( n, x, 1 ) )
420  50 CONTINUE
421  rcondc = one / max( one, anorm*ainvnm )
422 *
423  DO 80 irhs = 1, nns
424  nrhs = nsval( irhs )
425 *
426 * Generate NRHS random solution vectors.
427 *
428  ix = 1
429  DO 60 j = 1, nrhs
430  CALL slarnv( 2, iseed, n, xact( ix ) )
431  ix = ix + lda
432  60 CONTINUE
433 *
434 * Set the right hand side.
435 *
436  CALL slaptm( n, nrhs, one, d, e, xact, lda, zero, b,
437  $ lda )
438 *
439 *+ TEST 2
440 * Solve A*x = b and compute the residual.
441 *
442  CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
443  CALL spttrs( n, nrhs, d( n+1 ), e( n+1 ), x, lda, info )
444 *
445 * Check error code from SPTTRS.
446 *
447  IF( info.NE.0 )
448  $ CALL alaerh( path, 'SPTTRS', info, 0, ' ', n, n, -1,
449  $ -1, nrhs, imat, nfail, nerrs, nout )
450 *
451  CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
452  CALL sptt02( n, nrhs, d, e, x, lda, work, lda,
453  $ result( 2 ) )
454 *
455 *+ TEST 3
456 * Check solution from generated exact solution.
457 *
458  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
459  $ result( 3 ) )
460 *
461 *+ TESTS 4, 5, and 6
462 * Use iterative refinement to improve the solution.
463 *
464  srnamt = 'SPTRFS'
465  CALL sptrfs( n, nrhs, d, e, d( n+1 ), e( n+1 ), b, lda,
466  $ x, lda, rwork, rwork( nrhs+1 ), work, info )
467 *
468 * Check error code from SPTRFS.
469 *
470  IF( info.NE.0 )
471  $ CALL alaerh( path, 'SPTRFS', info, 0, ' ', n, n, -1,
472  $ -1, nrhs, imat, nfail, nerrs, nout )
473 *
474  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
475  $ result( 4 ) )
476  CALL sptt05( n, nrhs, d, e, b, lda, x, lda, xact, lda,
477  $ rwork, rwork( nrhs+1 ), result( 5 ) )
478 *
479 * Print information about the tests that did not pass the
480 * threshold.
481 *
482  DO 70 k = 2, 6
483  IF( result( k ).GE.thresh ) THEN
484  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
485  $ CALL alahd( nout, path )
486  WRITE( nout, fmt = 9998 )n, nrhs, imat, k,
487  $ result( k )
488  nfail = nfail + 1
489  END IF
490  70 CONTINUE
491  nrun = nrun + 5
492  80 CONTINUE
493 *
494 *+ TEST 7
495 * Estimate the reciprocal of the condition number of the
496 * matrix.
497 *
498  90 CONTINUE
499  srnamt = 'SPTCON'
500  CALL sptcon( n, d( n+1 ), e( n+1 ), anorm, rcond, rwork,
501  $ info )
502 *
503 * Check error code from SPTCON.
504 *
505  IF( info.NE.0 )
506  $ CALL alaerh( path, 'SPTCON', info, 0, ' ', n, n, -1, -1,
507  $ -1, imat, nfail, nerrs, nout )
508 *
509  result( 7 ) = sget06( rcond, rcondc )
510 *
511 * Print the test ratio if greater than or equal to THRESH.
512 *
513  IF( result( 7 ).GE.thresh ) THEN
514  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
515  $ CALL alahd( nout, path )
516  WRITE( nout, fmt = 9999 )n, imat, 7, result( 7 )
517  nfail = nfail + 1
518  END IF
519  nrun = nrun + 1
520  100 CONTINUE
521  110 CONTINUE
522 *
523 * Print a summary of the results.
524 *
525  CALL alasum( path, nout, nfail, nrun, nerrs )
526 *
527  9999 FORMAT( ' N =', i5, ', type ', i2, ', test ', i2, ', ratio = ',
528  $ g12.5 )
529  9998 FORMAT( ' N =', i5, ', NRHS=', i3, ', type ', i2, ', test(', i2,
530  $ ') = ', g12.5 )
531  RETURN
532 *
533 * End of SCHKPT
534 *
alahd
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:95
slanst
real function slanst(NORM, N, D, E)
SLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix.
Definition: slanst.f:102
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
sptt01
subroutine sptt01(N, D, E, DF, EF, WORK, RESID)
SPTT01
Definition: sptt01.f:93
slatb4
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
Definition: slatb4.f:122
spttrf
subroutine spttrf(N, D, E, INFO)
SPTTRF
Definition: spttrf.f:93
sptcon
subroutine sptcon(N, D, E, ANORM, RCOND, WORK, INFO)
SPTCON
Definition: sptcon.f:120
isamax
integer function isamax(N, SX, INCX)
ISAMAX
Definition: isamax.f:53
slarnv
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: slarnv.f:99
serrgt
subroutine serrgt(PATH, NUNIT)
SERRGT
Definition: serrgt.f:57
sget06
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:57
sptt02
subroutine sptt02(N, NRHS, D, E, X, LDX, B, LDB, RESID)
SPTT02
Definition: sptt02.f:106
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
slatms
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:323
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
sptrfs
subroutine sptrfs(N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, INFO)
SPTRFS
Definition: sptrfs.f:165
sptt05
subroutine sptt05(N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPTT05
Definition: sptt05.f:152
slaptm
subroutine slaptm(N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB)
SLAPTM
Definition: slaptm.f:118
sscal
subroutine sscal(N, SA, SX, INCX)
SSCAL
Definition: sscal.f:55
spttrs
subroutine spttrs(N, NRHS, D, E, B, LDB, INFO)
SPTTRS
Definition: spttrs.f:111
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: