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

◆ dchkpp()

subroutine dchkpp ( logical, dimension( * )  dotype,
integer  nn,
integer, dimension( * )  nval,
integer  nns,
integer, dimension( * )  nsval,
double precision  thresh,
logical  tsterr,
integer  nmax,
double precision, dimension( * )  a,
double precision, dimension( * )  afac,
double precision, dimension( * )  ainv,
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 
)

DCHKPP

Purpose:
 DCHKPP tests DPPTRF, -TRI, -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 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 maximum value permitted for N, used in dimensioning the
          work arrays.
[out]A
          A is DOUBLE PRECISION array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AFAC
          AFAC is DOUBLE PRECISION array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AINV
          AINV 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]RWORK
          RWORK is DOUBLE PRECISION array, dimension
                      (max(NMAX,2*NSMAX))
[out]IWORK
          IWORK is INTEGER array, dimension (NMAX)
[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 160 of file dchkpp.f.

163*
164* -- LAPACK test routine --
165* -- LAPACK is a software package provided by Univ. of Tennessee, --
166* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
167*
168* .. Scalar Arguments ..
169 LOGICAL TSTERR
170 INTEGER NMAX, NN, NNS, NOUT
171 DOUBLE PRECISION THRESH
172* ..
173* .. Array Arguments ..
174 LOGICAL DOTYPE( * )
175 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
176 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
177 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 DOUBLE PRECISION ZERO
184 parameter( zero = 0.0d+0 )
185 INTEGER NTYPES
186 parameter( ntypes = 9 )
187 INTEGER NTESTS
188 parameter( ntests = 8 )
189* ..
190* .. Local Scalars ..
191 LOGICAL ZEROT
192 CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
193 CHARACTER*3 PATH
194 INTEGER I, IMAT, IN, INFO, IOFF, IRHS, IUPLO, IZERO, K,
195 $ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT, NPP,
196 $ NRHS, NRUN
197 DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
198* ..
199* .. Local Arrays ..
200 CHARACTER PACKS( 2 ), UPLOS( 2 )
201 INTEGER ISEED( 4 ), ISEEDY( 4 )
202 DOUBLE PRECISION RESULT( NTESTS )
203* ..
204* .. External Functions ..
205 DOUBLE PRECISION DGET06, DLANSP
206 EXTERNAL dget06, dlansp
207* ..
208* .. External Subroutines ..
209 EXTERNAL alaerh, alahd, alasum, dcopy, derrpo, dget04,
210 $ dlacpy, dlarhs, dlatb4, dlatms, dppcon, dpprfs,
211 $ dppt01, dppt02, dppt03, dppt05, dpptrf, dpptri,
212 $ dpptrs
213* ..
214* .. Scalars in Common ..
215 LOGICAL LERR, OK
216 CHARACTER*32 SRNAMT
217 INTEGER INFOT, NUNIT
218* ..
219* .. Common blocks ..
220 COMMON / infoc / infot, nunit, ok, lerr
221 COMMON / srnamc / srnamt
222* ..
223* .. Intrinsic Functions ..
224 INTRINSIC max
225* ..
226* .. Data statements ..
227 DATA iseedy / 1988, 1989, 1990, 1991 /
228 DATA uplos / 'U', 'L' / , packs / 'C', 'R' /
229* ..
230* .. Executable Statements ..
231*
232* Initialize constants and the random number seed.
233*
234 path( 1: 1 ) = 'Double precision'
235 path( 2: 3 ) = 'PP'
236 nrun = 0
237 nfail = 0
238 nerrs = 0
239 DO 10 i = 1, 4
240 iseed( i ) = iseedy( i )
241 10 CONTINUE
242*
243* Test the error exits
244*
245 IF( tsterr )
246 $ CALL derrpo( path, nout )
247 infot = 0
248*
249* Do for each value of N in NVAL
250*
251 DO 110 in = 1, nn
252 n = nval( in )
253 lda = max( n, 1 )
254 xtype = 'N'
255 nimat = ntypes
256 IF( n.LE.0 )
257 $ nimat = 1
258*
259 DO 100 imat = 1, nimat
260*
261* Do the tests only if DOTYPE( IMAT ) is true.
262*
263 IF( .NOT.dotype( imat ) )
264 $ GO TO 100
265*
266* Skip types 3, 4, or 5 if the matrix size is too small.
267*
268 zerot = imat.GE.3 .AND. imat.LE.5
269 IF( zerot .AND. n.LT.imat-2 )
270 $ GO TO 100
271*
272* Do first for UPLO = 'U', then for UPLO = 'L'
273*
274 DO 90 iuplo = 1, 2
275 uplo = uplos( iuplo )
276 packit = packs( iuplo )
277*
278* Set up parameters with DLATB4 and generate a test matrix
279* with DLATMS.
280*
281 CALL dlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
282 $ CNDNUM, DIST )
283*
284 srnamt = 'DLATMS'
285 CALL dlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
286 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
287 $ INFO )
288*
289* Check error code from DLATMS.
290*
291 IF( info.NE.0 ) THEN
292 CALL alaerh( path, 'DLATMS', info, 0, uplo, n, n, -1,
293 $ -1, -1, imat, nfail, nerrs, nout )
294 GO TO 90
295 END IF
296*
297* For types 3-5, zero one row and column of the matrix to
298* test that INFO is returned correctly.
299*
300 IF( zerot ) THEN
301 IF( imat.EQ.3 ) THEN
302 izero = 1
303 ELSE IF( imat.EQ.4 ) THEN
304 izero = n
305 ELSE
306 izero = n / 2 + 1
307 END IF
308*
309* Set row and column IZERO of A to 0.
310*
311 IF( iuplo.EQ.1 ) THEN
312 ioff = ( izero-1 )*izero / 2
313 DO 20 i = 1, izero - 1
314 a( ioff+i ) = zero
315 20 CONTINUE
316 ioff = ioff + izero
317 DO 30 i = izero, n
318 a( ioff ) = zero
319 ioff = ioff + i
320 30 CONTINUE
321 ELSE
322 ioff = izero
323 DO 40 i = 1, izero - 1
324 a( ioff ) = zero
325 ioff = ioff + n - i
326 40 CONTINUE
327 ioff = ioff - izero
328 DO 50 i = izero, n
329 a( ioff+i ) = zero
330 50 CONTINUE
331 END IF
332 ELSE
333 izero = 0
334 END IF
335*
336* Compute the L*L' or U'*U factorization of the matrix.
337*
338 npp = n*( n+1 ) / 2
339 CALL dcopy( npp, a, 1, afac, 1 )
340 srnamt = 'DPPTRF'
341 CALL dpptrf( uplo, n, afac, info )
342*
343* Check error code from DPPTRF.
344*
345 IF( info.NE.izero ) THEN
346 CALL alaerh( path, 'DPPTRF', info, izero, uplo, n, n,
347 $ -1, -1, -1, imat, nfail, nerrs, nout )
348 GO TO 90
349 END IF
350*
351* Skip the tests if INFO is not 0.
352*
353 IF( info.NE.0 )
354 $ GO TO 90
355*
356*+ TEST 1
357* Reconstruct matrix from factors and compute residual.
358*
359 CALL dcopy( npp, afac, 1, ainv, 1 )
360 CALL dppt01( uplo, n, a, ainv, rwork, result( 1 ) )
361*
362*+ TEST 2
363* Form the inverse and compute the residual.
364*
365 CALL dcopy( npp, afac, 1, ainv, 1 )
366 srnamt = 'DPPTRI'
367 CALL dpptri( uplo, n, ainv, info )
368*
369* Check error code from DPPTRI.
370*
371 IF( info.NE.0 )
372 $ CALL alaerh( path, 'DPPTRI', info, 0, uplo, n, n, -1,
373 $ -1, -1, imat, nfail, nerrs, nout )
374*
375 CALL dppt03( uplo, n, a, ainv, work, lda, rwork, rcondc,
376 $ result( 2 ) )
377*
378* Print information about the tests that did not pass
379* the threshold.
380*
381 DO 60 k = 1, 2
382 IF( result( k ).GE.thresh ) THEN
383 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
384 $ CALL alahd( nout, path )
385 WRITE( nout, fmt = 9999 )uplo, n, imat, k,
386 $ result( k )
387 nfail = nfail + 1
388 END IF
389 60 CONTINUE
390 nrun = nrun + 2
391*
392 DO 80 irhs = 1, nns
393 nrhs = nsval( irhs )
394*
395*+ TEST 3
396* Solve and compute residual for A * X = B.
397*
398 srnamt = 'DLARHS'
399 CALL dlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
400 $ nrhs, a, lda, xact, lda, b, lda, iseed,
401 $ info )
402 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
403*
404 srnamt = 'DPPTRS'
405 CALL dpptrs( uplo, n, nrhs, afac, x, lda, info )
406*
407* Check error code from DPPTRS.
408*
409 IF( info.NE.0 )
410 $ CALL alaerh( path, 'DPPTRS', info, 0, uplo, n, n,
411 $ -1, -1, nrhs, imat, nfail, nerrs,
412 $ nout )
413*
414 CALL dlacpy( 'Full', n, nrhs, b, lda, work, lda )
415 CALL dppt02( uplo, n, nrhs, a, x, lda, work, lda,
416 $ rwork, result( 3 ) )
417*
418*+ TEST 4
419* Check solution from generated exact solution.
420*
421 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
422 $ result( 4 ) )
423*
424*+ TESTS 5, 6, and 7
425* Use iterative refinement to improve the solution.
426*
427 srnamt = 'DPPRFS'
428 CALL dpprfs( uplo, n, nrhs, a, afac, b, lda, x, lda,
429 $ rwork, rwork( nrhs+1 ), work, iwork,
430 $ info )
431*
432* Check error code from DPPRFS.
433*
434 IF( info.NE.0 )
435 $ CALL alaerh( path, 'DPPRFS', info, 0, uplo, n, n,
436 $ -1, -1, nrhs, imat, nfail, nerrs,
437 $ nout )
438*
439 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
440 $ result( 5 ) )
441 CALL dppt05( uplo, n, nrhs, a, b, lda, x, lda, xact,
442 $ lda, rwork, rwork( nrhs+1 ),
443 $ result( 6 ) )
444*
445* Print information about the tests that did not pass
446* the threshold.
447*
448 DO 70 k = 3, 7
449 IF( result( k ).GE.thresh ) THEN
450 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
451 $ CALL alahd( nout, path )
452 WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
453 $ k, result( k )
454 nfail = nfail + 1
455 END IF
456 70 CONTINUE
457 nrun = nrun + 5
458 80 CONTINUE
459*
460*+ TEST 8
461* Get an estimate of RCOND = 1/CNDNUM.
462*
463 anorm = dlansp( '1', uplo, n, a, rwork )
464 srnamt = 'DPPCON'
465 CALL dppcon( uplo, n, afac, anorm, rcond, work, iwork,
466 $ info )
467*
468* Check error code from DPPCON.
469*
470 IF( info.NE.0 )
471 $ CALL alaerh( path, 'DPPCON', info, 0, uplo, n, n, -1,
472 $ -1, -1, imat, nfail, nerrs, nout )
473*
474 result( 8 ) = dget06( rcond, rcondc )
475*
476* Print the test ratio if greater than or equal to THRESH.
477*
478 IF( result( 8 ).GE.thresh ) THEN
479 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
480 $ CALL alahd( nout, path )
481 WRITE( nout, fmt = 9999 )uplo, n, imat, 8,
482 $ result( 8 )
483 nfail = nfail + 1
484 END IF
485 nrun = nrun + 1
486 90 CONTINUE
487 100 CONTINUE
488 110 CONTINUE
489*
490* Print a summary of the results.
491*
492 CALL alasum( path, nout, nfail, nrun, nerrs )
493*
494 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', type ', i2, ', test ',
495 $ i2, ', ratio =', g12.5 )
496 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
497 $ i2, ', test(', i2, ') =', g12.5 )
498 RETURN
499*
500* End of DCHKPP
501*
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
derrpo
subroutine derrpo(path, nunit)
DERRPO
Definition derrpo.f:55
dget04
subroutine dget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
DGET04
Definition dget04.f:102
dget06
double precision function dget06(rcond, rcondc)
DGET06
Definition dget06.f:55
dlatb4
subroutine dlatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
DLATB4
Definition dlatb4.f:120
dlatms
subroutine dlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
DLATMS
Definition dlatms.f:321
dppt01
subroutine dppt01(uplo, n, a, afac, rwork, resid)
DPPT01
Definition dppt01.f:93
dppt02
subroutine dppt02(uplo, n, nrhs, a, x, ldx, b, ldb, rwork, resid)
DPPT02
Definition dppt02.f:122
dppt03
subroutine dppt03(uplo, n, a, ainv, work, ldwork, rwork, rcond, resid)
DPPT03
Definition dppt03.f:110
dppt05
subroutine dppt05(uplo, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
DPPT05
Definition dppt05.f:156
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
dlansp
double precision function dlansp(norm, uplo, n, ap, work)
DLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlansp.f:114
dppcon
subroutine dppcon(uplo, n, ap, anorm, rcond, work, iwork, info)
DPPCON
Definition dppcon.f:118
dpprfs
subroutine dpprfs(uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr, work, iwork, info)
DPPRFS
Definition dpprfs.f:171
dpptrf
subroutine dpptrf(uplo, n, ap, info)
DPPTRF
Definition dpptrf.f:119
dpptri
subroutine dpptri(uplo, n, ap, info)
DPPTRI
Definition dpptri.f:93
dpptrs
subroutine dpptrs(uplo, n, nrhs, ap, b, ldb, info)
DPPTRS
Definition dpptrs.f:108
Here is the call graph for this function:
Here is the caller graph for this function: