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

SCHKTP

Purpose: 
 SCHKTP tests STPTRI, -TRS, -RFS, and -CON, and SLATPS
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 column 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.
[in]NMAX
          NMAX is INTEGER
          The leading dimension of the work arrays.  NMAX >= the
          maximumm value of N in NVAL.
[out]AP
          AP is REAL array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AINVP
          AINVP is REAL array, dimension
                      (NMAX*(NMAX+1)/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]IWORK
          IWORK is INTEGER array, dimension (NMAX)
[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 159 of file schktp.f.

159 *
160 * -- LAPACK test routine (version 3.4.0) --
161 * -- LAPACK is a software package provided by Univ. of Tennessee, --
162 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
163 * November 2011
164 *
165 * .. Scalar Arguments ..
166  LOGICAL tsterr
167  INTEGER nmax, nn, nns, nout
168  REAL thresh
169 * ..
170 * .. Array Arguments ..
171  LOGICAL dotype( * )
172  INTEGER iwork( * ), nsval( * ), nval( * )
173  REAL ainvp( * ), ap( * ), b( * ), rwork( * ),
174  $ work( * ), x( * ), xact( * )
175 * ..
176 *
177 * =====================================================================
178 *
179 * .. Parameters ..
180  INTEGER ntype1, ntypes
181  parameter ( ntype1 = 10, ntypes = 18 )
182  INTEGER ntests
183  parameter ( ntests = 9 )
184  INTEGER ntran
185  parameter ( ntran = 3 )
186  REAL one, zero
187  parameter ( one = 1.0e+0, zero = 0.0e+0 )
188 * ..
189 * .. Local Scalars ..
190  CHARACTER diag, norm, trans, uplo, xtype
191  CHARACTER*3 path
192  INTEGER i, idiag, imat, in, info, irhs, itran, iuplo,
193  $ k, lap, lda, n, nerrs, nfail, nrhs, nrun
194  REAL ainvnm, anorm, rcond, rcondc, rcondi, rcondo,
195  $ scale
196 * ..
197 * .. Local Arrays ..
198  CHARACTER transs( ntran ), uplos( 2 )
199  INTEGER iseed( 4 ), iseedy( 4 )
200  REAL result( ntests )
201 * ..
202 * .. External Functions ..
203  LOGICAL lsame
204  REAL slantp
205  EXTERNAL lsame, slantp
206 * ..
207 * .. External Subroutines ..
208  EXTERNAL alaerh, alahd, alasum, scopy, serrtr, sget04,
209  $ slacpy, slarhs, slatps, slattp, stpcon, stprfs,
210  $ stpt01, stpt02, stpt03, stpt05, stpt06, stptri,
211  $ stptrs
212 * ..
213 * .. Scalars in Common ..
214  LOGICAL lerr, ok
215  CHARACTER*32 srnamt
216  INTEGER infot, iounit
217 * ..
218 * .. Common blocks ..
219  COMMON / infoc / infot, iounit, ok, lerr
220  COMMON / srnamc / srnamt
221 * ..
222 * .. Intrinsic Functions ..
223  INTRINSIC max
224 * ..
225 * .. Data statements ..
226  DATA iseedy / 1988, 1989, 1990, 1991 /
227  DATA uplos / 'U', 'L' / , transs / 'N', 'T', 'C' /
228 * ..
229 * .. Executable Statements ..
230 *
231 * Initialize constants and the random number seed.
232 *
233  path( 1: 1 ) = 'Single precision'
234  path( 2: 3 ) = 'TP'
235  nrun = 0
236  nfail = 0
237  nerrs = 0
238  DO 10 i = 1, 4
239  iseed( i ) = iseedy( i )
240  10 CONTINUE
241 *
242 * Test the error exits
243 *
244  IF( tsterr )
245  $ CALL serrtr( path, nout )
246  infot = 0
247 *
248  DO 110 in = 1, nn
249 *
250 * Do for each value of N in NVAL
251 *
252  n = nval( in )
253  lda = max( 1, n )
254  lap = lda*( lda+1 ) / 2
255  xtype = 'N'
256 *
257  DO 70 imat = 1, ntype1
258 *
259 * Do the tests only if DOTYPE( IMAT ) is true.
260 *
261  IF( .NOT.dotype( imat ) )
262  $ GO TO 70
263 *
264  DO 60 iuplo = 1, 2
265 *
266 * Do first for UPLO = 'U', then for UPLO = 'L'
267 *
268  uplo = uplos( iuplo )
269 *
270 * Call SLATTP to generate a triangular test matrix.
271 *
272  srnamt = 'SLATTP'
273  CALL slattp( imat, uplo, 'No transpose', diag, iseed, n,
274  $ ap, x, work, info )
275 *
276 * Set IDIAG = 1 for non-unit matrices, 2 for unit.
277 *
278  IF( lsame( diag, 'N' ) ) THEN
279  idiag = 1
280  ELSE
281  idiag = 2
282  END IF
283 *
284 *+ TEST 1
285 * Form the inverse of A.
286 *
287  IF( n.GT.0 )
288  $ CALL scopy( lap, ap, 1, ainvp, 1 )
289  srnamt = 'STPTRI'
290  CALL stptri( uplo, diag, n, ainvp, info )
291 *
292 * Check error code from STPTRI.
293 *
294  IF( info.NE.0 )
295  $ CALL alaerh( path, 'STPTRI', info, 0, uplo // diag, n,
296  $ n, -1, -1, -1, imat, nfail, nerrs, nout )
297 *
298 * Compute the infinity-norm condition number of A.
299 *
300  anorm = slantp( 'I', uplo, diag, n, ap, rwork )
301  ainvnm = slantp( 'I', uplo, diag, n, ainvp, rwork )
302  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
303  rcondi = one
304  ELSE
305  rcondi = ( one / anorm ) / ainvnm
306  END IF
307 *
308 * Compute the residual for the triangular matrix times its
309 * inverse. Also compute the 1-norm condition number of A.
310 *
311  CALL stpt01( uplo, diag, n, ap, ainvp, rcondo, rwork,
312  $ result( 1 ) )
313 *
314 * Print the test ratio if it is .GE. THRESH.
315 *
316  IF( result( 1 ).GE.thresh ) THEN
317  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
318  $ CALL alahd( nout, path )
319  WRITE( nout, fmt = 9999 )uplo, diag, n, imat, 1,
320  $ result( 1 )
321  nfail = nfail + 1
322  END IF
323  nrun = nrun + 1
324 *
325  DO 40 irhs = 1, nns
326  nrhs = nsval( irhs )
327  xtype = 'N'
328 *
329  DO 30 itran = 1, ntran
330 *
331 * Do for op(A) = A, A**T, or A**H.
332 *
333  trans = transs( itran )
334  IF( itran.EQ.1 ) THEN
335  norm = 'O'
336  rcondc = rcondo
337  ELSE
338  norm = 'I'
339  rcondc = rcondi
340  END IF
341 *
342 *+ TEST 2
343 * Solve and compute residual for op(A)*x = b.
344 *
345  srnamt = 'SLARHS'
346  CALL slarhs( path, xtype, uplo, trans, n, n, 0,
347  $ idiag, nrhs, ap, lap, xact, lda, b,
348  $ lda, iseed, info )
349  xtype = 'C'
350  CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
351 *
352  srnamt = 'STPTRS'
353  CALL stptrs( uplo, trans, diag, n, nrhs, ap, x,
354  $ lda, info )
355 *
356 * Check error code from STPTRS.
357 *
358  IF( info.NE.0 )
359  $ CALL alaerh( path, 'STPTRS', info, 0,
360  $ uplo // trans // diag, n, n, -1,
361  $ -1, -1, imat, nfail, nerrs, nout )
362 *
363  CALL stpt02( uplo, trans, diag, n, nrhs, ap, x,
364  $ lda, b, lda, work, result( 2 ) )
365 *
366 *+ TEST 3
367 * Check solution from generated exact solution.
368 *
369  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
370  $ result( 3 ) )
371 *
372 *+ TESTS 4, 5, and 6
373 * Use iterative refinement to improve the solution and
374 * compute error bounds.
375 *
376  srnamt = 'STPRFS'
377  CALL stprfs( uplo, trans, diag, n, nrhs, ap, b,
378  $ lda, x, lda, rwork, rwork( nrhs+1 ),
379  $ work, iwork, info )
380 *
381 * Check error code from STPRFS.
382 *
383  IF( info.NE.0 )
384  $ CALL alaerh( path, 'STPRFS', info, 0,
385  $ uplo // trans // diag, n, n, -1,
386  $ -1, nrhs, imat, nfail, nerrs,
387  $ nout )
388 *
389  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
390  $ result( 4 ) )
391  CALL stpt05( uplo, trans, diag, n, nrhs, ap, b,
392  $ lda, x, lda, xact, lda, rwork,
393  $ rwork( nrhs+1 ), result( 5 ) )
394 *
395 * Print information about the tests that did not pass
396 * the threshold.
397 *
398  DO 20 k = 2, 6
399  IF( result( k ).GE.thresh ) THEN
400  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
401  $ CALL alahd( nout, path )
402  WRITE( nout, fmt = 9998 )uplo, trans, diag,
403  $ n, nrhs, imat, k, result( k )
404  nfail = nfail + 1
405  END IF
406  20 CONTINUE
407  nrun = nrun + 5
408  30 CONTINUE
409  40 CONTINUE
410 *
411 *+ TEST 7
412 * Get an estimate of RCOND = 1/CNDNUM.
413 *
414  DO 50 itran = 1, 2
415  IF( itran.EQ.1 ) THEN
416  norm = 'O'
417  rcondc = rcondo
418  ELSE
419  norm = 'I'
420  rcondc = rcondi
421  END IF
422 *
423  srnamt = 'STPCON'
424  CALL stpcon( norm, uplo, diag, n, ap, rcond, work,
425  $ iwork, info )
426 *
427 * Check error code from STPCON.
428 *
429  IF( info.NE.0 )
430  $ CALL alaerh( path, 'STPCON', info, 0,
431  $ norm // uplo // diag, n, n, -1, -1,
432  $ -1, imat, nfail, nerrs, nout )
433 *
434  CALL stpt06( rcond, rcondc, uplo, diag, n, ap, rwork,
435  $ result( 7 ) )
436 *
437 * Print the test ratio if it is .GE. THRESH.
438 *
439  IF( result( 7 ).GE.thresh ) THEN
440  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
441  $ CALL alahd( nout, path )
442  WRITE( nout, fmt = 9997 ) 'STPCON', norm, uplo,
443  $ diag, n, imat, 7, result( 7 )
444  nfail = nfail + 1
445  END IF
446  nrun = nrun + 1
447  50 CONTINUE
448  60 CONTINUE
449  70 CONTINUE
450 *
451 * Use pathological test matrices to test SLATPS.
452 *
453  DO 100 imat = ntype1 + 1, ntypes
454 *
455 * Do the tests only if DOTYPE( IMAT ) is true.
456 *
457  IF( .NOT.dotype( imat ) )
458  $ GO TO 100
459 *
460  DO 90 iuplo = 1, 2
461 *
462 * Do first for UPLO = 'U', then for UPLO = 'L'
463 *
464  uplo = uplos( iuplo )
465  DO 80 itran = 1, ntran
466 *
467 * Do for op(A) = A, A**T, or A**H.
468 *
469  trans = transs( itran )
470 *
471 * Call SLATTP to generate a triangular test matrix.
472 *
473  srnamt = 'SLATTP'
474  CALL slattp( imat, uplo, trans, diag, iseed, n, ap, x,
475  $ work, info )
476 *
477 *+ TEST 8
478 * Solve the system op(A)*x = b.
479 *
480  srnamt = 'SLATPS'
481  CALL scopy( n, x, 1, b, 1 )
482  CALL slatps( uplo, trans, diag, 'N', n, ap, b, scale,
483  $ rwork, info )
484 *
485 * Check error code from SLATPS.
486 *
487  IF( info.NE.0 )
488  $ CALL alaerh( path, 'SLATPS', info, 0,
489  $ uplo // trans // diag // 'N', n, n,
490  $ -1, -1, -1, imat, nfail, nerrs, nout )
491 *
492  CALL stpt03( uplo, trans, diag, n, 1, ap, scale,
493  $ rwork, one, b, lda, x, lda, work,
494  $ result( 8 ) )
495 *
496 *+ TEST 9
497 * Solve op(A)*x = b again with NORMIN = 'Y'.
498 *
499  CALL scopy( n, x, 1, b( n+1 ), 1 )
500  CALL slatps( uplo, trans, diag, 'Y', n, ap, b( n+1 ),
501  $ scale, rwork, info )
502 *
503 * Check error code from SLATPS.
504 *
505  IF( info.NE.0 )
506  $ CALL alaerh( path, 'SLATPS', info, 0,
507  $ uplo // trans // diag // 'Y', n, n,
508  $ -1, -1, -1, imat, nfail, nerrs, nout )
509 *
510  CALL stpt03( uplo, trans, diag, n, 1, ap, scale,
511  $ rwork, one, b( n+1 ), lda, x, lda, work,
512  $ result( 9 ) )
513 *
514 * Print information about the tests that did not pass
515 * the threshold.
516 *
517  IF( result( 8 ).GE.thresh ) THEN
518  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
519  $ CALL alahd( nout, path )
520  WRITE( nout, fmt = 9996 )'SLATPS', uplo, trans,
521  $ diag, 'N', n, imat, 8, result( 8 )
522  nfail = nfail + 1
523  END IF
524  IF( result( 9 ).GE.thresh ) THEN
525  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
526  $ CALL alahd( nout, path )
527  WRITE( nout, fmt = 9996 )'SLATPS', uplo, trans,
528  $ diag, 'Y', n, imat, 9, result( 9 )
529  nfail = nfail + 1
530  END IF
531  nrun = nrun + 2
532  80 CONTINUE
533  90 CONTINUE
534  100 CONTINUE
535  110 CONTINUE
536 *
537 * Print a summary of the results.
538 *
539  CALL alasum( path, nout, nfail, nrun, nerrs )
540 *
541  9999 FORMAT( ' UPLO=''', a1, ''', DIAG=''', a1, ''', N=', i5,
542  $ ', type ', i2, ', test(', i2, ')= ', g12.5 )
543  9998 FORMAT( ' UPLO=''', a1, ''', TRANS=''', a1, ''', DIAG=''', a1,
544  $ ''', N=', i5, ''', NRHS=', i5, ', type ', i2, ', test(',
545  $ i2, ')= ', g12.5 )
546  9997 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''',',
547  $ i5, ', ... ), type ', i2, ', test(', i2, ')=', g12.5 )
548  9996 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''', ''',
549  $ a1, ''',', i5, ', ... ), type ', i2, ', test(', i2, ')=',
550  $ g12.5 )
551  RETURN
552 *
553 * End of SCHKTP
554 *
alahd
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:95
slatps
subroutine slatps(UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO)
SLATPS solves a triangular system of equations with the matrix held in packed storage.
Definition: slatps.f:231
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
stptri
subroutine stptri(UPLO, DIAG, N, AP, INFO)
STPTRI
Definition: stptri.f:119
slattp
subroutine slattp(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK, INFO)
SLATTP
Definition: slattp.f:127
stpt03
subroutine stpt03(UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
STPT03
Definition: stpt03.f:163
stpt01
subroutine stpt01(UPLO, DIAG, N, AP, AINVP, RCOND, WORK, RESID)
STPT01
Definition: stpt01.f:110
slarhs
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
Definition: slarhs.f:206
stpcon
subroutine stpcon(NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, INFO)
STPCON
Definition: stpcon.f:132
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
stpt05
subroutine stpt05(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
STPT05
Definition: stpt05.f:176
serrtr
subroutine serrtr(PATH, NUNIT)
SERRTR
Definition: serrtr.f:57
sget04
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
Definition: sget04.f:104
slantp
real function slantp(NORM, UPLO, DIAG, N, AP, WORK)
SLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular matrix supplied in packed form.
Definition: slantp.f:126
stpt02
subroutine stpt02(UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB, WORK, RESID)
STPT02
Definition: stpt02.f:143
stpt06
subroutine stpt06(RCOND, RCONDC, UPLO, DIAG, N, AP, WORK, RAT)
STPT06
Definition: stpt06.f:113
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
stprfs
subroutine stprfs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
STPRFS
Definition: stprfs.f:177
scopy
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:53
stptrs
subroutine stptrs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO)
STPTRS
Definition: stptrs.f:132
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: