LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
cdrvsy.f
Go to the documentation of this file.
1 *> \brief \b CDRVSY
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE CDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
12 * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
13 * NOUT )
14 *
15 * .. Scalar Arguments ..
16 * LOGICAL TSTERR
17 * INTEGER NMAX, NN, NOUT, NRHS
18 * REAL THRESH
19 * ..
20 * .. Array Arguments ..
21 * LOGICAL DOTYPE( * )
22 * INTEGER IWORK( * ), NVAL( * )
23 * REAL RWORK( * )
24 * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
25 * $ WORK( * ), X( * ), XACT( * )
26 * ..
27 *
28 *
29 *> \par Purpose:
30 * =============
31 *>
32 *> \verbatim
33 *>
34 *> CDRVSY tests the driver routines CSYSV and -SVX.
35 *> \endverbatim
36 *
37 * Arguments:
38 * ==========
39 *
40 *> \param[in] DOTYPE
41 *> \verbatim
42 *> DOTYPE is LOGICAL array, dimension (NTYPES)
43 *> The matrix types to be used for testing. Matrices of type j
44 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
45 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
46 *> \endverbatim
47 *>
48 *> \param[in] NN
49 *> \verbatim
50 *> NN is INTEGER
51 *> The number of values of N contained in the vector NVAL.
52 *> \endverbatim
53 *>
54 *> \param[in] NVAL
55 *> \verbatim
56 *> NVAL is INTEGER array, dimension (NN)
57 *> The values of the matrix dimension N.
58 *> \endverbatim
59 *>
60 *> \param[in] NRHS
61 *> \verbatim
62 *> NRHS is INTEGER
63 *> The number of right hand side vectors to be generated for
64 *> each linear system.
65 *> \endverbatim
66 *>
67 *> \param[in] THRESH
68 *> \verbatim
69 *> THRESH is REAL
70 *> The threshold value for the test ratios. A result is
71 *> included in the output file if RESULT >= THRESH. To have
72 *> every test ratio printed, use THRESH = 0.
73 *> \endverbatim
74 *>
75 *> \param[in] TSTERR
76 *> \verbatim
77 *> TSTERR is LOGICAL
78 *> Flag that indicates whether error exits are to be tested.
79 *> \endverbatim
80 *>
81 *> \param[in] NMAX
82 *> \verbatim
83 *> NMAX is INTEGER
84 *> The maximum value permitted for N, used in dimensioning the
85 *> work arrays.
86 *> \endverbatim
87 *>
88 *> \param[out] A
89 *> \verbatim
90 *> A is COMPLEX array, dimension (NMAX*NMAX)
91 *> \endverbatim
92 *>
93 *> \param[out] AFAC
94 *> \verbatim
95 *> AFAC is COMPLEX array, dimension (NMAX*NMAX)
96 *> \endverbatim
97 *>
98 *> \param[out] AINV
99 *> \verbatim
100 *> AINV is COMPLEX array, dimension (NMAX*NMAX)
101 *> \endverbatim
102 *>
103 *> \param[out] B
104 *> \verbatim
105 *> B is COMPLEX array, dimension (NMAX*NRHS)
106 *> \endverbatim
107 *>
108 *> \param[out] X
109 *> \verbatim
110 *> X is COMPLEX array, dimension (NMAX*NRHS)
111 *> \endverbatim
112 *>
113 *> \param[out] XACT
114 *> \verbatim
115 *> XACT is COMPLEX array, dimension (NMAX*NRHS)
116 *> \endverbatim
117 *>
118 *> \param[out] WORK
119 *> \verbatim
120 *> WORK is COMPLEX array, dimension (NMAX*max(2,NRHS))
121 *> \endverbatim
122 *>
123 *> \param[out] RWORK
124 *> \verbatim
125 *> RWORK is REAL array, dimension (NMAX+2*NRHS)
126 *> \endverbatim
127 *>
128 *> \param[out] IWORK
129 *> \verbatim
130 *> IWORK is INTEGER array, dimension (NMAX)
131 *> \endverbatim
132 *>
133 *> \param[in] NOUT
134 *> \verbatim
135 *> NOUT is INTEGER
136 *> The unit number for output.
137 *> \endverbatim
138 *
139 * Authors:
140 * ========
141 *
142 *> \author Univ. of Tennessee
143 *> \author Univ. of California Berkeley
144 *> \author Univ. of Colorado Denver
145 *> \author NAG Ltd.
146 *
147 *> \date November 2013
148 *
149 *> \ingroup complex_lin
150 *
151 * =====================================================================
152  SUBROUTINE cdrvsy( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
153  $ a, afac, ainv, b, x, xact, work, rwork, iwork,
154  $ nout )
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  REAL THRESH
165 * ..
166 * .. Array Arguments ..
167  LOGICAL DOTYPE( * )
168  INTEGER IWORK( * ), NVAL( * )
169  REAL RWORK( * )
170  COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
171  $ work( * ), x( * ), xact( * )
172 * ..
173 *
174 * =====================================================================
175 *
176 * .. Parameters ..
177  REAL ONE, ZERO
178  parameter ( one = 1.0e+0, zero = 0.0e+0 )
179  INTEGER NTYPES, NTESTS
180  parameter ( ntypes = 11, ntests = 6 )
181  INTEGER NFACT
182  parameter ( nfact = 2 )
183 * ..
184 * .. Local Scalars ..
185  LOGICAL ZEROT
186  CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
187  CHARACTER*3 PATH
188  INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
189  $ izero, j, k, k1, kl, ku, lda, lwork, mode, n,
190  $ nb, nbmin, nerrs, nfail, nimat, nrun, nt
191  REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
192 * ..
193 * .. Local Arrays ..
194  CHARACTER FACTS( nfact ), UPLOS( 2 )
195  INTEGER ISEED( 4 ), ISEEDY( 4 )
196  REAL RESULT( ntests )
197 * ..
198 * .. External Functions ..
199  REAL CLANSY, SGET06
200  EXTERNAL clansy, sget06
201 * ..
202 * .. External Subroutines ..
203  EXTERNAL aladhd, alaerh, alasvm, cerrvx, cget04, clacpy,
206  $ xlaenv
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 cmplx, 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  path( 1: 1 ) = 'Complex precision'
229  path( 2: 3 ) = 'SY'
230  nrun = 0
231  nfail = 0
232  nerrs = 0
233  DO 10 i = 1, 4
234  iseed( i ) = iseedy( i )
235  10 CONTINUE
236  lwork = max( 2*nmax, nmax*nrhs )
237 *
238 * Test the error exits
239 *
240  IF( tsterr )
241  $ CALL cerrvx( path, nout )
242  infot = 0
243 *
244 * Set the block size and minimum block size for testing.
245 *
246  nb = 1
247  nbmin = 2
248  CALL xlaenv( 1, nb )
249  CALL xlaenv( 2, nbmin )
250 *
251 * Do for each value of N in NVAL
252 *
253  DO 180 in = 1, nn
254  n = nval( in )
255  lda = max( n, 1 )
256  xtype = 'N'
257  nimat = ntypes
258  IF( n.LE.0 )
259  $ nimat = 1
260 *
261  DO 170 imat = 1, nimat
262 *
263 * Do the tests only if DOTYPE( IMAT ) is true.
264 *
265  IF( .NOT.dotype( imat ) )
266  $ GO TO 170
267 *
268 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
269 *
270  zerot = imat.GE.3 .AND. imat.LE.6
271  IF( zerot .AND. n.LT.imat-2 )
272  $ GO TO 170
273 *
274 * Do first for UPLO = 'U', then for UPLO = 'L'
275 *
276  DO 160 iuplo = 1, 2
277  uplo = uplos( iuplo )
278 *
279  IF( imat.NE.ntypes ) THEN
280 *
281 * Set up parameters with CLATB4 and generate a test
282 * matrix with CLATMS.
283 *
284  CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
285  $ mode, cndnum, dist )
286 *
287  srnamt = 'CLATMS'
288  CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
289  $ cndnum, anorm, kl, ku, uplo, a, lda,
290  $ work, info )
291 *
292 * Check error code from CLATMS.
293 *
294  IF( info.NE.0 ) THEN
295  CALL alaerh( path, 'CLATMS', info, 0, uplo, n, n,
296  $ -1, -1, -1, imat, nfail, nerrs, nout )
297  GO TO 160
298  END IF
299 *
300 * For types 3-6, zero one or more rows and columns of
301 * the matrix to test that INFO is returned correctly.
302 *
303  IF( zerot ) THEN
304  IF( imat.EQ.3 ) THEN
305  izero = 1
306  ELSE IF( imat.EQ.4 ) THEN
307  izero = n
308  ELSE
309  izero = n / 2 + 1
310  END IF
311 *
312  IF( imat.LT.6 ) THEN
313 *
314 * Set row and column IZERO to zero.
315 *
316  IF( iuplo.EQ.1 ) THEN
317  ioff = ( izero-1 )*lda
318  DO 20 i = 1, izero - 1
319  a( ioff+i ) = zero
320  20 CONTINUE
321  ioff = ioff + izero
322  DO 30 i = izero, n
323  a( ioff ) = zero
324  ioff = ioff + lda
325  30 CONTINUE
326  ELSE
327  ioff = izero
328  DO 40 i = 1, izero - 1
329  a( ioff ) = zero
330  ioff = ioff + lda
331  40 CONTINUE
332  ioff = ioff - izero
333  DO 50 i = izero, n
334  a( ioff+i ) = zero
335  50 CONTINUE
336  END IF
337  ELSE
338  IF( iuplo.EQ.1 ) THEN
339 *
340 * Set the first IZERO rows to zero.
341 *
342  ioff = 0
343  DO 70 j = 1, n
344  i2 = min( j, izero )
345  DO 60 i = 1, i2
346  a( ioff+i ) = zero
347  60 CONTINUE
348  ioff = ioff + lda
349  70 CONTINUE
350  ELSE
351 *
352 * Set the last IZERO rows to zero.
353 *
354  ioff = 0
355  DO 90 j = 1, n
356  i1 = max( j, izero )
357  DO 80 i = i1, n
358  a( ioff+i ) = zero
359  80 CONTINUE
360  ioff = ioff + lda
361  90 CONTINUE
362  END IF
363  END IF
364  ELSE
365  izero = 0
366  END IF
367  ELSE
368 *
369 * IMAT = NTYPES: Use a special block diagonal matrix to
370 * test alternate code for the 2-by-2 blocks.
371 *
372  CALL clatsy( uplo, n, a, lda, iseed )
373  END IF
374 *
375  DO 150 ifact = 1, nfact
376 *
377 * Do first for FACT = 'F', then for other values.
378 *
379  fact = facts( ifact )
380 *
381 * Compute the condition number for comparison with
382 * the value returned by CSYSVX.
383 *
384  IF( zerot ) THEN
385  IF( ifact.EQ.1 )
386  $ GO TO 150
387  rcondc = zero
388 *
389  ELSE IF( ifact.EQ.1 ) THEN
390 *
391 * Compute the 1-norm of A.
392 *
393  anorm = clansy( '1', uplo, n, a, lda, rwork )
394 *
395 * Factor the matrix A.
396 *
397  CALL clacpy( uplo, n, n, a, lda, afac, lda )
398  CALL csytrf( uplo, n, afac, lda, iwork, work,
399  $ lwork, info )
400 *
401 * Compute inv(A) and take its norm.
402 *
403  CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
404  lwork = (n+nb+1)*(nb+3)
405  CALL csytri2( uplo, n, ainv, lda, iwork, work,
406  $ lwork, info )
407  ainvnm = clansy( '1', uplo, n, ainv, lda, rwork )
408 *
409 * Compute the 1-norm condition number of A.
410 *
411  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
412  rcondc = one
413  ELSE
414  rcondc = ( one / anorm ) / ainvnm
415  END IF
416  END IF
417 *
418 * Form an exact solution and set the right hand side.
419 *
420  srnamt = 'CLARHS'
421  CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
422  $ nrhs, a, lda, xact, lda, b, lda, iseed,
423  $ info )
424  xtype = 'C'
425 *
426 * --- Test CSYSV ---
427 *
428  IF( ifact.EQ.2 ) THEN
429  CALL clacpy( uplo, n, n, a, lda, afac, lda )
430  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
431 *
432 * Factor the matrix and solve the system using CSYSV.
433 *
434  srnamt = 'CSYSV '
435  CALL csysv( uplo, n, nrhs, afac, lda, iwork, x,
436  $ lda, work, lwork, info )
437 *
438 * Adjust the expected value of INFO to account for
439 * pivoting.
440 *
441  k = izero
442  IF( k.GT.0 ) THEN
443  100 CONTINUE
444  IF( iwork( k ).LT.0 ) THEN
445  IF( iwork( k ).NE.-k ) THEN
446  k = -iwork( k )
447  GO TO 100
448  END IF
449  ELSE IF( iwork( k ).NE.k ) THEN
450  k = iwork( k )
451  GO TO 100
452  END IF
453  END IF
454 *
455 * Check error code from CSYSV .
456 *
457  IF( info.NE.k ) THEN
458  CALL alaerh( path, 'CSYSV ', info, k, uplo, n,
459  $ n, -1, -1, nrhs, imat, nfail,
460  $ nerrs, nout )
461  GO TO 120
462  ELSE IF( info.NE.0 ) THEN
463  GO TO 120
464  END IF
465 *
466 * Reconstruct matrix from factors and compute
467 * residual.
468 *
469  CALL csyt01( uplo, n, a, lda, afac, lda, iwork,
470  $ ainv, lda, rwork, result( 1 ) )
471 *
472 * Compute residual of the computed solution.
473 *
474  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
475  CALL csyt02( uplo, n, nrhs, a, lda, x, lda, work,
476  $ lda, rwork, result( 2 ) )
477 *
478 * Check solution from generated exact solution.
479 *
480  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
481  $ result( 3 ) )
482  nt = 3
483 *
484 * Print information about the tests that did not pass
485 * the threshold.
486 *
487  DO 110 k = 1, nt
488  IF( result( k ).GE.thresh ) THEN
489  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
490  $ CALL aladhd( nout, path )
491  WRITE( nout, fmt = 9999 )'CSYSV ', uplo, n,
492  $ imat, k, result( k )
493  nfail = nfail + 1
494  END IF
495  110 CONTINUE
496  nrun = nrun + nt
497  120 CONTINUE
498  END IF
499 *
500 * --- Test CSYSVX ---
501 *
502  IF( ifact.EQ.2 )
503  $ CALL claset( uplo, n, n, cmplx( zero ),
504  $ cmplx( zero ), afac, lda )
505  CALL claset( 'Full', n, nrhs, cmplx( zero ),
506  $ cmplx( zero ), x, lda )
507 *
508 * Solve the system and compute the condition number and
509 * error bounds using CSYSVX.
510 *
511  srnamt = 'CSYSVX'
512  CALL csysvx( fact, uplo, n, nrhs, a, lda, afac, lda,
513  $ iwork, b, lda, x, lda, rcond, rwork,
514  $ rwork( nrhs+1 ), work, lwork,
515  $ rwork( 2*nrhs+1 ), info )
516 *
517 * Adjust the expected value of INFO to account for
518 * pivoting.
519 *
520  k = izero
521  IF( k.GT.0 ) THEN
522  130 CONTINUE
523  IF( iwork( k ).LT.0 ) THEN
524  IF( iwork( k ).NE.-k ) THEN
525  k = -iwork( k )
526  GO TO 130
527  END IF
528  ELSE IF( iwork( k ).NE.k ) THEN
529  k = iwork( k )
530  GO TO 130
531  END IF
532  END IF
533 *
534 * Check the error code from CSYSVX.
535 *
536  IF( info.NE.k ) THEN
537  CALL alaerh( path, 'CSYSVX', info, k, fact // uplo,
538  $ n, n, -1, -1, nrhs, imat, nfail,
539  $ nerrs, nout )
540  GO TO 150
541  END IF
542 *
543  IF( info.EQ.0 ) THEN
544  IF( ifact.GE.2 ) THEN
545 *
546 * Reconstruct matrix from factors and compute
547 * residual.
548 *
549  CALL csyt01( uplo, n, a, lda, afac, lda, iwork,
550  $ ainv, lda, rwork( 2*nrhs+1 ),
551  $ result( 1 ) )
552  k1 = 1
553  ELSE
554  k1 = 2
555  END IF
556 *
557 * Compute residual of the computed solution.
558 *
559  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
560  CALL csyt02( uplo, n, nrhs, a, lda, x, lda, work,
561  $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
562 *
563 * Check solution from generated exact solution.
564 *
565  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
566  $ result( 3 ) )
567 *
568 * Check the error bounds from iterative refinement.
569 *
570  CALL cpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
571  $ xact, lda, rwork, rwork( nrhs+1 ),
572  $ result( 4 ) )
573  ELSE
574  k1 = 6
575  END IF
576 *
577 * Compare RCOND from CSYSVX with the computed value
578 * in RCONDC.
579 *
580  result( 6 ) = sget06( rcond, rcondc )
581 *
582 * Print information about the tests that did not pass
583 * the threshold.
584 *
585  DO 140 k = k1, 6
586  IF( result( k ).GE.thresh ) THEN
587  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
588  $ CALL aladhd( nout, path )
589  WRITE( nout, fmt = 9998 )'CSYSVX', fact, uplo,
590  $ n, imat, k, result( k )
591  nfail = nfail + 1
592  END IF
593  140 CONTINUE
594  nrun = nrun + 7 - k1
595 *
596  150 CONTINUE
597 *
598  160 CONTINUE
599  170 CONTINUE
600  180 CONTINUE
601 *
602 * Print a summary of the results.
603 *
604  CALL alasvm( path, nout, nfail, nrun, nerrs )
605 *
606  9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
607  $ ', test ', i2, ', ratio =', g12.5 )
608  9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N =', i5,
609  $ ', type ', i2, ', test ', i2, ', ratio =', g12.5 )
610  RETURN
611 *
612 * End of CDRVSY
613 *
614  END
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:75
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
subroutine clatsy(UPLO, N, X, LDX, ISEED)
CLATSY
Definition: clatsy.f:91
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 csyt02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CSYT02
Definition: csyt02.f:129
subroutine cdrvsy(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
CDRVSY
Definition: cdrvsy.f:155
subroutine cerrvx(PATH, NUNIT)
CERRVX
Definition: cerrvx.f:57
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
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
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:334
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:80
subroutine csytrf(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
CSYTRF
Definition: csytrf.f:184
subroutine csysvx(FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO)
CSYSVX computes the solution to system of linear equations A * X = B for SY matrices ...
Definition: csysvx.f:287
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 csysv(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO)
CSYSV computes the solution to system of linear equations A * X = B for SY matrices ...
Definition: csysv.f:173
subroutine csyt01(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
CSYT01
Definition: csyt01.f:127
subroutine cpot05(UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPOT05
Definition: cpot05.f:167
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:123
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:104
subroutine csytri2(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
CSYTRI2
Definition: csytri2.f:129