LAPACK  3.7.0
LAPACK: Linear Algebra PACKage
subroutine cdrvhe_rk ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NRHS,
real  THRESH,
logical  TSTERR,
integer  NMAX,
complex, dimension( * )  A,
complex, dimension( * )  AFAC,
complex, dimension( * )  E,
complex, dimension( * )  AINV,
complex, dimension( * )  B,
complex, dimension( * )  X,
complex, dimension( * )  XACT,
complex, dimension( * )  WORK,
real, dimension( * )  RWORK,
integer, dimension( * )  IWORK,
integer  NOUT 
)

CDRVHE_RK

Purpose: 
 CDRVHE_RK tests the driver routines CHESV_RK.
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]NRHS
          NRHS is INTEGER
          The number of right hand side vectors to be generated for
          each linear system.
[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]E
          E is COMPLEX array, dimension (NMAX)
[out]AINV
          AINV is COMPLEX array, dimension (NMAX*NMAX)
[out]B
          B is COMPLEX array, dimension (NMAX*NRHS)
[out]X
          X is COMPLEX array, dimension (NMAX*NRHS)
[out]XACT
          XACT is COMPLEX array, dimension (NMAX*NRHS)
[out]WORK
          WORK is COMPLEX array, dimension (NMAX*max(2,NRHS))
[out]RWORK
          RWORK is REAL array, dimension (NMAX+2*NRHS)
[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
December 2016

Definition at line 160 of file cdrvhe_rk.f.

160 *
161 * -- LAPACK test routine (version 3.7.0) --
162 * -- LAPACK is a software package provided by Univ. of Tennessee, --
163 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
164 * December 2016
165 *
166 * .. Scalar Arguments ..
167  LOGICAL tsterr
168  INTEGER nmax, nn, nout, nrhs
169  REAL thresh
170 * ..
171 * .. Array Arguments ..
172  LOGICAL dotype( * )
173  INTEGER iwork( * ), nval( * )
174  REAL rwork( * )
175  COMPLEX a( * ), afac( * ), ainv( * ), b( * ), e( * ),
176  $ work( * ), x( * ), xact( * )
177 * ..
178 *
179 * =====================================================================
180 *
181 * .. Parameters ..
182  REAL one, zero
183  parameter ( one = 1.0e+0, zero = 0.0e+0 )
184  INTEGER ntypes, ntests
185  parameter ( ntypes = 10, ntests = 3 )
186  INTEGER nfact
187  parameter ( nfact = 2 )
188 * ..
189 * .. Local Scalars ..
190  LOGICAL zerot
191  CHARACTER dist, fact, TYPE, uplo, xtype
192  CHARACTER*3 matpath, path
193  INTEGER i, i1, i2, ifact, imat, in, info, ioff, iuplo,
194  $ izero, j, k, kl, ku, lda, lwork, mode, n,
195  $ nb, nbmin, nerrs, nfail, nimat, nrun, nt
196  REAL ainvnm, anorm, cndnum, rcondc
197 * ..
198 * .. Local Arrays ..
199  CHARACTER facts( nfact ), uplos( 2 )
200  INTEGER iseed( 4 ), iseedy( 4 )
201  REAL result( ntests )
202 
203 * ..
204 * .. External Functions ..
205  REAL clanhe
206  EXTERNAL clanhe
207 * ..
208 * .. External Subroutines ..
209  EXTERNAL aladhd, alaerh, alasvm, xlaenv, cerrvx, cget04,
210  $ clacpy, clarhs, clatb4, clatms, chesv_rk,
211  $ chet01_3, cpot02, chetrf_rk, chetri_3
212 * ..
213 * .. Scalars in Common ..
214  LOGICAL lerr, ok
215  CHARACTER*32 srnamt
216  INTEGER infot, nunit
217 * ..
218 * .. Common blocks ..
219  COMMON / infoc / infot, nunit, ok, lerr
220  COMMON / srnamc / srnamt
221 * ..
222 * .. Intrinsic Functions ..
223  INTRINSIC max, min
224 * ..
225 * .. Data statements ..
226  DATA iseedy / 1988, 1989, 1990, 1991 /
227  DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
228 * ..
229 * .. Executable Statements ..
230 *
231 * Initialize constants and the random number seed.
232 *
233 * Test path
234 *
235  path( 1: 1 ) = 'Complex precision'
236  path( 2: 3 ) = 'HK'
237 *
238 * Path to generate matrices
239 *
240  matpath( 1: 1 ) = 'Complex precision'
241  matpath( 2: 3 ) = 'HE'
242 *
243  nrun = 0
244  nfail = 0
245  nerrs = 0
246  DO 10 i = 1, 4
247  iseed( i ) = iseedy( i )
248  10 CONTINUE
249  lwork = max( 2*nmax, nmax*nrhs )
250 *
251 * Test the error exits
252 *
253  IF( tsterr )
254  $ CALL cerrvx( path, nout )
255  infot = 0
256 *
257 * Set the block size and minimum block size for which the block
258 * routine should be used, which will be later returned by ILAENV.
259 *
260  nb = 1
261  nbmin = 2
262  CALL xlaenv( 1, nb )
263  CALL xlaenv( 2, nbmin )
264 *
265 * Do for each value of N in NVAL
266 *
267  DO 180 in = 1, nn
268  n = nval( in )
269  lda = max( n, 1 )
270  xtype = 'N'
271  nimat = ntypes
272  IF( n.LE.0 )
273  $ nimat = 1
274 *
275  DO 170 imat = 1, nimat
276 *
277 * Do the tests only if DOTYPE( IMAT ) is true.
278 *
279  IF( .NOT.dotype( imat ) )
280  $ GO TO 170
281 *
282 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
283 *
284  zerot = imat.GE.3 .AND. imat.LE.6
285  IF( zerot .AND. n.LT.imat-2 )
286  $ GO TO 170
287 *
288 * Do first for UPLO = 'U', then for UPLO = 'L'
289 *
290  DO 160 iuplo = 1, 2
291  uplo = uplos( iuplo )
292 *
293 * Begin generate the test matrix A.
294 *
295 * Set up parameters with CLATB4 for the matrix generator
296 * based on the type of matrix to be generated.
297 *
298  CALL clatb4( matpath, imat, n, n, TYPE, kl, ku, anorm,
299  $ mode, cndnum, dist )
300 *
301 * Generate a matrix with CLATMS.
302 *
303  srnamt = 'CLATMS'
304  CALL clatms( n, n, dist, iseed, TYPE, rwork, mode,
305  $ cndnum, anorm, kl, ku, uplo, a, lda,
306  $ work, info )
307 *
308 * Check error code from CLATMS and handle error.
309 *
310  IF( info.NE.0 ) THEN
311  CALL alaerh( path, 'CLATMS', info, 0, uplo, n, n,
312  $ -1, -1, -1, imat, nfail, nerrs, nout )
313  GO TO 160
314  END IF
315 *
316 * For types 3-6, zero one or more rows and columns of
317 * the matrix to test that INFO is returned correctly.
318 *
319  IF( zerot ) THEN
320  IF( imat.EQ.3 ) THEN
321  izero = 1
322  ELSE IF( imat.EQ.4 ) THEN
323  izero = n
324  ELSE
325  izero = n / 2 + 1
326  END IF
327 *
328  IF( imat.LT.6 ) THEN
329 *
330 * Set row and column IZERO to zero.
331 *
332  IF( iuplo.EQ.1 ) THEN
333  ioff = ( izero-1 )*lda
334  DO 20 i = 1, izero - 1
335  a( ioff+i ) = zero
336  20 CONTINUE
337  ioff = ioff + izero
338  DO 30 i = izero, n
339  a( ioff ) = zero
340  ioff = ioff + lda
341  30 CONTINUE
342  ELSE
343  ioff = izero
344  DO 40 i = 1, izero - 1
345  a( ioff ) = zero
346  ioff = ioff + lda
347  40 CONTINUE
348  ioff = ioff - izero
349  DO 50 i = izero, n
350  a( ioff+i ) = zero
351  50 CONTINUE
352  END IF
353  ELSE
354  IF( iuplo.EQ.1 ) THEN
355 *
356 * Set the first IZERO rows and columns to zero.
357 *
358  ioff = 0
359  DO 70 j = 1, n
360  i2 = min( j, izero )
361  DO 60 i = 1, i2
362  a( ioff+i ) = zero
363  60 CONTINUE
364  ioff = ioff + lda
365  70 CONTINUE
366  ELSE
367 *
368 * Set the first IZERO rows and columns to zero.
369 *
370  ioff = 0
371  DO 90 j = 1, n
372  i1 = max( j, izero )
373  DO 80 i = i1, n
374  a( ioff+i ) = zero
375  80 CONTINUE
376  ioff = ioff + lda
377  90 CONTINUE
378  END IF
379  END IF
380  ELSE
381  izero = 0
382  END IF
383 *
384 * End generate the test matrix A.
385 *
386 *
387  DO 150 ifact = 1, nfact
388 *
389 * Do first for FACT = 'F', then for other values.
390 *
391  fact = facts( ifact )
392 *
393 * Compute the condition number
394 *
395  IF( zerot ) THEN
396  IF( ifact.EQ.1 )
397  $ GO TO 150
398  rcondc = zero
399 *
400  ELSE IF( ifact.EQ.1 ) THEN
401 *
402 * Compute the 1-norm of A.
403 *
404  anorm = clanhe( '1', uplo, n, a, lda, rwork )
405 *
406 * Factor the matrix A.
407 *
408  CALL clacpy( uplo, n, n, a, lda, afac, lda )
409  CALL chetrf_rk( uplo, n, afac, lda, e, iwork, work,
410  $ lwork, info )
411 *
412 * Compute inv(A) and take its norm.
413 *
414  CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
415  lwork = (n+nb+1)*(nb+3)
416 *
417 * We need to copute the invesrse to compute
418 * RCONDC that is used later in TEST3.
419 *
420  CALL csytri_3( uplo, n, ainv, lda, e, iwork,
421  $ work, lwork, info )
422  ainvnm = clanhe( '1', uplo, n, ainv, lda, rwork )
423 *
424 * Compute the 1-norm condition number of A.
425 *
426  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
427  rcondc = one
428  ELSE
429  rcondc = ( one / anorm ) / ainvnm
430  END IF
431  END IF
432 *
433 * Form an exact solution and set the right hand side.
434 *
435  srnamt = 'CLARHS'
436  CALL clarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
437  $ nrhs, a, lda, xact, lda, b, lda, iseed,
438  $ info )
439  xtype = 'C'
440 *
441 * --- Test CHESV_RK ---
442 *
443  IF( ifact.EQ.2 ) THEN
444  CALL clacpy( uplo, n, n, a, lda, afac, lda )
445  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
446 *
447 * Factor the matrix and solve the system using
448 * CHESV_RK.
449 *
450  srnamt = 'CHESV_RK'
451  CALL chesv_rk( uplo, n, nrhs, afac, lda, e, iwork,
452  $ x, lda, work, lwork, info )
453 *
454 * Adjust the expected value of INFO to account for
455 * pivoting.
456 *
457  k = izero
458  IF( k.GT.0 ) THEN
459  100 CONTINUE
460  IF( iwork( k ).LT.0 ) THEN
461  IF( iwork( k ).NE.-k ) THEN
462  k = -iwork( k )
463  GO TO 100
464  END IF
465  ELSE IF( iwork( k ).NE.k ) THEN
466  k = iwork( k )
467  GO TO 100
468  END IF
469  END IF
470 *
471 * Check error code from CHESV_RK and handle error.
472 *
473  IF( info.NE.k ) THEN
474  CALL alaerh( path, 'CHESV_RK', info, k, uplo,
475  $ n, n, -1, -1, nrhs, imat, nfail,
476  $ nerrs, nout )
477  GO TO 120
478  ELSE IF( info.NE.0 ) THEN
479  GO TO 120
480  END IF
481 *
482 *+ TEST 1 Reconstruct matrix from factors and compute
483 * residual.
484 *
485  CALL chet01_3( uplo, n, a, lda, afac, lda, e,
486  $ iwork, ainv, lda, rwork,
487  $ result( 1 ) )
488 *
489 *+ TEST 2 Compute residual of the computed solution.
490 *
491  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
492  CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
493  $ lda, rwork, result( 2 ) )
494 *
495 *+ TEST 3
496 * Check solution from generated exact solution.
497 *
498  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
499  $ result( 3 ) )
500  nt = 3
501 *
502 * Print information about the tests that did not pass
503 * the threshold.
504 *
505  DO 110 k = 1, nt
506  IF( result( k ).GE.thresh ) THEN
507  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
508  $ CALL aladhd( nout, path )
509  WRITE( nout, fmt = 9999 )'CHESV_RK', uplo,
510  $ n, imat, k, result( k )
511  nfail = nfail + 1
512  END IF
513  110 CONTINUE
514  nrun = nrun + nt
515  120 CONTINUE
516  END IF
517 *
518  150 CONTINUE
519 *
520  160 CONTINUE
521  170 CONTINUE
522  180 CONTINUE
523 *
524 * Print a summary of the results.
525 *
526  CALL alasvm( path, nout, nfail, nrun, nerrs )
527 *
528  9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
529  $ ', test ', i2, ', ratio =', g12.5 )
530  RETURN
531 *
532 * End of CDRVHE_RK
533 *
alasvm
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:75
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
cerrvx
subroutine cerrvx(PATH, NUNIT)
CERRVX
Definition: cerrvx.f:57
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
cpot02
subroutine cpot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CPOT02
Definition: cpot02.f:129
chetri_3
subroutine chetri_3(UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO)
CHETRI_3
Definition: chetri_3.f:172
clatms
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:334
aladhd
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:92
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
chet01_3
subroutine chet01_3(UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, LDC, RWORK, RESID)
CHET01_3
Definition: chet01_3.f:143
csytri_3
subroutine csytri_3(UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO)
CSYTRI_3
Definition: csytri_3.f:172
clatb4
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:123
chetrf_rk
subroutine chetrf_rk(UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO)
CHETRF_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch...
Definition: chetrf_rk.f:261
chesv_rk
subroutine chesv_rk(UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, WORK, LWORK, INFO)
CHESV_RK computes the solution to system of linear equations A * X = B for SY matrices ...
Definition: chesv_rk.f:230
clanhe
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
cget04
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:104

Here is the call graph for this function:

Here is the caller graph for this function: