LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ 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 *
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
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:205
dppt02
subroutine dppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
DPPT02
Definition: dppt02.f:122
dget04
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
Definition: dget04.f:102
dppt01
subroutine dppt01(UPLO, N, A, AFAC, RWORK, RESID)
DPPT01
Definition: dppt01.f:93
derrpo
subroutine derrpo(PATH, NUNIT)
DERRPO
Definition: derrpo.f:55
dppt03
subroutine dppt03(UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, RESID)
DPPT03
Definition: dppt03.f:110
dlatb4
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
Definition: dlatb4.f:120
dppt05
subroutine dppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DPPT05
Definition: dppt05.f:156
dget06
double precision function dget06(RCOND, RCONDC)
DGET06
Definition: dget06.f:55
dlatms
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
Definition: dlatms.f:321
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
dpptrf
subroutine dpptrf(UPLO, N, AP, INFO)
DPPTRF
Definition: dpptrf.f:119
dpprfs
subroutine dpprfs(UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DPPRFS
Definition: dpprfs.f:171
dppcon
subroutine dppcon(UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO)
DPPCON
Definition: dppcon.f:118
dpptrs
subroutine dpptrs(UPLO, N, NRHS, AP, B, LDB, INFO)
DPPTRS
Definition: dpptrs.f:108
dpptri
subroutine dpptri(UPLO, N, AP, INFO)
DPPTRI
Definition: dpptri.f:93
Here is the call graph for this function:
Here is the caller graph for this function: