LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cchkhp ( 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, dimension( * )  IWORK,
integer  NOUT 
)

CCHKHP

Purpose: 
 CCHKHP tests CHPTRF, -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(2,NSMAX))
[out]RWORK
          RWORK is REAL array,
                                 dimension (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 166 of file cchkhp.f.

166 *
167 * -- LAPACK test routine (version 3.4.0) --
168 * -- LAPACK is a software package provided by Univ. of Tennessee, --
169 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
170 * November 2011
171 *
172 * .. Scalar Arguments ..
173  LOGICAL tsterr
174  INTEGER nmax, nn, nns, nout
175  REAL thresh
176 * ..
177 * .. Array Arguments ..
178  LOGICAL dotype( * )
179  INTEGER iwork( * ), nsval( * ), nval( * )
180  REAL rwork( * )
181  COMPLEX a( * ), afac( * ), ainv( * ), b( * ),
182  $ work( * ), x( * ), xact( * )
183 * ..
184 *
185 * =====================================================================
186 *
187 * .. Parameters ..
188  REAL zero
189  parameter ( zero = 0.0e+0 )
190  INTEGER ntypes
191  parameter ( ntypes = 10 )
192  INTEGER ntests
193  parameter ( ntests = 8 )
194 * ..
195 * .. Local Scalars ..
196  LOGICAL trfcon, zerot
197  CHARACTER dist, packit, TYPE, uplo, xtype
198  CHARACTER*3 path
199  INTEGER i, i1, i2, imat, in, info, ioff, irhs, iuplo,
200  $ izero, j, k, kl, ku, lda, mode, n, nerrs,
201  $ nfail, nimat, npp, nrhs, nrun, nt
202  REAL anorm, cndnum, rcond, rcondc
203 * ..
204 * .. Local Arrays ..
205  CHARACTER uplos( 2 )
206  INTEGER iseed( 4 ), iseedy( 4 )
207  REAL result( ntests )
208 * ..
209 * .. External Functions ..
210  LOGICAL lsame
211  REAL clanhp, sget06
212  EXTERNAL lsame, clanhp, sget06
213 * ..
214 * .. External Subroutines ..
215  EXTERNAL alaerh, alahd, alasum, ccopy, cerrsy, cget04,
216  $ chpcon, chprfs, chpt01, chptrf, chptri, chptrs,
217  $ clacpy, claipd, clarhs, clatb4, clatms, cppt02,
218  $ cppt03, cppt05
219 * ..
220 * .. Intrinsic Functions ..
221  INTRINSIC max, min
222 * ..
223 * .. Scalars in Common ..
224  LOGICAL lerr, ok
225  CHARACTER*32 srnamt
226  INTEGER infot, nunit
227 * ..
228 * .. Common blocks ..
229  COMMON / infoc / infot, nunit, ok, lerr
230  COMMON / srnamc / srnamt
231 * ..
232 * .. Data statements ..
233  DATA iseedy / 1988, 1989, 1990, 1991 /
234  DATA uplos / 'U', 'L' /
235 * ..
236 * .. Executable Statements ..
237 *
238 * Initialize constants and the random number seed.
239 *
240  path( 1: 1 ) = 'Complex precision'
241  path( 2: 3 ) = 'HP'
242  nrun = 0
243  nfail = 0
244  nerrs = 0
245  DO 10 i = 1, 4
246  iseed( i ) = iseedy( i )
247  10 CONTINUE
248 *
249 * Test the error exits
250 *
251  IF( tsterr )
252  $ CALL cerrsy( path, nout )
253  infot = 0
254 *
255 * Do for each value of N in NVAL
256 *
257  DO 170 in = 1, nn
258  n = nval( in )
259  lda = max( n, 1 )
260  xtype = 'N'
261  nimat = ntypes
262  IF( n.LE.0 )
263  $ nimat = 1
264 *
265  izero = 0
266  DO 160 imat = 1, nimat
267 *
268 * Do the tests only if DOTYPE( IMAT ) is true.
269 *
270  IF( .NOT.dotype( imat ) )
271  $ GO TO 160
272 *
273 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
274 *
275  zerot = imat.GE.3 .AND. imat.LE.6
276  IF( zerot .AND. n.LT.imat-2 )
277  $ GO TO 160
278 *
279 * Do first for UPLO = 'U', then for UPLO = 'L'
280 *
281  DO 150 iuplo = 1, 2
282  uplo = uplos( iuplo )
283  IF( lsame( uplo, 'U' ) ) THEN
284  packit = 'C'
285  ELSE
286  packit = 'R'
287  END IF
288 *
289 * Set up parameters with CLATB4 and generate a test matrix
290 * with CLATMS.
291 *
292  CALL clatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
293  $ cndnum, dist )
294 *
295  srnamt = 'CLATMS'
296  CALL clatms( n, n, dist, iseed, TYPE, rwork, mode,
297  $ cndnum, anorm, kl, ku, packit, a, lda, work,
298  $ info )
299 *
300 * Check error code from CLATMS.
301 *
302  IF( info.NE.0 ) THEN
303  CALL alaerh( path, 'CLATMS', info, 0, uplo, n, n, -1,
304  $ -1, -1, imat, nfail, nerrs, nout )
305  GO TO 150
306  END IF
307 *
308 * For types 3-6, zero one or more rows and columns of
309 * the matrix to test that INFO is returned correctly.
310 *
311  IF( zerot ) THEN
312  IF( imat.EQ.3 ) THEN
313  izero = 1
314  ELSE IF( imat.EQ.4 ) THEN
315  izero = n
316  ELSE
317  izero = n / 2 + 1
318  END IF
319 *
320  IF( imat.LT.6 ) THEN
321 *
322 * Set row and column IZERO to zero.
323 *
324  IF( iuplo.EQ.1 ) THEN
325  ioff = ( izero-1 )*izero / 2
326  DO 20 i = 1, izero - 1
327  a( ioff+i ) = zero
328  20 CONTINUE
329  ioff = ioff + izero
330  DO 30 i = izero, n
331  a( ioff ) = zero
332  ioff = ioff + i
333  30 CONTINUE
334  ELSE
335  ioff = izero
336  DO 40 i = 1, izero - 1
337  a( ioff ) = zero
338  ioff = ioff + n - i
339  40 CONTINUE
340  ioff = ioff - izero
341  DO 50 i = izero, n
342  a( ioff+i ) = zero
343  50 CONTINUE
344  END IF
345  ELSE
346  ioff = 0
347  IF( iuplo.EQ.1 ) THEN
348 *
349 * Set the first IZERO rows and columns to zero.
350 *
351  DO 70 j = 1, n
352  i2 = min( j, izero )
353  DO 60 i = 1, i2
354  a( ioff+i ) = zero
355  60 CONTINUE
356  ioff = ioff + j
357  70 CONTINUE
358  ELSE
359 *
360 * Set the last IZERO rows and columns to zero.
361 *
362  DO 90 j = 1, n
363  i1 = max( j, izero )
364  DO 80 i = i1, n
365  a( ioff+i ) = zero
366  80 CONTINUE
367  ioff = ioff + n - j
368  90 CONTINUE
369  END IF
370  END IF
371  ELSE
372  izero = 0
373  END IF
374 *
375 * Set the imaginary part of the diagonals.
376 *
377  IF( iuplo.EQ.1 ) THEN
378  CALL claipd( n, a, 2, 1 )
379  ELSE
380  CALL claipd( n, a, n, -1 )
381  END IF
382 *
383 * Compute the L*D*L' or U*D*U' factorization of the matrix.
384 *
385  npp = n*( n+1 ) / 2
386  CALL ccopy( npp, a, 1, afac, 1 )
387  srnamt = 'CHPTRF'
388  CALL chptrf( uplo, n, afac, iwork, info )
389 *
390 * Adjust the expected value of INFO to account for
391 * pivoting.
392 *
393  k = izero
394  IF( k.GT.0 ) THEN
395  100 CONTINUE
396  IF( iwork( k ).LT.0 ) THEN
397  IF( iwork( k ).NE.-k ) THEN
398  k = -iwork( k )
399  GO TO 100
400  END IF
401  ELSE IF( iwork( k ).NE.k ) THEN
402  k = iwork( k )
403  GO TO 100
404  END IF
405  END IF
406 *
407 * Check error code from CHPTRF.
408 *
409  IF( info.NE.k )
410  $ CALL alaerh( path, 'CHPTRF', info, k, uplo, n, n, -1,
411  $ -1, -1, imat, nfail, nerrs, nout )
412  IF( info.NE.0 ) THEN
413  trfcon = .true.
414  ELSE
415  trfcon = .false.
416  END IF
417 *
418 *+ TEST 1
419 * Reconstruct matrix from factors and compute residual.
420 *
421  CALL chpt01( uplo, n, a, afac, iwork, ainv, lda, rwork,
422  $ result( 1 ) )
423  nt = 1
424 *
425 *+ TEST 2
426 * Form the inverse and compute the residual.
427 *
428  IF( .NOT.trfcon ) THEN
429  CALL ccopy( npp, afac, 1, ainv, 1 )
430  srnamt = 'CHPTRI'
431  CALL chptri( uplo, n, ainv, iwork, work, info )
432 *
433 * Check error code from CHPTRI.
434 *
435  IF( info.NE.0 )
436  $ CALL alaerh( path, 'CHPTRI', info, 0, uplo, n, n,
437  $ -1, -1, -1, imat, nfail, nerrs, nout )
438 *
439  CALL cppt03( uplo, n, a, ainv, work, lda, rwork,
440  $ rcondc, result( 2 ) )
441  nt = 2
442  END IF
443 *
444 * Print information about the tests that did not pass
445 * the threshold.
446 *
447  DO 110 k = 1, nt
448  IF( result( k ).GE.thresh ) THEN
449  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
450  $ CALL alahd( nout, path )
451  WRITE( nout, fmt = 9999 )uplo, n, imat, k,
452  $ result( k )
453  nfail = nfail + 1
454  END IF
455  110 CONTINUE
456  nrun = nrun + nt
457 *
458 * Do only the condition estimate if INFO is not 0.
459 *
460  IF( trfcon ) THEN
461  rcondc = zero
462  GO TO 140
463  END IF
464 *
465  DO 130 irhs = 1, nns
466  nrhs = nsval( irhs )
467 *
468 *+ TEST 3
469 * Solve and compute residual for A * X = B.
470 *
471  srnamt = 'CLARHS'
472  CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
473  $ nrhs, a, lda, xact, lda, b, lda, iseed,
474  $ info )
475  xtype = 'C'
476  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
477 *
478  srnamt = 'CHPTRS'
479  CALL chptrs( uplo, n, nrhs, afac, iwork, x, lda,
480  $ info )
481 *
482 * Check error code from CHPTRS.
483 *
484  IF( info.NE.0 )
485  $ CALL alaerh( path, 'CHPTRS', info, 0, uplo, n, n,
486  $ -1, -1, nrhs, imat, nfail, nerrs,
487  $ nout )
488 *
489  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
490  CALL cppt02( uplo, n, nrhs, a, x, lda, work, lda,
491  $ rwork, result( 3 ) )
492 *
493 *+ TEST 4
494 * Check solution from generated exact solution.
495 *
496  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
497  $ result( 4 ) )
498 *
499 *+ TESTS 5, 6, and 7
500 * Use iterative refinement to improve the solution.
501 *
502  srnamt = 'CHPRFS'
503  CALL chprfs( uplo, n, nrhs, a, afac, iwork, b, lda, x,
504  $ lda, rwork, rwork( nrhs+1 ), work,
505  $ rwork( 2*nrhs+1 ), info )
506 *
507 * Check error code from CHPRFS.
508 *
509  IF( info.NE.0 )
510  $ CALL alaerh( path, 'CHPRFS', info, 0, uplo, n, n,
511  $ -1, -1, nrhs, imat, nfail, nerrs,
512  $ nout )
513 *
514  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
515  $ result( 5 ) )
516  CALL cppt05( uplo, n, nrhs, a, b, lda, x, lda, xact,
517  $ lda, rwork, rwork( nrhs+1 ),
518  $ result( 6 ) )
519 *
520 * Print information about the tests that did not pass
521 * the threshold.
522 *
523  DO 120 k = 3, 7
524  IF( result( k ).GE.thresh ) THEN
525  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
526  $ CALL alahd( nout, path )
527  WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
528  $ k, result( k )
529  nfail = nfail + 1
530  END IF
531  120 CONTINUE
532  nrun = nrun + 5
533  130 CONTINUE
534 *
535 *+ TEST 8
536 * Get an estimate of RCOND = 1/CNDNUM.
537 *
538  140 CONTINUE
539  anorm = clanhp( '1', uplo, n, a, rwork )
540  srnamt = 'CHPCON'
541  CALL chpcon( uplo, n, afac, iwork, anorm, rcond, work,
542  $ info )
543 *
544 * Check error code from CHPCON.
545 *
546  IF( info.NE.0 )
547  $ CALL alaerh( path, 'CHPCON', info, 0, uplo, n, n, -1,
548  $ -1, -1, imat, nfail, nerrs, nout )
549 *
550  result( 8 ) = sget06( rcond, rcondc )
551 *
552 * Print the test ratio if it is .GE. THRESH.
553 *
554  IF( result( 8 ).GE.thresh ) THEN
555  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
556  $ CALL alahd( nout, path )
557  WRITE( nout, fmt = 9999 )uplo, n, imat, 8,
558  $ result( 8 )
559  nfail = nfail + 1
560  END IF
561  nrun = nrun + 1
562  150 CONTINUE
563  160 CONTINUE
564  170 CONTINUE
565 *
566 * Print a summary of the results.
567 *
568  CALL alasum( path, nout, nfail, nrun, nerrs )
569 *
570  9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', type ', i2, ', test ',
571  $ i2, ', ratio =', g12.5 )
572  9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
573  $ i2, ', test(', i2, ') =', g12.5 )
574  RETURN
575 *
576 * End of CCHKHP
577 *
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
claipd
subroutine claipd(N, A, INDA, VINDA)
CLAIPD
Definition: claipd.f:85
cerrsy
subroutine cerrsy(PATH, NUNIT)
CERRSY
Definition: cerrsy.f:57
cppt05
subroutine cppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPPT05
Definition: cppt05.f:159
chprfs
subroutine chprfs(UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CHPRFS
Definition: chprfs.f:182
cppt03
subroutine cppt03(UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, RESID)
CPPT03
Definition: cppt03.f:112
chptri
subroutine chptri(UPLO, N, AP, IPIV, WORK, INFO)
CHPTRI
Definition: chptri.f:111
chptrs
subroutine chptrs(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
CHPTRS
Definition: chptrs.f:117
sget06
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:57
chptrf
subroutine chptrf(UPLO, N, AP, IPIV, INFO)
CHPTRF
Definition: chptrf.f:161
cppt02
subroutine cppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
CPPT02
Definition: cppt02.f:125
clatms
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:334
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
chpt01
subroutine chpt01(UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID)
CHPT01
Definition: chpt01.f:115
chpcon
subroutine chpcon(UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO)
CHPCON
Definition: chpcon.f:120
cget04
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:104
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
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: