LAPACK  3.9.1
LAPACK: Linear Algebra PACKage

◆ dchktp()

subroutine dchktp ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNS,
integer, dimension( * )  NSVAL,
double precision  THRESH,
logical  TSTERR,
integer  NMAX,
double precision, dimension( * )  AP,
double precision, dimension( * )  AINVP,
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 
)

DCHKTP

Purpose:
 DCHKTP tests DTPTRI, -TRS, -RFS, and -CON, and DLATPS
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 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.
[in]NMAX
          NMAX is INTEGER
          The leading dimension of the work arrays.  NMAX >= the
          maximumm value of N in NVAL.
[out]AP
          AP is DOUBLE PRECISION array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AINVP
          AINVP is DOUBLE PRECISION array, dimension
                      (NMAX*(NMAX+1)/2)
[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]IWORK
          IWORK is INTEGER array, dimension (NMAX)
[out]RWORK
          RWORK is DOUBLE PRECISION 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.

Definition at line 154 of file dchktp.f.

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