LAPACK  3.8.0
LAPACK: Linear Algebra PACKage

◆ cchkhe()

subroutine cchkhe ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNB,
integer, dimension( * )  NBVAL,
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 
)

CCHKHE

Purpose:
 CCHKHE tests CHETRF, -TRI2, -TRS, -TRS2, -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]NNB
          NNB is INTEGER
          The number of values of NB contained in the vector NBVAL.
[in]NBVAL
          NBVAL is INTEGER array, dimension (NBVAL)
          The values of the blocksize NB.
[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)
[out]AFAC
          AFAC is COMPLEX array, dimension (NMAX*NMAX)
[out]AINV
          AINV is COMPLEX array, dimension (NMAX*NMAX)
[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))
[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 2013

Definition at line 173 of file cchkhe.f.

173 *
174 * -- LAPACK test routine (version 3.5.0) --
175 * -- LAPACK is a software package provided by Univ. of Tennessee, --
176 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
177 * November 2013
178 *
179 * .. Scalar Arguments ..
180  LOGICAL tsterr
181  INTEGER nmax, nn, nnb, nns, nout
182  REAL thresh
183 * ..
184 * .. Array Arguments ..
185  LOGICAL dotype( * )
186  INTEGER iwork( * ), nbval( * ), nsval( * ), nval( * )
187  REAL rwork( * )
188  COMPLEX a( * ), afac( * ), ainv( * ), b( * ),
189  $ work( * ), x( * ), xact( * )
190 * ..
191 *
192 * =====================================================================
193 *
194 * .. Parameters ..
195  REAL zero
196  parameter( zero = 0.0e+0 )
197  COMPLEX czero
198  parameter( czero = ( 0.0e+0, 0.0e+0 ) )
199  INTEGER ntypes
200  parameter( ntypes = 10 )
201  INTEGER ntests
202  parameter( ntests = 9 )
203 * ..
204 * .. Local Scalars ..
205  LOGICAL trfcon, zerot
206  CHARACTER dist, TYPE, uplo, xtype
207  CHARACTER*3 path
208  INTEGER i, i1, i2, imat, in, inb, info, ioff, irhs,
209  $ iuplo, izero, j, k, kl, ku, lda, lwork, mode,
210  $ n, nb, nerrs, nfail, nimat, nrhs, nrun, nt
211  REAL anorm, cndnum, rcond, rcondc
212 * ..
213 * .. Local Arrays ..
214  CHARACTER uplos( 2 )
215  INTEGER iseed( 4 ), iseedy( 4 )
216  REAL result( ntests )
217 * ..
218 * .. External Functions ..
219  REAL clanhe, sget06
220  EXTERNAL clanhe, sget06
221 * ..
222 * .. External Subroutines ..
223  EXTERNAL alaerh, alahd, alasum, cerrhe, cget04, checon,
226  $ cpot03, cpot05, xlaenv
227 * ..
228 * .. Intrinsic Functions ..
229  INTRINSIC max, min
230 * ..
231 * .. Scalars in Common ..
232  LOGICAL lerr, ok
233  CHARACTER*32 srnamt
234  INTEGER infot, nunit
235 * ..
236 * .. Common blocks ..
237  COMMON / infoc / infot, nunit, ok, lerr
238  COMMON / srnamc / srnamt
239 * ..
240 * .. Data statements ..
241  DATA iseedy / 1988, 1989, 1990, 1991 /
242  DATA uplos / 'U', 'L' /
243 * ..
244 * .. Executable Statements ..
245 *
246 * Initialize constants and the random number seed.
247 *
248  path( 1: 1 ) = 'Complex precision'
249  path( 2: 3 ) = 'HE'
250  nrun = 0
251  nfail = 0
252  nerrs = 0
253  DO 10 i = 1, 4
254  iseed( i ) = iseedy( i )
255  10 CONTINUE
256 *
257 * Test the error exits
258 *
259  IF( tsterr )
260  $ CALL cerrhe( path, nout )
261  infot = 0
262 *
263 * Set the minimum block size for which the block routine should
264 * be used, which will be later returned by ILAENV
265 *
266  CALL xlaenv( 2, 2 )
267 *
268 * Do for each value of N in NVAL
269 *
270  DO 180 in = 1, nn
271  n = nval( in )
272  lda = max( n, 1 )
273  xtype = 'N'
274  nimat = ntypes
275  IF( n.LE.0 )
276  $ nimat = 1
277 *
278  izero = 0
279 *
280 * Do for each value of matrix type IMAT
281 *
282  DO 170 imat = 1, nimat
283 *
284 * Do the tests only if DOTYPE( IMAT ) is true.
285 *
286  IF( .NOT.dotype( imat ) )
287  $ GO TO 170
288 *
289 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
290 *
291  zerot = imat.GE.3 .AND. imat.LE.6
292  IF( zerot .AND. n.LT.imat-2 )
293  $ GO TO 170
294 *
295 * Do first for UPLO = 'U', then for UPLO = 'L'
296 *
297  DO 160 iuplo = 1, 2
298  uplo = uplos( iuplo )
299 *
300 * Begin generate test matrix A.
301 *
302 *
303 * Set up parameters with CLATB4 for the matrix generator
304 * based on the type of matrix to be generated.
305 *
306  CALL clatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
307  $ cndnum, dist )
308 *
309 * Generate a matrix with CLATMS.
310 *
311  srnamt = 'CLATMS'
312  CALL clatms( n, n, dist, iseed, TYPE, rwork, mode,
313  $ cndnum, anorm, kl, ku, uplo, a, lda, work,
314  $ info )
315 *
316 * Check error code from CLATMS and handle error.
317 *
318  IF( info.NE.0 ) THEN
319  CALL alaerh( path, 'CLATMS', info, 0, uplo, n, n, -1,
320  $ -1, -1, imat, nfail, nerrs, nout )
321 *
322 * Skip all tests for this generated matrix
323 *
324  GO TO 160
325  END IF
326 *
327 * For matrix types 3-6, zero one or more rows and
328 * columns of the matrix to test that INFO is returned
329 * correctly.
330 *
331  IF( zerot ) THEN
332  IF( imat.EQ.3 ) THEN
333  izero = 1
334  ELSE IF( imat.EQ.4 ) THEN
335  izero = n
336  ELSE
337  izero = n / 2 + 1
338  END IF
339 *
340  IF( imat.LT.6 ) THEN
341 *
342 * Set row and column IZERO to zero.
343 *
344  IF( iuplo.EQ.1 ) THEN
345  ioff = ( izero-1 )*lda
346  DO 20 i = 1, izero - 1
347  a( ioff+i ) = czero
348  20 CONTINUE
349  ioff = ioff + izero
350  DO 30 i = izero, n
351  a( ioff ) = czero
352  ioff = ioff + lda
353  30 CONTINUE
354  ELSE
355  ioff = izero
356  DO 40 i = 1, izero - 1
357  a( ioff ) = czero
358  ioff = ioff + lda
359  40 CONTINUE
360  ioff = ioff - izero
361  DO 50 i = izero, n
362  a( ioff+i ) = czero
363  50 CONTINUE
364  END IF
365  ELSE
366  IF( iuplo.EQ.1 ) THEN
367 *
368 * Set the first IZERO rows and columns to zero.
369 *
370  ioff = 0
371  DO 70 j = 1, n
372  i2 = min( j, izero )
373  DO 60 i = 1, i2
374  a( ioff+i ) = czero
375  60 CONTINUE
376  ioff = ioff + lda
377  70 CONTINUE
378  ELSE
379 *
380 * Set the last IZERO rows and columns to zero.
381 *
382  ioff = 0
383  DO 90 j = 1, n
384  i1 = max( j, izero )
385  DO 80 i = i1, n
386  a( ioff+i ) = czero
387  80 CONTINUE
388  ioff = ioff + lda
389  90 CONTINUE
390  END IF
391  END IF
392  ELSE
393  izero = 0
394  END IF
395 *
396 * Set the imaginary part of the diagonals.
397 *
398  CALL claipd( n, a, lda+1, 0 )
399 *
400 * End generate test matrix A.
401 *
402 *
403 * Do for each value of NB in NBVAL
404 *
405  DO 150 inb = 1, nnb
406 *
407 * Set the optimal blocksize, which will be later
408 * returned by ILAENV.
409 *
410  nb = nbval( inb )
411  CALL xlaenv( 1, nb )
412 *
413 * Copy the test matrix A into matrix AFAC which
414 * will be factorized in place. This is needed to
415 * preserve the test matrix A for subsequent tests.
416 *
417  CALL clacpy( uplo, n, n, a, lda, afac, lda )
418 *
419 * Compute the L*D*L**T or U*D*U**T factorization of the
420 * matrix. IWORK stores details of the interchanges and
421 * the block structure of D. AINV is a work array for
422 * block factorization, LWORK is the length of AINV.
423 *
424  lwork = max( 2, nb )*lda
425  srnamt = 'CHETRF'
426  CALL chetrf( uplo, n, afac, lda, iwork, ainv, lwork,
427  $ info )
428 *
429 * Adjust the expected value of INFO to account for
430 * pivoting.
431 *
432  k = izero
433  IF( k.GT.0 ) THEN
434  100 CONTINUE
435  IF( iwork( k ).LT.0 ) THEN
436  IF( iwork( k ).NE.-k ) THEN
437  k = -iwork( k )
438  GO TO 100
439  END IF
440  ELSE IF( iwork( k ).NE.k ) THEN
441  k = iwork( k )
442  GO TO 100
443  END IF
444  END IF
445 *
446 * Check error code from CHETRF and handle error.
447 *
448  IF( info.NE.k )
449  $ CALL alaerh( path, 'CHETRF', info, k, uplo, n, n,
450  $ -1, -1, nb, imat, nfail, nerrs, nout )
451 *
452 * Set the condition estimate flag if the INFO is not 0.
453 *
454  IF( info.NE.0 ) THEN
455  trfcon = .true.
456  ELSE
457  trfcon = .false.
458  END IF
459 *
460 *+ TEST 1
461 * Reconstruct matrix from factors and compute residual.
462 *
463  CALL chet01( uplo, n, a, lda, afac, lda, iwork, ainv,
464  $ lda, rwork, result( 1 ) )
465  nt = 1
466 *
467 *+ TEST 2
468 * Form the inverse and compute the residual,
469 * if the factorization was competed without INFO > 0
470 * (i.e. there is no zero rows and columns).
471 * Do it only for the first block size.
472 *
473  IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
474  CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
475  srnamt = 'CHETRI2'
476  lwork = (n+nb+1)*(nb+3)
477  CALL chetri2( uplo, n, ainv, lda, iwork, work,
478  $ lwork, info )
479 *
480 * Check error code from CHETRI2 and handle error.
481 *
482  IF( info.NE.0 )
483  $ CALL alaerh( path, 'CHETRI2', info, -1, uplo, n,
484  $ n, -1, -1, -1, imat, nfail, nerrs,
485  $ nout )
486 *
487 * Compute the residual for a symmetric matrix times
488 * its inverse.
489 *
490  CALL cpot03( uplo, n, a, lda, ainv, lda, work, lda,
491  $ rwork, rcondc, result( 2 ) )
492  nt = 2
493  END IF
494 *
495 * Print information about the tests that did not pass
496 * the threshold.
497 *
498  DO 110 k = 1, nt
499  IF( result( k ).GE.thresh ) THEN
500  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
501  $ CALL alahd( nout, path )
502  WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
503  $ result( k )
504  nfail = nfail + 1
505  END IF
506  110 CONTINUE
507  nrun = nrun + nt
508 *
509 * Skip the other tests if this is not the first block
510 * size.
511 *
512  IF( inb.GT.1 )
513  $ GO TO 150
514 *
515 * Do only the condition estimate if INFO is not 0.
516 *
517  IF( trfcon ) THEN
518  rcondc = zero
519  GO TO 140
520  END IF
521 *
522 * Do for each value of NRHS in NSVAL.
523 *
524  DO 130 irhs = 1, nns
525  nrhs = nsval( irhs )
526 *
527 *+ TEST 3 (Using TRS)
528 * Solve and compute residual for A * X = B.
529 *
530 * Choose a set of NRHS random solution vectors
531 * stored in XACT and set up the right hand side B
532 *
533  srnamt = 'CLARHS'
534  CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
535  $ nrhs, a, lda, xact, lda, b, lda,
536  $ iseed, info )
537  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
538 *
539  srnamt = 'CHETRS'
540  CALL chetrs( uplo, n, nrhs, afac, lda, iwork, x,
541  $ lda, info )
542 *
543 * Check error code from CHETRS and handle error.
544 *
545  IF( info.NE.0 )
546  $ CALL alaerh( path, 'CHETRS', info, 0, uplo, n,
547  $ n, -1, -1, nrhs, imat, nfail,
548  $ nerrs, nout )
549 *
550  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
551 *
552 * Compute the residual for the solution
553 *
554  CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
555  $ lda, rwork, result( 3 ) )
556 *
557 *+ TEST 4 (Using TRS2)
558 * Solve and compute residual for A * X = B.
559 *
560 * Choose a set of NRHS random solution vectors
561 * stored in XACT and set up the right hand side B
562 *
563  srnamt = 'CLARHS'
564  CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
565  $ nrhs, a, lda, xact, lda, b, lda,
566  $ iseed, info )
567  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
568 *
569  srnamt = 'CHETRS2'
570  CALL chetrs2( uplo, n, nrhs, afac, lda, iwork, x,
571  $ lda, work, info )
572 *
573 * Check error code from CHETRS2 and handle error.
574 *
575  IF( info.NE.0 )
576  $ CALL alaerh( path, 'CHETRS2', info, 0, uplo, n,
577  $ n, -1, -1, nrhs, imat, nfail,
578  $ nerrs, nout )
579 *
580  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
581 *
582 * Compute the residual for the solution
583 *
584  CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
585  $ lda, rwork, result( 4 ) )
586 *
587 *+ TEST 5
588 * Check solution from generated exact solution.
589 *
590  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
591  $ result( 5 ) )
592 *
593 *+ TESTS 6, 7, and 8
594 * Use iterative refinement to improve the solution.
595 *
596  srnamt = 'CHERFS'
597  CALL cherfs( uplo, n, nrhs, a, lda, afac, lda,
598  $ iwork, b, lda, x, lda, rwork,
599  $ rwork( nrhs+1 ), work,
600  $ rwork( 2*nrhs+1 ), info )
601 *
602 * Check error code from CHERFS and handle error.
603 *
604  IF( info.NE.0 )
605  $ CALL alaerh( path, 'CHERFS', info, 0, uplo, n,
606  $ n, -1, -1, nrhs, imat, nfail,
607  $ nerrs, nout )
608 *
609  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
610  $ result( 6 ) )
611  CALL cpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
612  $ xact, lda, rwork, rwork( nrhs+1 ),
613  $ result( 7 ) )
614 *
615 * Print information about the tests that did not pass
616 * the threshold.
617 *
618  DO 120 k = 3, 8
619  IF( result( k ).GE.thresh ) THEN
620  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
621  $ CALL alahd( nout, path )
622  WRITE( nout, fmt = 9998 )uplo, n, nrhs,
623  $ imat, k, result( k )
624  nfail = nfail + 1
625  END IF
626  120 CONTINUE
627  nrun = nrun + 6
628 *
629 * End do for each value of NRHS in NSVAL.
630 *
631  130 CONTINUE
632 *
633 *+ TEST 9
634 * Get an estimate of RCOND = 1/CNDNUM.
635 *
636  140 CONTINUE
637  anorm = clanhe( '1', uplo, n, a, lda, rwork )
638  srnamt = 'CHECON'
639  CALL checon( uplo, n, afac, lda, iwork, anorm, rcond,
640  $ work, info )
641 *
642 * Check error code from CHECON and handle error.
643 *
644  IF( info.NE.0 )
645  $ CALL alaerh( path, 'CHECON', info, 0, uplo, n, n,
646  $ -1, -1, -1, imat, nfail, nerrs, nout )
647 *
648 * Compute the test ratio to compare values of RCOND
649 *
650  result( 9 ) = sget06( rcond, rcondc )
651 *
652 * Print information about the tests that did not pass
653 * the threshold.
654 *
655  IF( result( 9 ).GE.thresh ) THEN
656  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
657  $ CALL alahd( nout, path )
658  WRITE( nout, fmt = 9997 )uplo, n, imat, 8,
659  $ result( 9 )
660  nfail = nfail + 1
661  END IF
662  nrun = nrun + 1
663  150 CONTINUE
664  160 CONTINUE
665  170 CONTINUE
666  180 CONTINUE
667 *
668 * Print a summary of the results.
669 *
670  CALL alasum( path, nout, nfail, nrun, nerrs )
671 *
672  9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
673  $ i2, ', test ', i2, ', ratio =', g12.5 )
674  9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
675  $ i2, ', test(', i2, ') =', g12.5 )
676  9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
677  $ ', test(', i2, ') =', g12.5 )
678  RETURN
679 *
680 * End of CCHKHE
681 *
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
subroutine chetrs2(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO)
CHETRS2
Definition: chetrs2.f:129
subroutine claipd(N, A, INDA, VINDA)
CLAIPD
Definition: claipd.f:85
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
subroutine chetri2(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
CHETRI2
Definition: chetri2.f:129
subroutine chet01(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
CHET01
Definition: chet01.f:128
subroutine cpot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CPOT02
Definition: cpot02.f:129
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:57
subroutine checon(UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO)
CHECON
Definition: checon.f:127
subroutine cherfs(UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CHERFS
Definition: cherfs.f:194
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
subroutine cerrhe(PATH, NUNIT)
CERRHE
Definition: cerrhe.f:57
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
subroutine cpot05(UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPOT05
Definition: cpot05.f:167
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:334
subroutine chetrs(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
CHETRS
Definition: chetrs.f:122
real function clanhe(NORM, UPLO, N, A, LDA, WORK)
CLANHE 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.
Definition: clanhe.f:126
subroutine chetrf(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
CHETRF
Definition: chetrf.f:179
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
Definition: clarhs.f:211
subroutine cpot03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
CPOT03
Definition: cpot03.f:128
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:104
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:75
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:123
Here is the call graph for this function:
Here is the caller graph for this function: