LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cchkpp ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNS,
integer, dimension( * )  NSVAL,
real  THRESH,
logical  TSTERR,
integer  NMAX,
complex, dimension( * )  A,
complex, dimension( * )  AFAC,
complex, dimension( * )  AINV,
complex, dimension( * )  B,
complex, dimension( * )  X,
complex, dimension( * )  XACT,
complex, dimension( * )  WORK,
real, dimension( * )  RWORK,
integer  NOUT 
)

CCHKPP

Purpose: 
 CCHKPP tests CPPTRF, -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 REAL
          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 array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AFAC
          AFAC is COMPLEX array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AINV
          AINV is COMPLEX array, dimension
                      (NMAX*(NMAX+1)/2)
[out]B
          B is COMPLEX array, dimension (NMAX*NSMAX)
          where NSMAX is the largest entry in NSVAL.
[out]X
          X is COMPLEX array, dimension (NMAX*NSMAX)
[out]XACT
          XACT is COMPLEX array, dimension (NMAX*NSMAX)
[out]WORK
          WORK is COMPLEX array, dimension
                      (NMAX*max(3,NSMAX))
[out]RWORK
          RWORK is REAL 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
November 2011

Definition at line 161 of file cchkpp.f.

161 *
162 * -- LAPACK test routine (version 3.4.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 * November 2011
166 *
167 * .. Scalar Arguments ..
168  LOGICAL tsterr
169  INTEGER nmax, nn, nns, nout
170  REAL thresh
171 * ..
172 * .. Array Arguments ..
173  LOGICAL dotype( * )
174  INTEGER nsval( * ), nval( * )
175  REAL rwork( * )
176  COMPLEX a( * ), afac( * ), ainv( * ), b( * ),
177  $ work( * ), x( * ), xact( * )
178 * ..
179 *
180 * =====================================================================
181 *
182 * .. Parameters ..
183  REAL zero
184  parameter ( zero = 0.0e+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  REAL anorm, cndnum, rcond, rcondc
198 * ..
199 * .. Local Arrays ..
200  CHARACTER packs( 2 ), uplos( 2 )
201  INTEGER iseed( 4 ), iseedy( 4 )
202  REAL result( ntests )
203 * ..
204 * .. External Functions ..
205  REAL clanhp, sget06
206  EXTERNAL clanhp, sget06
207 * ..
208 * .. External Subroutines ..
209  EXTERNAL alaerh, alahd, alasum, ccopy, cerrpo, cget04,
210  $ clacpy, claipd, clarhs, clatb4, clatms, cppcon,
211  $ cpprfs, cppt01, cppt02, cppt03, cppt05, cpptrf,
212  $ cpptri, cpptrs
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 ) = 'Complex 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 cerrpo( 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 CLATB4 and generate a test matrix
279 * with CLATMS.
280 *
281  CALL clatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
282  $ cndnum, dist )
283 *
284  srnamt = 'CLATMS'
285  CALL clatms( n, n, dist, iseed, TYPE, rwork, mode,
286  $ cndnum, anorm, kl, ku, packit, a, lda, work,
287  $ info )
288 *
289 * Check error code from CLATMS.
290 *
291  IF( info.NE.0 ) THEN
292  CALL alaerh( path, 'CLATMS', 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 claipd( n, a, 2, 1 )
340  ELSE
341  CALL claipd( 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 ccopy( npp, a, 1, afac, 1 )
348  srnamt = 'CPPTRF'
349  CALL cpptrf( uplo, n, afac, info )
350 *
351 * Check error code from CPPTRF.
352 *
353  IF( info.NE.izero ) THEN
354  CALL alaerh( path, 'CPPTRF', 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 ccopy( npp, afac, 1, ainv, 1 )
368  CALL cppt01( uplo, n, a, ainv, rwork, result( 1 ) )
369 *
370 *+ TEST 2
371 * Form the inverse and compute the residual.
372 *
373  CALL ccopy( npp, afac, 1, ainv, 1 )
374  srnamt = 'CPPTRI'
375  CALL cpptri( uplo, n, ainv, info )
376 *
377 * Check error code from CPPTRI.
378 *
379  IF( info.NE.0 )
380  $ CALL alaerh( path, 'CPPTRI', info, 0, uplo, n, n, -1,
381  $ -1, -1, imat, nfail, nerrs, nout )
382 *
383  CALL cppt03( 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 = 'CLARHS'
407  CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
408  $ nrhs, a, lda, xact, lda, b, lda, iseed,
409  $ info )
410  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
411 *
412  srnamt = 'CPPTRS'
413  CALL cpptrs( uplo, n, nrhs, afac, x, lda, info )
414 *
415 * Check error code from CPPTRS.
416 *
417  IF( info.NE.0 )
418  $ CALL alaerh( path, 'CPPTRS', info, 0, uplo, n, n,
419  $ -1, -1, nrhs, imat, nfail, nerrs,
420  $ nout )
421 *
422  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
423  CALL cppt02( 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 cget04( 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 = 'CPPRFS'
436  CALL cpprfs( 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 CPPRFS.
441 *
442  IF( info.NE.0 )
443  $ CALL alaerh( path, 'CPPRFS', info, 0, uplo, n, n,
444  $ -1, -1, nrhs, imat, nfail, nerrs,
445  $ nout )
446 *
447  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
448  $ result( 5 ) )
449  CALL cppt05( 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 = clanhp( '1', uplo, n, a, rwork )
472  srnamt = 'CPPCON'
473  CALL cppcon( uplo, n, afac, anorm, rcond, work, rwork,
474  $ info )
475 *
476 * Check error code from CPPCON.
477 *
478  IF( info.NE.0 )
479  $ CALL alaerh( path, 'CPPCON', info, 0, uplo, n, n, -1,
480  $ -1, -1, imat, nfail, nerrs, nout )
481 *
482  result( 8 ) = sget06( 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 CCHKPP
510 *
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
clarhs
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
Definition: clarhs.f:211
cpptrs
subroutine cpptrs(UPLO, N, NRHS, AP, B, LDB, INFO)
CPPTRS
Definition: cpptrs.f:110
claipd
subroutine claipd(N, A, INDA, VINDA)
CLAIPD
Definition: claipd.f:85
cppt01
subroutine cppt01(UPLO, N, A, AFAC, RWORK, RESID)
CPPT01
Definition: cppt01.f:97
cppt05
subroutine cppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPPT05
Definition: cppt05.f:159
cpptrf
subroutine cpptrf(UPLO, N, AP, INFO)
CPPTRF
Definition: cpptrf.f:121
cppt03
subroutine cppt03(UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, RESID)
CPPT03
Definition: cppt03.f:112
sget06
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:57
cppcon
subroutine cppcon(UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO)
CPPCON
Definition: cppcon.f:120
cppt02
subroutine cppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
CPPT02
Definition: cppt02.f:125
cpptri
subroutine cpptri(UPLO, N, AP, INFO)
CPPTRI
Definition: cpptri.f:95
clatms
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:334
cpprfs
subroutine cpprfs(UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CPPRFS
Definition: cpprfs.f:173
clacpy
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:105
ccopy
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:52
clanhp
real function clanhp(NORM, UPLO, N, AP, WORK)
CLANHP 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: clanhp.f:119
clatb4
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:123
cget04
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:104
cerrpo
subroutine cerrpo(PATH, NUNIT)
CERRPO
Definition: cerrpo.f:57
alasum
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:75

Here is the call graph for this function:

Here is the caller graph for this function: