3 * =========== DOCUMENTATION ===========
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
11 * SUBROUTINE DCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
12 * NMAX, AP, AINVP, B, X, XACT, WORK, RWORK,
15 * .. Scalar Arguments ..
17 * INTEGER NMAX, NN, NNS, NOUT
18 * DOUBLE PRECISION THRESH
20 * .. Array Arguments ..
22 * INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
23 * DOUBLE PRECISION AINVP( * ), AP( * ), B( * ), RWORK( * ),
24 * $ WORK( * ), X( * ), XACT( * )
33 *> DCHKTP tests DTPTRI, -TRS, -RFS, and -CON, and DLATPS
41 *> DOTYPE is LOGICAL array, dimension (NTYPES)
42 *> The matrix types to be used for testing. Matrices of type j
43 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
44 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
50 *> The number of values of N contained in the vector NVAL.
55 *> NVAL is INTEGER array, dimension (NN)
56 *> The values of the matrix column dimension N.
62 *> The number of values of NRHS contained in the vector NSVAL.
67 *> NSVAL is INTEGER array, dimension (NNS)
68 *> The values of the number of right hand sides NRHS.
73 *> THRESH is DOUBLE PRECISION
74 *> The threshold value for the test ratios. A result is
75 *> included in the output file if RESULT >= THRESH. To have
76 *> every test ratio printed, use THRESH = 0.
82 *> Flag that indicates whether error exits are to be tested.
88 *> The leading dimension of the work arrays. NMAX >= the
89 *> maximumm value of N in NVAL.
94 *> AP is DOUBLE PRECISION array, dimension
100 *> AINVP is DOUBLE PRECISION array, dimension
106 *> B is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
107 *> where NSMAX is the largest entry in NSVAL.
112 *> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
117 *> XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
122 *> WORK is DOUBLE PRECISION array, dimension
123 *> (NMAX*max(3,NSMAX))
128 *> IWORK is INTEGER array, dimension (NMAX)
133 *> RWORK is DOUBLE PRECISION array, dimension
134 *> (max(NMAX,2*NSMAX))
140 *> The unit number for output.
146 *> \author Univ. of Tennessee
147 *> \author Univ. of California Berkeley
148 *> \author Univ. of Colorado Denver
151 *> \date November 2011
153 *> \ingroup double_lin
155 * =====================================================================
156 SUBROUTINE DCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
157 $ NMAX, AP, AINVP, B, X, XACT, WORK, RWORK,
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..--
165 * .. Scalar Arguments ..
167 INTEGER NMAX, NN, NNS, NOUT
168 DOUBLE PRECISION THRESH
170 * .. Array Arguments ..
172 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
173 DOUBLE PRECISION AINVP( * ), AP( * ), B( * ), RWORK( * ),
174 $ WORK( * ), X( * ), XACT( * )
177 * =====================================================================
180 INTEGER NTYPE1, NTYPES
181 PARAMETER ( NTYPE1 = 10, NTYPES = 18 )
183 PARAMETER ( NTESTS = 9 )
185 PARAMETER ( NTRAN = 3 )
186 DOUBLE PRECISION ONE, ZERO
187 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
189 * .. Local Scalars ..
190 CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
192 INTEGER I, IDIAG, IMAT, IN, INFO, IRHS, ITRAN, IUPLO,
193 $ K, LAP, LDA, N, NERRS, NFAIL, NRHS, NRUN
194 DOUBLE PRECISION AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
198 CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
199 INTEGER ISEED( 4 ), ISEEDY( 4 )
200 DOUBLE PRECISION RESULT( NTESTS )
202 * .. External Functions ..
204 DOUBLE PRECISION DLANTP
205 EXTERNAL LSAME, DLANTP
207 * .. External Subroutines ..
208 EXTERNAL ALAERH, ALAHD, ALASUM, DCOPY, DERRTR, DGET04,
209 $ DLACPY, DLARHS, DLATPS, DLATTP, DTPCON, DTPRFS,
210 $ DTPT01, DTPT02, DTPT03, DTPT05, DTPT06, DTPTRI,
213 * .. Scalars in Common ..
216 INTEGER INFOT, IOUNIT
218 * .. Common blocks ..
219 COMMON / INFOC / INFOT, IOUNIT, OK, LERR
220 COMMON / SRNAMC / SRNAMT
222 * .. Intrinsic Functions ..
225 * .. Data statements ..
226 DATA ISEEDY / 1988, 1989, 1990, 1991 /
227 DATA UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' /
229 * .. Executable Statements ..
231 * Initialize constants and the random number seed.
233 PATH( 1: 1 ) = 'Double precision'
239 ISEED( I ) = ISEEDY( I )
242 * Test the error exits
245 $ CALL DERRTR( PATH, NOUT )
250 * Do for each value of N in NVAL
254 LAP = LDA*( LDA+1 ) / 2
257 DO 70 IMAT = 1, NTYPE1
259 * Do the tests only if DOTYPE( IMAT ) is true.
261 IF( .NOT.DOTYPE( IMAT ) )
266 * Do first for UPLO = 'U', then for UPLO = 'L'
268 UPLO = UPLOS( IUPLO )
270 * Call DLATTP to generate a triangular test matrix.
273 CALL DLATTP( IMAT, UPLO, 'No transpose', DIAG, ISEED, N,
274 $ AP, X, WORK, INFO )
276 * Set IDIAG = 1 for non-unit matrices, 2 for unit.
278 IF( LSAME( DIAG, 'N' ) ) THEN
285 * Form the inverse of A.
288 $ CALL DCOPY( LAP, AP, 1, AINVP, 1 )
290 CALL DTPTRI( UPLO, DIAG, N, AINVP, INFO )
292 * Check error code from DTPTRI.
295 $ CALL ALAERH( PATH, 'DTPTRI', INFO, 0, UPLO // DIAG, N,
296 $ N, -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
298 * Compute the infinity-norm condition number of A.
300 ANORM = DLANTP( 'I', UPLO, DIAG, N, AP, RWORK )
301 AINVNM = DLANTP( 'I', UPLO, DIAG, N, AINVP, RWORK )
302 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
305 RCONDI = ( ONE / ANORM ) / AINVNM
308 * Compute the residual for the triangular matrix times its
309 * inverse. Also compute the 1-norm condition number of A.
311 CALL DTPT01( UPLO, DIAG, N, AP, AINVP, RCONDO, RWORK,
314 * Print the test ratio if it is .GE. THRESH.
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,
329 DO 30 ITRAN = 1, NTRAN
331 * Do for op(A) = A, A**T, or A**H.
333 TRANS = TRANSS( ITRAN )
334 IF( ITRAN.EQ.1 ) THEN
343 * Solve and compute residual for op(A)*x = b.
346 CALL DLARHS( PATH, XTYPE, UPLO, TRANS, N, N, 0,
347 $ IDIAG, NRHS, AP, LAP, XACT, LDA, B,
350 CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
353 CALL DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, X,
356 * Check error code from DTPTRS.
359 $ CALL ALAERH( PATH, 'DTPTRS', INFO, 0,
360 $ UPLO // TRANS // DIAG, N, N, -1,
361 $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
363 CALL DTPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X,
364 $ LDA, B, LDA, WORK, RESULT( 2 ) )
367 * Check solution from generated exact solution.
369 CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
373 * Use iterative refinement to improve the solution and
374 * compute error bounds.
377 CALL DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B,
378 $ LDA, X, LDA, RWORK, RWORK( NRHS+1 ),
379 $ WORK, IWORK, INFO )
381 * Check error code from DTPRFS.
384 $ CALL ALAERH( PATH, 'DTPRFS', INFO, 0,
385 $ UPLO // TRANS // DIAG, N, N, -1,
386 $ -1, NRHS, IMAT, NFAIL, NERRS,
389 CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
391 CALL DTPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B,
392 $ LDA, X, LDA, XACT, LDA, RWORK,
393 $ RWORK( NRHS+1 ), RESULT( 5 ) )
395 * Print information about the tests that did not pass
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 )
412 * Get an estimate of RCOND = 1/CNDNUM.
415 IF( ITRAN.EQ.1 ) THEN
424 CALL DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK,
427 * Check error code from DTPCON.
430 $ CALL ALAERH( PATH, 'DTPCON', INFO, 0,
431 $ NORM // UPLO // DIAG, N, N, -1, -1,
432 $ -1, IMAT, NFAIL, NERRS, NOUT )
434 CALL DTPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, RWORK,
437 * Print the test ratio if it is .GE. THRESH.
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 ) 'DTPCON', NORM, UPLO,
443 $ DIAG, N, IMAT, 7, RESULT( 7 )
451 * Use pathological test matrices to test DLATPS.
453 DO 100 IMAT = NTYPE1 + 1, NTYPES
455 * Do the tests only if DOTYPE( IMAT ) is true.
457 IF( .NOT.DOTYPE( IMAT ) )
462 * Do first for UPLO = 'U', then for UPLO = 'L'
464 UPLO = UPLOS( IUPLO )
465 DO 80 ITRAN = 1, NTRAN
467 * Do for op(A) = A, A**T, or A**H.
469 TRANS = TRANSS( ITRAN )
471 * Call DLATTP to generate a triangular test matrix.
474 CALL DLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, X,
478 * Solve the system op(A)*x = b.
481 CALL DCOPY( N, X, 1, B, 1 )
482 CALL DLATPS( UPLO, TRANS, DIAG, 'N', N, AP, B, SCALE,
485 * Check error code from DLATPS.
488 $ CALL ALAERH( PATH, 'DLATPS', INFO, 0,
489 $ UPLO // TRANS // DIAG // 'N', N, N,
490 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
492 CALL DTPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE,
493 $ RWORK, ONE, B, LDA, X, LDA, WORK,
497 * Solve op(A)*x = b again with NORMIN = 'Y'.
499 CALL DCOPY( N, X, 1, B( N+1 ), 1 )
500 CALL DLATPS( UPLO, TRANS, DIAG, 'Y', N, AP, B( N+1 ),
501 $ SCALE, RWORK, INFO )
503 * Check error code from DLATPS.
506 $ CALL ALAERH( PATH, 'DLATPS', INFO, 0,
507 $ UPLO // TRANS // DIAG // 'Y', N, N,
508 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
510 CALL DTPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE,
511 $ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK,
514 * Print information about the tests that did not pass
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 )'DLATPS', UPLO, TRANS,
521 $ DIAG, 'N', N, IMAT, 8, RESULT( 8 )
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 )'DLATPS', UPLO, TRANS,
528 $ DIAG, 'Y', N, IMAT, 9, RESULT( 9 )
537 * Print a summary of the results.
539 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
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(',
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, ')=',