LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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.
Date
November 2011

Definition at line 165 of file dchkpp.f.

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

Here is the call graph for this function:

Here is the caller graph for this function: