LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ 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
          maximum 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*
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
dlarhs
subroutine dlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
DLARHS
Definition dlarhs.f:205
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
alahd
subroutine alahd(iounit, path)
ALAHD
Definition alahd.f:107
derrtr
subroutine derrtr(path, nunit)
DERRTR
Definition derrtr.f:55
dget04
subroutine dget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
DGET04
Definition dget04.f:102
dlattp
subroutine dlattp(imat, uplo, trans, diag, iseed, n, a, b, work, info)
DLATTP
Definition dlattp.f:125
dtpt01
subroutine dtpt01(uplo, diag, n, ap, ainvp, rcond, work, resid)
DTPT01
Definition dtpt01.f:108
dtpt02
subroutine dtpt02(uplo, trans, diag, n, nrhs, ap, x, ldx, b, ldb, work, resid)
DTPT02
Definition dtpt02.f:142
dtpt03
subroutine dtpt03(uplo, trans, diag, n, nrhs, ap, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
DTPT03
Definition dtpt03.f:161
dtpt05
subroutine dtpt05(uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
DTPT05
Definition dtpt05.f:174
dtpt06
subroutine dtpt06(rcond, rcondc, uplo, diag, n, ap, work, rat)
DTPT06
Definition dtpt06.f:111
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82
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
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
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
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
dtptri
subroutine dtptri(uplo, diag, n, ap, info)
DTPTRI
Definition dtptri.f:117
dtptrs
subroutine dtptrs(uplo, trans, diag, n, nrhs, ap, b, ldb, info)
DTPTRS
Definition dtptrs.f:130
Here is the call graph for this function:
Here is the caller graph for this function: