LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cdrvsy_rook ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NRHS,
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 
)

CDRVSY_ROOK

Purpose: 
 CDRVSY_ROOK tests the driver routines CSYSV_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 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*NRHS)
[out]X
          X is COMPLEX array, dimension (NMAX*NRHS)
[out]XACT
          XACT is COMPLEX array, dimension (NMAX*NRHS)
[out]WORK
[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
November 2013

Definition at line 154 of file cdrvsy_rook.f.

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

Here is the call graph for this function:

Here is the caller graph for this function: