LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ cchkhe_aa()

subroutine cchkhe_aa ( 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_AA

Purpose:
 CCHKHE_AA tests CHETRF_AA, -TRS_AA.
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 2017

Definition at line 174 of file cchkhe_aa.f.

174 *
175 * -- LAPACK test routine (version 3.8.0) --
176 * -- LAPACK is a software package provided by Univ. of Tennessee, --
177 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
178 * November 2017
179 *
180  IMPLICIT NONE
181 *
182 * .. Scalar Arguments ..
183  LOGICAL TSTERR
184  INTEGER NMAX, NN, NNB, NNS, NOUT
185  REAL THRESH
186 * ..
187 * .. Array Arguments ..
188  LOGICAL DOTYPE( * )
189  INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
190  REAL RWORK( * )
191  COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
192  $ WORK( * ), X( * ), XACT( * )
193 * ..
194 *
195 * =====================================================================
196 *
197 * .. Parameters ..
198  REAL ZERO
199  parameter( zero = 0.0e+0 )
200  COMPLEX CZERO
201  parameter( czero = ( 0.0e+0, 0.0e+0 ) )
202  INTEGER NTYPES
203  parameter( ntypes = 10 )
204  INTEGER NTESTS
205  parameter( ntests = 9 )
206 * ..
207 * .. Local Scalars ..
208  LOGICAL ZEROT
209  CHARACTER DIST, TYPE, UPLO, XTYPE
210  CHARACTER*3 PATH, MATPATH
211  INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
212  $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
213  $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
214  REAL ANORM, CNDNUM
215 * ..
216 * .. Local Arrays ..
217  CHARACTER UPLOS( 2 )
218  INTEGER ISEED( 4 ), ISEEDY( 4 )
219  REAL RESULT( NTESTS )
220 * ..
221 * .. External Subroutines ..
222  EXTERNAL alaerh, alahd, alasum, xlaenv, cerrhe, chet01_aa,
223  $ chetrf_aa, chetrs_aa, clacpy, claipd, clarhs,
224  $ clatb4, clatms, cpot02
225 * ..
226 * .. Intrinsic Functions ..
227  INTRINSIC max, min
228 * ..
229 * .. Scalars in Common ..
230  LOGICAL LERR, OK
231  CHARACTER*32 SRNAMT
232  INTEGER INFOT, NUNIT
233 * ..
234 * .. Common blocks ..
235  COMMON / infoc / infot, nunit, ok, lerr
236  COMMON / srnamc / srnamt
237 * ..
238 * .. Data statements ..
239  DATA iseedy / 1988, 1989, 1990, 1991 /
240  DATA uplos / 'U', 'L' /
241 * ..
242 * .. Executable Statements ..
243 *
244 * Initialize constants and the random number seed.
245 *
246 *
247 * Test path
248 *
249  path( 1: 1 ) = 'Complex precision'
250  path( 2: 3 ) = 'HA'
251 *
252 * Path to generate matrices
253 *
254  matpath( 1: 1 ) = 'Complex precision'
255  matpath( 2: 3 ) = 'HE'
256  nrun = 0
257  nfail = 0
258  nerrs = 0
259  DO 10 i = 1, 4
260  iseed( i ) = iseedy( i )
261  10 CONTINUE
262 *
263 * Test the error exits
264 *
265  IF( tsterr )
266  $ CALL cerrhe( path, nout )
267  infot = 0
268 *
269 * Set the minimum block size for which the block routine should
270 * be used, which will be later returned by ILAENV
271 *
272  CALL xlaenv( 2, 2 )
273 *
274 * Do for each value of N in NVAL
275 *
276  DO 180 in = 1, nn
277  n = nval( in )
278  IF( n .GT. nmax ) THEN
279  nfail = nfail + 1
280  WRITE(nout, 9995) 'M ', n, nmax
281  GO TO 180
282  END IF
283  lda = max( n, 1 )
284  xtype = 'N'
285  nimat = ntypes
286  IF( n.LE.0 )
287  $ nimat = 1
288 *
289  izero = 0
290  DO 170 imat = 1, nimat
291 *
292 * Do the tests only if DOTYPE( IMAT ) is true.
293 *
294  IF( .NOT.dotype( imat ) )
295  $ GO TO 170
296 *
297 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
298 *
299  zerot = imat.GE.3 .AND. imat.LE.6
300  IF( zerot .AND. n.LT.imat-2 )
301  $ GO TO 170
302 *
303 * Do first for UPLO = 'U', then for UPLO = 'L'
304 *
305  DO 160 iuplo = 1, 2
306  uplo = uplos( iuplo )
307 *
308 * Set up parameters with CLATB4 for the matrix generator
309 * based on the type of matrix to be generated.
310 *
311  CALL clatb4( matpath, imat, n, n, TYPE, KL, KU,
312  $ ANORM, MODE, CNDNUM, DIST )
313 *
314 * Generate a matrix with CLATMS.
315 *
316  srnamt = 'CLATMS'
317  CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
318  $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
319  $ INFO )
320 *
321 * Check error code from CLATMS and handle error.
322 *
323  IF( info.NE.0 ) THEN
324  CALL alaerh( path, 'CLATMS', info, 0, uplo, n, n, -1,
325  $ -1, -1, imat, nfail, nerrs, nout )
326 *
327 * Skip all tests for this generated matrix
328 *
329  GO TO 160
330  END IF
331 *
332 * For types 3-6, zero one or more rows and columns of
333 * the matrix to test that INFO is returned correctly.
334 *
335  IF( zerot ) THEN
336  IF( imat.EQ.3 ) THEN
337  izero = 1
338  ELSE IF( imat.EQ.4 ) THEN
339  izero = n
340  ELSE
341  izero = n / 2 + 1
342  END IF
343 *
344  IF( imat.LT.6 ) THEN
345 *
346 * Set row and column IZERO to zero.
347 *
348  IF( iuplo.EQ.1 ) THEN
349  ioff = ( izero-1 )*lda
350  DO 20 i = 1, izero - 1
351  a( ioff+i ) = czero
352  20 CONTINUE
353  ioff = ioff + izero
354  DO 30 i = izero, n
355  a( ioff ) = czero
356  ioff = ioff + lda
357  30 CONTINUE
358  ELSE
359  ioff = izero
360  DO 40 i = 1, izero - 1
361  a( ioff ) = czero
362  ioff = ioff + lda
363  40 CONTINUE
364  ioff = ioff - izero
365  DO 50 i = izero, n
366  a( ioff+i ) = czero
367  50 CONTINUE
368  END IF
369  ELSE
370  IF( iuplo.EQ.1 ) THEN
371 *
372 * Set the first IZERO rows and columns to zero.
373 *
374  ioff = 0
375  DO 70 j = 1, n
376  i2 = min( j, izero )
377  DO 60 i = 1, i2
378  a( ioff+i ) = czero
379  60 CONTINUE
380  ioff = ioff + lda
381  70 CONTINUE
382  izero = 1
383  ELSE
384 *
385 * Set the last IZERO rows and columns to zero.
386 *
387  ioff = 0
388  DO 90 j = 1, n
389  i1 = max( j, izero )
390  DO 80 i = i1, n
391  a( ioff+i ) = czero
392  80 CONTINUE
393  ioff = ioff + lda
394  90 CONTINUE
395  END IF
396  END IF
397  ELSE
398  izero = 0
399  END IF
400 *
401 * End generate test matrix A.
402 *
403 *
404 * Set the imaginary part of the diagonals.
405 *
406  CALL claipd( n, a, lda+1, 0 )
407 *
408 * Do for each value of NB in NBVAL
409 *
410  DO 150 inb = 1, nnb
411 *
412 * Set the optimal blocksize, which will be later
413 * returned by ILAENV.
414 *
415  nb = nbval( inb )
416  CALL xlaenv( 1, nb )
417 *
418 * Copy the test matrix A into matrix AFAC which
419 * will be factorized in place. This is needed to
420 * preserve the test matrix A for subsequent tests.
421 *
422  CALL clacpy( uplo, n, n, a, lda, afac, lda )
423 *
424 * Compute the L*D*L**T or U*D*U**T factorization of the
425 * matrix. IWORK stores details of the interchanges and
426 * the block structure of D. AINV is a work array for
427 * block factorization, LWORK is the length of AINV.
428 *
429  lwork = max( 1, ( nb+1 )*lda )
430  srnamt = 'CHETRF_AA'
431  CALL chetrf_aa( uplo, n, afac, lda, iwork, ainv,
432  $ lwork, info )
433 *
434 * Adjust the expected value of INFO to account for
435 * pivoting.
436 *
437 c IF( IZERO.GT.0 ) THEN
438 c J = 1
439 c K = IZERO
440 c 100 CONTINUE
441 c IF( J.EQ.K ) THEN
442 c K = IWORK( J )
443 c ELSE IF( IWORK( J ).EQ.K ) THEN
444 c K = J
445 c END IF
446 c IF( J.LT.K ) THEN
447 c J = J + 1
448 c GO TO 100
449 c END IF
450 c ELSE
451  k = 0
452 c END IF
453 *
454 * Check error code from CHETRF and handle error.
455 *
456  IF( info.NE.k ) THEN
457  CALL alaerh( path, 'CHETRF_AA', info, k, uplo,
458  $ n, n, -1, -1, nb, imat, nfail, nerrs,
459  $ nout )
460  END IF
461 *
462 *+ TEST 1
463 * Reconstruct matrix from factors and compute residual.
464 *
465  CALL chet01_aa( uplo, n, a, lda, afac, lda, iwork,
466  $ ainv, lda, rwork, result( 1 ) )
467  nt = 1
468 *
469 *
470 * Print information about the tests that did not pass
471 * the threshold.
472 *
473  DO 110 k = 1, nt
474  IF( result( k ).GE.thresh ) THEN
475  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
476  $ CALL alahd( nout, path )
477  WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
478  $ result( k )
479  nfail = nfail + 1
480  END IF
481  110 CONTINUE
482  nrun = nrun + nt
483 *
484 * Skip solver test if INFO is not 0.
485 *
486  IF( info.NE.0 ) THEN
487  GO TO 140
488  END IF
489 *
490 * Do for each value of NRHS in NSVAL.
491 *
492  DO 130 irhs = 1, nns
493  nrhs = nsval( irhs )
494 *
495 *+ TEST 2 (Using TRS)
496 * Solve and compute residual for A * X = B.
497 *
498 * Choose a set of NRHS random solution vectors
499 * stored in XACT and set up the right hand side B
500 *
501  srnamt = 'CLARHS'
502  CALL clarhs( matpath, xtype, uplo, ' ', n, n,
503  $ kl, ku, nrhs, a, lda, xact, lda,
504  $ b, lda, iseed, info )
505  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
506 *
507  srnamt = 'CHETRS_AA'
508  lwork = max( 1, 3*n-2 )
509  CALL chetrs_aa( uplo, n, nrhs, afac, lda, iwork,
510  $ x, lda, work, lwork, info )
511 *
512 * Check error code from CHETRS and handle error.
513 *
514  IF( info.NE.0 ) THEN
515  IF( izero.EQ.0 ) THEN
516  CALL alaerh( path, 'CHETRS_AA', info, 0,
517  $ uplo, n, n, -1, -1, nrhs, imat,
518  $ nfail, nerrs, nout )
519  END IF
520  ELSE
521  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda
522  $ )
523 *
524 * Compute the residual for the solution
525 *
526  CALL cpot02( uplo, n, nrhs, a, lda, x, lda,
527  $ work, lda, rwork, result( 2 ) )
528 *
529 * Print information about the tests that did not pass
530 * the threshold.
531 *
532  DO 120 k = 2, 2
533  IF( result( k ).GE.thresh ) THEN
534  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
535  $ CALL alahd( nout, path )
536  WRITE( nout, fmt = 9998 )uplo, n, nrhs,
537  $ imat, k, result( k )
538  nfail = nfail + 1
539  END IF
540  120 CONTINUE
541  END IF
542  nrun = nrun + 1
543 *
544 * End do for each value of NRHS in NSVAL.
545 *
546  130 CONTINUE
547  140 CONTINUE
548  150 CONTINUE
549  160 CONTINUE
550  170 CONTINUE
551  180 CONTINUE
552 *
553 * Print a summary of the results.
554 *
555  CALL alasum( path, nout, nfail, nrun, nerrs )
556 *
557  9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
558  $ i2, ', test ', i2, ', ratio =', g12.5 )
559  9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
560  $ i2, ', test(', i2, ') =', g12.5 )
561  9995 FORMAT( ' Invalid input value: ', a4, '=', i6, '; must be <=',
562  $ i6 )
563  RETURN
564 *
565 * End of CCHKHE_AA
566 *
Here is the call graph for this function:
Here is the caller graph for this function:
chetrs_aa
subroutine chetrs_aa(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO)
CHETRS_AA
Definition: chetrs_aa.f:133
chet01_aa
subroutine chet01_aa(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
CHET01_AA
Definition: chet01_aa.f:127
claipd
subroutine claipd(N, A, INDA, VINDA)
CLAIPD
Definition: claipd.f:85
alahd
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:109
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
cpot02
subroutine cpot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CPOT02
Definition: cpot02.f:129
cerrhe
subroutine cerrhe(PATH, NUNIT)
CERRHE
Definition: cerrhe.f:57
clatms
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:334
chetrf_aa
subroutine chetrf_aa(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
CHETRF_AA
Definition: chetrf_aa.f:134
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
alasum
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:75
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
clatb4
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:123
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83