LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine zdrvhe_rook ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NRHS,
double precision  THRESH,
logical  TSTERR,
integer  NMAX,
complex*16, dimension( * )  A,
complex*16, dimension( * )  AFAC,
complex*16, dimension( * )  AINV,
complex*16, dimension( * )  B,
complex*16, dimension( * )  X,
complex*16, dimension( * )  XACT,
complex*16, dimension( * )  WORK,
double precision, dimension( * )  RWORK,
integer, dimension( * )  IWORK,
integer  NOUT 
)

ZDRVHE_ROOK

Purpose: 
 ZDRVHE_ROOK tests the driver routines ZHESV_ROOK.
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 DOUBLE PRECISION
          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*16 array, dimension (NMAX*NMAX)
[out]AFAC
          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
[out]AINV
          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
[out]B
          B is COMPLEX*16 array, dimension (NMAX*NRHS)
[out]X
          X is COMPLEX*16 array, dimension (NMAX*NRHS)
[out]XACT
          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
[out]WORK
          WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
[out]RWORK
          RWORK is DOUBLE PRECISION 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
November 2013

Definition at line 155 of file zdrvhe_rook.f.

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

Here is the call graph for this function:

Here is the caller graph for this function: