LAPACK  3.9.1
LAPACK: Linear Algebra PACKage
zdrvgex.f
Go to the documentation of this file.
1 *> \brief \b ZDRVGEX
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 ZDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
12 * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
13 * RWORK, IWORK, NOUT )
14 *
15 * .. Scalar Arguments ..
16 * LOGICAL TSTERR
17 * INTEGER NMAX, NN, NOUT, NRHS
18 * DOUBLE PRECISION THRESH
19 * ..
20 * .. Array Arguments ..
21 * LOGICAL DOTYPE( * )
22 * INTEGER IWORK( * ), NVAL( * )
23 * DOUBLE PRECISION RWORK( * ), S( * )
24 * COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ),
25 * $ BSAV( * ), WORK( * ), X( * ), XACT( * )
26 * ..
27 *
28 *
29 *> \par Purpose:
30 * =============
31 *>
32 *> \verbatim
33 *>
34 *> ZDRVGE tests the driver routines ZGESV, -SVX, and -SVXX.
35 *>
36 *> Note that this file is used only when the XBLAS are available,
37 *> otherwise zdrvge.f defines this subroutine.
38 *> \endverbatim
39 *
40 * Arguments:
41 * ==========
42 *
43 *> \param[in] DOTYPE
44 *> \verbatim
45 *> DOTYPE is LOGICAL array, dimension (NTYPES)
46 *> The matrix types to be used for testing. Matrices of type j
47 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
48 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
49 *> \endverbatim
50 *>
51 *> \param[in] NN
52 *> \verbatim
53 *> NN is INTEGER
54 *> The number of values of N contained in the vector NVAL.
55 *> \endverbatim
56 *>
57 *> \param[in] NVAL
58 *> \verbatim
59 *> NVAL is INTEGER array, dimension (NN)
60 *> The values of the matrix column dimension N.
61 *> \endverbatim
62 *>
63 *> \param[in] NRHS
64 *> \verbatim
65 *> NRHS is INTEGER
66 *> The number of right hand side vectors to be generated for
67 *> each linear system.
68 *> \endverbatim
69 *>
70 *> \param[in] THRESH
71 *> \verbatim
72 *> THRESH is DOUBLE PRECISION
73 *> The threshold value for the test ratios. A result is
74 *> included in the output file if RESULT >= THRESH. To have
75 *> every test ratio printed, use THRESH = 0.
76 *> \endverbatim
77 *>
78 *> \param[in] TSTERR
79 *> \verbatim
80 *> TSTERR is LOGICAL
81 *> Flag that indicates whether error exits are to be tested.
82 *> \endverbatim
83 *>
84 *> \param[in] NMAX
85 *> \verbatim
86 *> NMAX is INTEGER
87 *> The maximum value permitted for N, used in dimensioning the
88 *> work arrays.
89 *> \endverbatim
90 *>
91 *> \param[out] A
92 *> \verbatim
93 *> A is COMPLEX*16 array, dimension (NMAX*NMAX)
94 *> \endverbatim
95 *>
96 *> \param[out] AFAC
97 *> \verbatim
98 *> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
99 *> \endverbatim
100 *>
101 *> \param[out] ASAV
102 *> \verbatim
103 *> ASAV is COMPLEX*16 array, dimension (NMAX*NMAX)
104 *> \endverbatim
105 *>
106 *> \param[out] B
107 *> \verbatim
108 *> B is COMPLEX*16 array, dimension (NMAX*NRHS)
109 *> \endverbatim
110 *>
111 *> \param[out] BSAV
112 *> \verbatim
113 *> BSAV is COMPLEX*16 array, dimension (NMAX*NRHS)
114 *> \endverbatim
115 *>
116 *> \param[out] X
117 *> \verbatim
118 *> X is COMPLEX*16 array, dimension (NMAX*NRHS)
119 *> \endverbatim
120 *>
121 *> \param[out] XACT
122 *> \verbatim
123 *> XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
124 *> \endverbatim
125 *>
126 *> \param[out] S
127 *> \verbatim
128 *> S is DOUBLE PRECISION array, dimension (2*NMAX)
129 *> \endverbatim
130 *>
131 *> \param[out] WORK
132 *> \verbatim
133 *> WORK is COMPLEX*16 array, dimension
134 *> (NMAX*max(3,NRHS))
135 *> \endverbatim
136 *>
137 *> \param[out] RWORK
138 *> \verbatim
139 *> RWORK is DOUBLE PRECISION array, dimension (2*NRHS+NMAX)
140 *> \endverbatim
141 *>
142 *> \param[out] IWORK
143 *> \verbatim
144 *> IWORK is INTEGER array, dimension (NMAX)
145 *> \endverbatim
146 *>
147 *> \param[in] NOUT
148 *> \verbatim
149 *> NOUT is INTEGER
150 *> The unit number for output.
151 *> \endverbatim
152 *
153 * Authors:
154 * ========
155 *
156 *> \author Univ. of Tennessee
157 *> \author Univ. of California Berkeley
158 *> \author Univ. of Colorado Denver
159 *> \author NAG Ltd.
160 *
161 *> \ingroup complex16_lin
162 *
163 * =====================================================================
164  SUBROUTINE zdrvge( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
165  $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
166  $ RWORK, IWORK, NOUT )
167 *
168 * -- LAPACK test routine --
169 * -- LAPACK is a software package provided by Univ. of Tennessee, --
170 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
171 *
172 * .. Scalar Arguments ..
173  LOGICAL TSTERR
174  INTEGER NMAX, NN, NOUT, NRHS
175  DOUBLE PRECISION THRESH
176 * ..
177 * .. Array Arguments ..
178  LOGICAL DOTYPE( * )
179  INTEGER IWORK( * ), NVAL( * )
180  DOUBLE PRECISION RWORK( * ), S( * )
181  COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ),
182  $ bsav( * ), work( * ), x( * ), xact( * )
183 * ..
184 *
185 * =====================================================================
186 *
187 * .. Parameters ..
188  DOUBLE PRECISION ONE, ZERO
189  PARAMETER ( ONE = 1.0d+0, zero = 0.0d+0 )
190  INTEGER NTYPES
191  parameter( ntypes = 11 )
192  INTEGER NTESTS
193  parameter( ntests = 7 )
194  INTEGER NTRAN
195  parameter( ntran = 3 )
196 * ..
197 * .. Local Scalars ..
198  LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
199  CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
200  CHARACTER*3 PATH
201  INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, ITRAN,
202  $ izero, k, k1, kl, ku, lda, lwork, mode, n, nb,
203  $ nbmin, nerrs, nfact, nfail, nimat, nrun, nt,
204  $ n_err_bnds
205  DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, CNDNUM,
206  $ COLCND, RCOND, RCONDC, RCONDI, RCONDO, ROLDC,
207  $ roldi, roldo, rowcnd, rpvgrw, rpvgrw_svxx
208 * ..
209 * .. Local Arrays ..
210  CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
211  INTEGER ISEED( 4 ), ISEEDY( 4 )
212  DOUBLE PRECISION RDUM( 1 ), RESULT( NTESTS ), BERR( NRHS ),
213  $ errbnds_n( nrhs, 3 ), errbnds_c( nrhs, 3 )
214 * ..
215 * .. External Functions ..
216  LOGICAL LSAME
217  DOUBLE PRECISION DGET06, DLAMCH, ZLANGE, ZLANTR, ZLA_GERPVGRW
218  EXTERNAL lsame, dget06, dlamch, zlange, zlantr,
219  $ zla_gerpvgrw
220 * ..
221 * .. External Subroutines ..
222  EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx, zgeequ,
223  $ zgesv, zgesvx, zget01, zget02, zget04, zget07,
224  $ zgetrf, zgetri, zlacpy, zlaqge, zlarhs, zlaset,
225  $ zlatb4, zlatms, zgesvxx
226 * ..
227 * .. Intrinsic Functions ..
228  INTRINSIC abs, dcmplx, max, dble, dimag
229 * ..
230 * .. Scalars in Common ..
231  LOGICAL LERR, OK
232  CHARACTER*32 SRNAMT
233  INTEGER INFOT, NUNIT
234 * ..
235 * .. Common blocks ..
236  COMMON / infoc / infot, nunit, ok, lerr
237  COMMON / srnamc / srnamt
238 * ..
239 * .. Data statements ..
240  DATA iseedy / 1988, 1989, 1990, 1991 /
241  DATA transs / 'N', 'T', 'C' /
242  DATA facts / 'F', 'N', 'E' /
243  DATA equeds / 'N', 'R', 'C', 'B' /
244 * ..
245 * .. Executable Statements ..
246 *
247 * Initialize constants and the random number seed.
248 *
249  path( 1: 1 ) = 'Zomplex precision'
250  path( 2: 3 ) = 'GE'
251  nrun = 0
252  nfail = 0
253  nerrs = 0
254  DO 10 i = 1, 4
255  iseed( i ) = iseedy( i )
256  10 CONTINUE
257 *
258 * Test the error exits
259 *
260  IF( tsterr )
261  $ CALL zerrvx( path, nout )
262  infot = 0
263 *
264 * Set the block size and minimum block size for testing.
265 *
266  nb = 1
267  nbmin = 2
268  CALL xlaenv( 1, nb )
269  CALL xlaenv( 2, nbmin )
270 *
271 * Do for each value of N in NVAL
272 *
273  DO 90 in = 1, nn
274  n = nval( in )
275  lda = max( n, 1 )
276  xtype = 'N'
277  nimat = ntypes
278  IF( n.LE.0 )
279  $ nimat = 1
280 *
281  DO 80 imat = 1, nimat
282 *
283 * Do the tests only if DOTYPE( IMAT ) is true.
284 *
285  IF( .NOT.dotype( imat ) )
286  $ GO TO 80
287 *
288 * Skip types 5, 6, or 7 if the matrix size is too small.
289 *
290  zerot = imat.GE.5 .AND. imat.LE.7
291  IF( zerot .AND. n.LT.imat-4 )
292  $ GO TO 80
293 *
294 * Set up parameters with ZLATB4 and generate a test matrix
295 * with ZLATMS.
296 *
297  CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
298  $ CNDNUM, DIST )
299  rcondc = one / cndnum
300 *
301  srnamt = 'ZLATMS'
302  CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE, CNDNUM,
303  $ anorm, kl, ku, 'No packing', a, lda, work,
304  $ info )
305 *
306 * Check error code from ZLATMS.
307 *
308  IF( info.NE.0 ) THEN
309  CALL alaerh( path, 'ZLATMS', info, 0, ' ', n, n, -1, -1,
310  $ -1, imat, nfail, nerrs, nout )
311  GO TO 80
312  END IF
313 *
314 * For types 5-7, zero one or more columns of the matrix to
315 * test that INFO is returned correctly.
316 *
317  IF( zerot ) THEN
318  IF( imat.EQ.5 ) THEN
319  izero = 1
320  ELSE IF( imat.EQ.6 ) THEN
321  izero = n
322  ELSE
323  izero = n / 2 + 1
324  END IF
325  ioff = ( izero-1 )*lda
326  IF( imat.LT.7 ) THEN
327  DO 20 i = 1, n
328  a( ioff+i ) = zero
329  20 CONTINUE
330  ELSE
331  CALL zlaset( 'Full', n, n-izero+1, dcmplx( zero ),
332  $ dcmplx( zero ), a( ioff+1 ), lda )
333  END IF
334  ELSE
335  izero = 0
336  END IF
337 *
338 * Save a copy of the matrix A in ASAV.
339 *
340  CALL zlacpy( 'Full', n, n, a, lda, asav, lda )
341 *
342  DO 70 iequed = 1, 4
343  equed = equeds( iequed )
344  IF( iequed.EQ.1 ) THEN
345  nfact = 3
346  ELSE
347  nfact = 1
348  END IF
349 *
350  DO 60 ifact = 1, nfact
351  fact = facts( ifact )
352  prefac = lsame( fact, 'F' )
353  nofact = lsame( fact, 'N' )
354  equil = lsame( fact, 'E' )
355 *
356  IF( zerot ) THEN
357  IF( prefac )
358  $ GO TO 60
359  rcondo = zero
360  rcondi = zero
361 *
362  ELSE IF( .NOT.nofact ) THEN
363 *
364 * Compute the condition number for comparison with
365 * the value returned by ZGESVX (FACT = 'N' reuses
366 * the condition number from the previous iteration
367 * with FACT = 'F').
368 *
369  CALL zlacpy( 'Full', n, n, asav, lda, afac, lda )
370  IF( equil .OR. iequed.GT.1 ) THEN
371 *
372 * Compute row and column scale factors to
373 * equilibrate the matrix A.
374 *
375  CALL zgeequ( n, n, afac, lda, s, s( n+1 ),
376  $ rowcnd, colcnd, amax, info )
377  IF( info.EQ.0 .AND. n.GT.0 ) THEN
378  IF( lsame( equed, 'R' ) ) THEN
379  rowcnd = zero
380  colcnd = one
381  ELSE IF( lsame( equed, 'C' ) ) THEN
382  rowcnd = one
383  colcnd = zero
384  ELSE IF( lsame( equed, 'B' ) ) THEN
385  rowcnd = zero
386  colcnd = zero
387  END IF
388 *
389 * Equilibrate the matrix.
390 *
391  CALL zlaqge( n, n, afac, lda, s, s( n+1 ),
392  $ rowcnd, colcnd, amax, equed )
393  END IF
394  END IF
395 *
396 * Save the condition number of the non-equilibrated
397 * system for use in ZGET04.
398 *
399  IF( equil ) THEN
400  roldo = rcondo
401  roldi = rcondi
402  END IF
403 *
404 * Compute the 1-norm and infinity-norm of A.
405 *
406  anormo = zlange( '1', n, n, afac, lda, rwork )
407  anormi = zlange( 'I', n, n, afac, lda, rwork )
408 *
409 * Factor the matrix A.
410 *
411  CALL zgetrf( n, n, afac, lda, iwork, info )
412 *
413 * Form the inverse of A.
414 *
415  CALL zlacpy( 'Full', n, n, afac, lda, a, lda )
416  lwork = nmax*max( 3, nrhs )
417  CALL zgetri( n, a, lda, iwork, work, lwork, info )
418 *
419 * Compute the 1-norm condition number of A.
420 *
421  ainvnm = zlange( '1', n, n, a, lda, rwork )
422  IF( anormo.LE.zero .OR. ainvnm.LE.zero ) THEN
423  rcondo = one
424  ELSE
425  rcondo = ( one / anormo ) / ainvnm
426  END IF
427 *
428 * Compute the infinity-norm condition number of A.
429 *
430  ainvnm = zlange( 'I', n, n, a, lda, rwork )
431  IF( anormi.LE.zero .OR. ainvnm.LE.zero ) THEN
432  rcondi = one
433  ELSE
434  rcondi = ( one / anormi ) / ainvnm
435  END IF
436  END IF
437 *
438  DO 50 itran = 1, ntran
439 *
440 * Do for each value of TRANS.
441 *
442  trans = transs( itran )
443  IF( itran.EQ.1 ) THEN
444  rcondc = rcondo
445  ELSE
446  rcondc = rcondi
447  END IF
448 *
449 * Restore the matrix A.
450 *
451  CALL zlacpy( 'Full', n, n, asav, lda, a, lda )
452 *
453 * Form an exact solution and set the right hand side.
454 *
455  srnamt = 'ZLARHS'
456  CALL zlarhs( path, xtype, 'Full', trans, n, n, kl,
457  $ ku, nrhs, a, lda, xact, lda, b, lda,
458  $ iseed, info )
459  xtype = 'C'
460  CALL zlacpy( 'Full', n, nrhs, b, lda, bsav, lda )
461 *
462  IF( nofact .AND. itran.EQ.1 ) THEN
463 *
464 * --- Test ZGESV ---
465 *
466 * Compute the LU factorization of the matrix and
467 * solve the system.
468 *
469  CALL zlacpy( 'Full', n, n, a, lda, afac, lda )
470  CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
471 *
472  srnamt = 'ZGESV '
473  CALL zgesv( n, nrhs, afac, lda, iwork, x, lda,
474  $ info )
475 *
476 * Check error code from ZGESV .
477 *
478  IF( info.NE.izero )
479  $ CALL alaerh( path, 'ZGESV ', info, izero,
480  $ ' ', n, n, -1, -1, nrhs, imat,
481  $ nfail, nerrs, nout )
482 *
483 * Reconstruct matrix from factors and compute
484 * residual.
485 *
486  CALL zget01( n, n, a, lda, afac, lda, iwork,
487  $ rwork, result( 1 ) )
488  nt = 1
489  IF( izero.EQ.0 ) THEN
490 *
491 * Compute residual of the computed solution.
492 *
493  CALL zlacpy( 'Full', n, nrhs, b, lda, work,
494  $ lda )
495  CALL zget02( 'No transpose', n, n, nrhs, a,
496  $ lda, x, lda, work, lda, rwork,
497  $ result( 2 ) )
498 *
499 * Check solution from generated exact solution.
500 *
501  CALL zget04( n, nrhs, x, lda, xact, lda,
502  $ rcondc, result( 3 ) )
503  nt = 3
504  END IF
505 *
506 * Print information about the tests that did not
507 * pass the threshold.
508 *
509  DO 30 k = 1, nt
510  IF( result( k ).GE.thresh ) THEN
511  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
512  $ CALL aladhd( nout, path )
513  WRITE( nout, fmt = 9999 )'ZGESV ', n,
514  $ imat, k, result( k )
515  nfail = nfail + 1
516  END IF
517  30 CONTINUE
518  nrun = nrun + nt
519  END IF
520 *
521 * --- Test ZGESVX ---
522 *
523  IF( .NOT.prefac )
524  $ CALL zlaset( 'Full', n, n, dcmplx( zero ),
525  $ dcmplx( zero ), afac, lda )
526  CALL zlaset( 'Full', n, nrhs, dcmplx( zero ),
527  $ dcmplx( zero ), x, lda )
528  IF( iequed.GT.1 .AND. n.GT.0 ) THEN
529 *
530 * Equilibrate the matrix if FACT = 'F' and
531 * EQUED = 'R', 'C', or 'B'.
532 *
533  CALL zlaqge( n, n, a, lda, s, s( n+1 ), rowcnd,
534  $ colcnd, amax, equed )
535  END IF
536 *
537 * Solve the system and compute the condition number
538 * and error bounds using ZGESVX.
539 *
540  srnamt = 'ZGESVX'
541  CALL zgesvx( fact, trans, n, nrhs, a, lda, afac,
542  $ lda, iwork, equed, s, s( n+1 ), b,
543  $ lda, x, lda, rcond, rwork,
544  $ rwork( nrhs+1 ), work,
545  $ rwork( 2*nrhs+1 ), info )
546 *
547 * Check the error code from ZGESVX.
548 *
549  IF( info.NE.izero )
550  $ CALL alaerh( path, 'ZGESVX', info, izero,
551  $ fact // trans, n, n, -1, -1, nrhs,
552  $ imat, nfail, nerrs, nout )
553 *
554 * Compare RWORK(2*NRHS+1) from ZGESVX with the
555 * computed reciprocal pivot growth factor RPVGRW
556 *
557  IF( info.NE.0 ) THEN
558  rpvgrw = zlantr( 'M', 'U', 'N', info, info,
559  $ afac, lda, rdum )
560  IF( rpvgrw.EQ.zero ) THEN
561  rpvgrw = one
562  ELSE
563  rpvgrw = zlange( 'M', n, info, a, lda,
564  $ rdum ) / rpvgrw
565  END IF
566  ELSE
567  rpvgrw = zlantr( 'M', 'U', 'N', n, n, afac, lda,
568  $ rdum )
569  IF( rpvgrw.EQ.zero ) THEN
570  rpvgrw = one
571  ELSE
572  rpvgrw = zlange( 'M', n, n, a, lda, rdum ) /
573  $ rpvgrw
574  END IF
575  END IF
576  result( 7 ) = abs( rpvgrw-rwork( 2*nrhs+1 ) ) /
577  $ max( rwork( 2*nrhs+1 ), rpvgrw ) /
578  $ dlamch( 'E' )
579 *
580  IF( .NOT.prefac ) THEN
581 *
582 * Reconstruct matrix from factors and compute
583 * residual.
584 *
585  CALL zget01( n, n, a, lda, afac, lda, iwork,
586  $ rwork( 2*nrhs+1 ), result( 1 ) )
587  k1 = 1
588  ELSE
589  k1 = 2
590  END IF
591 *
592  IF( info.EQ.0 ) THEN
593  trfcon = .false.
594 *
595 * Compute residual of the computed solution.
596 *
597  CALL zlacpy( 'Full', n, nrhs, bsav, lda, work,
598  $ lda )
599  CALL zget02( trans, n, n, nrhs, asav, lda, x,
600  $ lda, work, lda, rwork( 2*nrhs+1 ),
601  $ result( 2 ) )
602 *
603 * Check solution from generated exact solution.
604 *
605  IF( nofact .OR. ( prefac .AND. lsame( equed,
606  $ 'N' ) ) ) THEN
607  CALL zget04( n, nrhs, x, lda, xact, lda,
608  $ rcondc, result( 3 ) )
609  ELSE
610  IF( itran.EQ.1 ) THEN
611  roldc = roldo
612  ELSE
613  roldc = roldi
614  END IF
615  CALL zget04( n, nrhs, x, lda, xact, lda,
616  $ roldc, result( 3 ) )
617  END IF
618 *
619 * Check the error bounds from iterative
620 * refinement.
621 *
622  CALL zget07( trans, n, nrhs, asav, lda, b, lda,
623  $ x, lda, xact, lda, rwork, .true.,
624  $ rwork( nrhs+1 ), result( 4 ) )
625  ELSE
626  trfcon = .true.
627  END IF
628 *
629 * Compare RCOND from ZGESVX with the computed value
630 * in RCONDC.
631 *
632  result( 6 ) = dget06( rcond, rcondc )
633 *
634 * Print information about the tests that did not pass
635 * the threshold.
636 *
637  IF( .NOT.trfcon ) THEN
638  DO 40 k = k1, ntests
639  IF( result( k ).GE.thresh ) THEN
640  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
641  $ CALL aladhd( nout, path )
642  IF( prefac ) THEN
643  WRITE( nout, fmt = 9997 )'ZGESVX',
644  $ fact, trans, n, equed, imat, k,
645  $ result( k )
646  ELSE
647  WRITE( nout, fmt = 9998 )'ZGESVX',
648  $ fact, trans, n, imat, k, result( k )
649  END IF
650  nfail = nfail + 1
651  END IF
652  40 CONTINUE
653  nrun = nrun + 7 - k1
654  ELSE
655  IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
656  $ THEN
657  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
658  $ CALL aladhd( nout, path )
659  IF( prefac ) THEN
660  WRITE( nout, fmt = 9997 )'ZGESVX', fact,
661  $ trans, n, equed, imat, 1, result( 1 )
662  ELSE
663  WRITE( nout, fmt = 9998 )'ZGESVX', fact,
664  $ trans, n, imat, 1, result( 1 )
665  END IF
666  nfail = nfail + 1
667  nrun = nrun + 1
668  END IF
669  IF( result( 6 ).GE.thresh ) THEN
670  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
671  $ CALL aladhd( nout, path )
672  IF( prefac ) THEN
673  WRITE( nout, fmt = 9997 )'ZGESVX', fact,
674  $ trans, n, equed, imat, 6, result( 6 )
675  ELSE
676  WRITE( nout, fmt = 9998 )'ZGESVX', fact,
677  $ trans, n, imat, 6, result( 6 )
678  END IF
679  nfail = nfail + 1
680  nrun = nrun + 1
681  END IF
682  IF( result( 7 ).GE.thresh ) THEN
683  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
684  $ CALL aladhd( nout, path )
685  IF( prefac ) THEN
686  WRITE( nout, fmt = 9997 )'ZGESVX', fact,
687  $ trans, n, equed, imat, 7, result( 7 )
688  ELSE
689  WRITE( nout, fmt = 9998 )'ZGESVX', fact,
690  $ trans, n, imat, 7, result( 7 )
691  END IF
692  nfail = nfail + 1
693  nrun = nrun + 1
694  END IF
695 *
696  END IF
697 *
698 * --- Test ZGESVXX ---
699 *
700 * Restore the matrices A and B.
701 *
702 
703  CALL zlacpy( 'Full', n, n, asav, lda, a, lda )
704  CALL zlacpy( 'Full', n, nrhs, bsav, lda, b, lda )
705 
706  IF( .NOT.prefac )
707  $ CALL zlaset( 'Full', n, n, zero, zero, afac,
708  $ lda )
709  CALL zlaset( 'Full', n, nrhs, zero, zero, x, lda )
710  IF( iequed.GT.1 .AND. n.GT.0 ) THEN
711 *
712 * Equilibrate the matrix if FACT = 'F' and
713 * EQUED = 'R', 'C', or 'B'.
714 *
715  CALL zlaqge( n, n, a, lda, s, s( n+1 ), rowcnd,
716  $ colcnd, amax, equed )
717  END IF
718 *
719 * Solve the system and compute the condition number
720 * and error bounds using ZGESVXX.
721 *
722  srnamt = 'ZGESVXX'
723  n_err_bnds = 3
724  CALL zgesvxx( fact, trans, n, nrhs, a, lda, afac,
725  $ lda, iwork, equed, s, s( n+1 ), b, lda, x,
726  $ lda, rcond, rpvgrw_svxx, berr, n_err_bnds,
727  $ errbnds_n, errbnds_c, 0, zero, work,
728  $ rwork, info )
729 *
730 * Check the error code from ZGESVXX.
731 *
732  IF( info.EQ.n+1 ) GOTO 50
733  IF( info.NE.izero ) THEN
734  CALL alaerh( path, 'ZGESVXX', info, izero,
735  $ fact // trans, n, n, -1, -1, nrhs,
736  $ imat, nfail, nerrs, nout )
737  GOTO 50
738  END IF
739 *
740 * Compare rpvgrw_svxx from ZGESVXX with the computed
741 * reciprocal pivot growth factor RPVGRW
742 *
743 
744  IF ( info .GT. 0 .AND. info .LT. n+1 ) THEN
745  rpvgrw = zla_gerpvgrw
746  $ (n, info, a, lda, afac, lda)
747  ELSE
748  rpvgrw = zla_gerpvgrw
749  $ (n, n, a, lda, afac, lda)
750  ENDIF
751 
752  result( 7 ) = abs( rpvgrw-rpvgrw_svxx ) /
753  $ max( rpvgrw_svxx, rpvgrw ) /
754  $ dlamch( 'E' )
755 *
756  IF( .NOT.prefac ) THEN
757 *
758 * Reconstruct matrix from factors and compute
759 * residual.
760 *
761  CALL zget01( n, n, a, lda, afac, lda, iwork,
762  $ rwork( 2*nrhs+1 ), result( 1 ) )
763  k1 = 1
764  ELSE
765  k1 = 2
766  END IF
767 *
768  IF( info.EQ.0 ) THEN
769  trfcon = .false.
770 *
771 * Compute residual of the computed solution.
772 *
773  CALL zlacpy( 'Full', n, nrhs, bsav, lda, work,
774  $ lda )
775  CALL zget02( trans, n, n, nrhs, asav, lda, x,
776  $ lda, work, lda, rwork( 2*nrhs+1 ),
777  $ result( 2 ) )
778 *
779 * Check solution from generated exact solution.
780 *
781  IF( nofact .OR. ( prefac .AND. lsame( equed,
782  $ 'N' ) ) ) THEN
783  CALL zget04( n, nrhs, x, lda, xact, lda,
784  $ rcondc, result( 3 ) )
785  ELSE
786  IF( itran.EQ.1 ) THEN
787  roldc = roldo
788  ELSE
789  roldc = roldi
790  END IF
791  CALL zget04( n, nrhs, x, lda, xact, lda,
792  $ roldc, result( 3 ) )
793  END IF
794  ELSE
795  trfcon = .true.
796  END IF
797 *
798 * Compare RCOND from ZGESVXX with the computed value
799 * in RCONDC.
800 *
801  result( 6 ) = dget06( rcond, rcondc )
802 *
803 * Print information about the tests that did not pass
804 * the threshold.
805 *
806  IF( .NOT.trfcon ) THEN
807  DO 45 k = k1, ntests
808  IF( result( k ).GE.thresh ) THEN
809  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
810  $ CALL aladhd( nout, path )
811  IF( prefac ) THEN
812  WRITE( nout, fmt = 9997 )'ZGESVXX',
813  $ fact, trans, n, equed, imat, k,
814  $ result( k )
815  ELSE
816  WRITE( nout, fmt = 9998 )'ZGESVXX',
817  $ fact, trans, n, imat, k, result( k )
818  END IF
819  nfail = nfail + 1
820  END IF
821  45 CONTINUE
822  nrun = nrun + 7 - k1
823  ELSE
824  IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
825  $ THEN
826  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
827  $ CALL aladhd( nout, path )
828  IF( prefac ) THEN
829  WRITE( nout, fmt = 9997 )'ZGESVXX', fact,
830  $ trans, n, equed, imat, 1, result( 1 )
831  ELSE
832  WRITE( nout, fmt = 9998 )'ZGESVXX', fact,
833  $ trans, n, imat, 1, result( 1 )
834  END IF
835  nfail = nfail + 1
836  nrun = nrun + 1
837  END IF
838  IF( result( 6 ).GE.thresh ) THEN
839  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
840  $ CALL aladhd( nout, path )
841  IF( prefac ) THEN
842  WRITE( nout, fmt = 9997 )'ZGESVXX', fact,
843  $ trans, n, equed, imat, 6, result( 6 )
844  ELSE
845  WRITE( nout, fmt = 9998 )'ZGESVXX', fact,
846  $ trans, n, imat, 6, result( 6 )
847  END IF
848  nfail = nfail + 1
849  nrun = nrun + 1
850  END IF
851  IF( result( 7 ).GE.thresh ) THEN
852  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
853  $ CALL aladhd( nout, path )
854  IF( prefac ) THEN
855  WRITE( nout, fmt = 9997 )'ZGESVXX', fact,
856  $ trans, n, equed, imat, 7, result( 7 )
857  ELSE
858  WRITE( nout, fmt = 9998 )'ZGESVXX', fact,
859  $ trans, n, imat, 7, result( 7 )
860  END IF
861  nfail = nfail + 1
862  nrun = nrun + 1
863  END IF
864 *
865  END IF
866 *
867  50 CONTINUE
868  60 CONTINUE
869  70 CONTINUE
870  80 CONTINUE
871  90 CONTINUE
872 *
873 * Print a summary of the results.
874 *
875  CALL alasvm( path, nout, nfail, nrun, nerrs )
876 *
877 
878 * Test Error Bounds for ZGESVXX
879 
880  CALL zebchvxx(thresh, path)
881 
882  9999 FORMAT( 1x, a, ', N =', i5, ', type ', i2, ', test(', i2, ') =',
883  $ g12.5 )
884  9998 FORMAT( 1x, a, ', FACT=''', a1, ''', TRANS=''', a1, ''', N=', i5,
885  $ ', type ', i2, ', test(', i1, ')=', g12.5 )
886  9997 FORMAT( 1x, a, ', FACT=''', a1, ''', TRANS=''', a1, ''', N=', i5,
887  $ ', EQUED=''', a1, ''', type ', i2, ', test(', i1, ')=',
888  $ g12.5 )
889  RETURN
890 *
891 * End of ZDRVGE
892 *
893  END
alasvm
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:73
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:81
aladhd
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:90
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:147
zget02
subroutine zget02(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
ZGET02
Definition: zget02.f:133
zlarhs
subroutine zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
Definition: zlarhs.f:209
zebchvxx
subroutine zebchvxx(THRESH, PATH)
ZEBCHVXX
Definition: zebchvxx.f:96
zerrvx
subroutine zerrvx(PATH, NUNIT)
ZERRVX
Definition: zerrvx.f:55
zdrvge
subroutine zdrvge(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
ZDRVGE
Definition: zdrvge.f:164
zget04
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
Definition: zget04.f:102
zget01
subroutine zget01(M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, RESID)
ZGET01
Definition: zget01.f:108
zlatb4
subroutine zlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
ZLATB4
Definition: zlatb4.f:121
zget07
subroutine zget07(TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, CHKFERR, BERR, RESLTS)
ZGET07
Definition: zget07.f:166
zlatms
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
Definition: zlatms.f:332
zlaqge
subroutine zlaqge(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED)
ZLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ.
Definition: zlaqge.f:143
zgeequ
subroutine zgeequ(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO)
ZGEEQU
Definition: zgeequ.f:140
zgetri
subroutine zgetri(N, A, LDA, IPIV, WORK, LWORK, INFO)
ZGETRI
Definition: zgetri.f:114
zgesv
subroutine zgesv(N, NRHS, A, LDA, IPIV, B, LDB, INFO)
ZGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver)
Definition: zgesv.f:122
zgesvx
subroutine zgesvx(FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
ZGESVX computes the solution to system of linear equations A * X = B for GE matrices
Definition: zgesvx.f:350
zgesvxx
subroutine zgesvxx(FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO)
ZGESVXX computes the solution to system of linear equations A * X = B for GE matrices
Definition: zgesvxx.f:540
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:103
zlaset
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition: zlaset.f:106
zgetrf
subroutine zgetrf(M, N, A, LDA, IPIV, INFO)
ZGETRF VARIANT: Crout Level 3 BLAS version of the algorithm.
Definition: zgetrf.f:102