LAPACK  3.7.1
LAPACK: Linear Algebra PACKage

◆ zchkpp()

subroutine zchkpp ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNS,
integer, dimension( * )  NSVAL,
double precision  THRESH,
logical  TSTERR,
integer  NMAX,
complex*16, dimension( * )  A,
complex*16, dimension( * )  AFAC,
complex*16, dimension( * )  AINV,
complex*16, dimension( * )  B,
complex*16, dimension( * )  X,
complex*16, dimension( * )  XACT,
complex*16, dimension( * )  WORK,
double precision, dimension( * )  RWORK,
integer  NOUT 
)

ZCHKPP

Purpose: 
 ZCHKPP tests ZPPTRF, -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 COMPLEX*16 array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AFAC
          AFAC is COMPLEX*16 array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AINV
          AINV is COMPLEX*16 array, dimension
                      (NMAX*(NMAX+1)/2)
[out]B
          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
          where NSMAX is the largest entry in NSVAL.
[out]X
          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
[out]XACT
          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
[out]WORK
          WORK is COMPLEX*16 array, dimension
                      (NMAX*max(3,NSMAX))
[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.
Date
December 2016

Definition at line 161 of file zchkpp.f.

161 *
162 * -- LAPACK test routine (version 3.7.0) --
163 * -- LAPACK is a software package provided by Univ. of Tennessee, --
164 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
165 * December 2016
166 *
167 * .. Scalar Arguments ..
168  LOGICAL tsterr
169  INTEGER nmax, nn, nns, nout
170  DOUBLE PRECISION thresh
171 * ..
172 * .. Array Arguments ..
173  LOGICAL dotype( * )
174  INTEGER nsval( * ), nval( * )
175  DOUBLE PRECISION rwork( * )
176  COMPLEX*16 a( * ), afac( * ), ainv( * ), b( * ),
177  $ 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, zlanhp
206  EXTERNAL dget06, zlanhp
207 * ..
208 * .. External Subroutines ..
209  EXTERNAL alaerh, alahd, alasum, zcopy, zerrpo, zget04,
210  $ zlacpy, zlaipd, zlarhs, zlatb4, zlatms, zppcon,
211  $ zpprfs, zppt01, zppt02, zppt03, zppt05, zpptrf,
212  $ zpptri, zpptrs
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 ) = 'Zomplex 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 zerrpo( 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 ZLATB4 and generate a test matrix
279 * with ZLATMS.
280 *
281  CALL zlatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
282  $ cndnum, dist )
283 *
284  srnamt = 'ZLATMS'
285  CALL zlatms( n, n, dist, iseed, TYPE, rwork, mode,
286  $ cndnum, anorm, kl, ku, packit, a, lda, work,
287  $ info )
288 *
289 * Check error code from ZLATMS.
290 *
291  IF( info.NE.0 ) THEN
292  CALL alaerh( path, 'ZLATMS', 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 * Set the imaginary part of the diagonals.
337 *
338  IF( iuplo.EQ.1 ) THEN
339  CALL zlaipd( n, a, 2, 1 )
340  ELSE
341  CALL zlaipd( n, a, n, -1 )
342  END IF
343 *
344 * Compute the L*L' or U'*U factorization of the matrix.
345 *
346  npp = n*( n+1 ) / 2
347  CALL zcopy( npp, a, 1, afac, 1 )
348  srnamt = 'ZPPTRF'
349  CALL zpptrf( uplo, n, afac, info )
350 *
351 * Check error code from ZPPTRF.
352 *
353  IF( info.NE.izero ) THEN
354  CALL alaerh( path, 'ZPPTRF', info, izero, uplo, n, n,
355  $ -1, -1, -1, imat, nfail, nerrs, nout )
356  GO TO 90
357  END IF
358 *
359 * Skip the tests if INFO is not 0.
360 *
361  IF( info.NE.0 )
362  $ GO TO 90
363 *
364 *+ TEST 1
365 * Reconstruct matrix from factors and compute residual.
366 *
367  CALL zcopy( npp, afac, 1, ainv, 1 )
368  CALL zppt01( uplo, n, a, ainv, rwork, result( 1 ) )
369 *
370 *+ TEST 2
371 * Form the inverse and compute the residual.
372 *
373  CALL zcopy( npp, afac, 1, ainv, 1 )
374  srnamt = 'ZPPTRI'
375  CALL zpptri( uplo, n, ainv, info )
376 *
377 * Check error code from ZPPTRI.
378 *
379  IF( info.NE.0 )
380  $ CALL alaerh( path, 'ZPPTRI', info, 0, uplo, n, n, -1,
381  $ -1, -1, imat, nfail, nerrs, nout )
382 *
383  CALL zppt03( uplo, n, a, ainv, work, lda, rwork, rcondc,
384  $ result( 2 ) )
385 *
386 * Print information about the tests that did not pass
387 * the threshold.
388 *
389  DO 60 k = 1, 2
390  IF( result( k ).GE.thresh ) THEN
391  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
392  $ CALL alahd( nout, path )
393  WRITE( nout, fmt = 9999 )uplo, n, imat, k,
394  $ result( k )
395  nfail = nfail + 1
396  END IF
397  60 CONTINUE
398  nrun = nrun + 2
399 *
400  DO 80 irhs = 1, nns
401  nrhs = nsval( irhs )
402 *
403 *+ TEST 3
404 * Solve and compute residual for A * X = B.
405 *
406  srnamt = 'ZLARHS'
407  CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
408  $ nrhs, a, lda, xact, lda, b, lda, iseed,
409  $ info )
410  CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
411 *
412  srnamt = 'ZPPTRS'
413  CALL zpptrs( uplo, n, nrhs, afac, x, lda, info )
414 *
415 * Check error code from ZPPTRS.
416 *
417  IF( info.NE.0 )
418  $ CALL alaerh( path, 'ZPPTRS', info, 0, uplo, n, n,
419  $ -1, -1, nrhs, imat, nfail, nerrs,
420  $ nout )
421 *
422  CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
423  CALL zppt02( uplo, n, nrhs, a, x, lda, work, lda,
424  $ rwork, result( 3 ) )
425 *
426 *+ TEST 4
427 * Check solution from generated exact solution.
428 *
429  CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
430  $ result( 4 ) )
431 *
432 *+ TESTS 5, 6, and 7
433 * Use iterative refinement to improve the solution.
434 *
435  srnamt = 'ZPPRFS'
436  CALL zpprfs( uplo, n, nrhs, a, afac, b, lda, x, lda,
437  $ rwork, rwork( nrhs+1 ), work,
438  $ rwork( 2*nrhs+1 ), info )
439 *
440 * Check error code from ZPPRFS.
441 *
442  IF( info.NE.0 )
443  $ CALL alaerh( path, 'ZPPRFS', info, 0, uplo, n, n,
444  $ -1, -1, nrhs, imat, nfail, nerrs,
445  $ nout )
446 *
447  CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
448  $ result( 5 ) )
449  CALL zppt05( uplo, n, nrhs, a, b, lda, x, lda, xact,
450  $ lda, rwork, rwork( nrhs+1 ),
451  $ result( 6 ) )
452 *
453 * Print information about the tests that did not pass
454 * the threshold.
455 *
456  DO 70 k = 3, 7
457  IF( result( k ).GE.thresh ) THEN
458  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
459  $ CALL alahd( nout, path )
460  WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
461  $ k, result( k )
462  nfail = nfail + 1
463  END IF
464  70 CONTINUE
465  nrun = nrun + 5
466  80 CONTINUE
467 *
468 *+ TEST 8
469 * Get an estimate of RCOND = 1/CNDNUM.
470 *
471  anorm = zlanhp( '1', uplo, n, a, rwork )
472  srnamt = 'ZPPCON'
473  CALL zppcon( uplo, n, afac, anorm, rcond, work, rwork,
474  $ info )
475 *
476 * Check error code from ZPPCON.
477 *
478  IF( info.NE.0 )
479  $ CALL alaerh( path, 'ZPPCON', info, 0, uplo, n, n, -1,
480  $ -1, -1, imat, nfail, nerrs, nout )
481 *
482  result( 8 ) = dget06( rcond, rcondc )
483 *
484 * Print the test ratio if greater than or equal to THRESH.
485 *
486  IF( result( 8 ).GE.thresh ) THEN
487  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
488  $ CALL alahd( nout, path )
489  WRITE( nout, fmt = 9999 )uplo, n, imat, 8,
490  $ result( 8 )
491  nfail = nfail + 1
492  END IF
493  nrun = nrun + 1
494 *
495  90 CONTINUE
496  100 CONTINUE
497  110 CONTINUE
498 *
499 * Print a summary of the results.
500 *
501  CALL alasum( path, nout, nfail, nrun, nerrs )
502 *
503  9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', type ', i2, ', test ',
504  $ i2, ', ratio =', g12.5 )
505  9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
506  $ i2, ', test(', i2, ') =', g12.5 )
507  RETURN
508 *
509 * End of ZCHKPP
510 *
alahd
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
zerrpo
subroutine zerrpo(PATH, NUNIT)
ZERRPO
Definition: zerrpo.f:57
zpptrs
subroutine zpptrs(UPLO, N, NRHS, AP, B, LDB, INFO)
ZPPTRS
Definition: zpptrs.f:110
zpptrf
subroutine zpptrf(UPLO, N, AP, INFO)
ZPPTRF
Definition: zpptrf.f:121
zget04
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
Definition: zget04.f:104
zcopy
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
Definition: zcopy.f:83
zppt02
subroutine zppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
ZPPT02
Definition: zppt02.f:125
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
zlacpy
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
Definition: zlacpy.f:105
zlatb4
subroutine zlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
ZLATB4
Definition: zlatb4.f:123
zppt05
subroutine zppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
ZPPT05
Definition: zppt05.f:159
zppt03
subroutine zppt03(UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, RESID)
ZPPT03
Definition: zppt03.f:112
zlaipd
subroutine zlaipd(N, A, INDA, VINDA)
ZLAIPD
Definition: zlaipd.f:85
zpptri
subroutine zpptri(UPLO, N, AP, INFO)
ZPPTRI
Definition: zpptri.f:95
zlatms
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
Definition: zlatms.f:334
dget06
double precision function dget06(RCOND, RCONDC)
DGET06
Definition: dget06.f:57
zlarhs
subroutine zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
Definition: zlarhs.f:211
zppt01
subroutine zppt01(UPLO, N, A, AFAC, RWORK, RESID)
ZPPT01
Definition: zppt01.f:97
zppcon
subroutine zppcon(UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO)
ZPPCON
Definition: zppcon.f:120
zlanhp
double precision function zlanhp(NORM, UPLO, N, AP, WORK)
ZLANHP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian matrix supplied in packed form.
Definition: zlanhp.f:119
alasum
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:75
zpprfs
subroutine zpprfs(UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZPPRFS
Definition: zpprfs.f:173
Here is the call graph for this function:
Here is the caller graph for this function: