LAPACK  3.9.1
LAPACK: Linear Algebra PACKage
cdrvgex.f
Go to the documentation of this file.
1 *> \brief \b CDRVGEX
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 CDRVGE( 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 * REAL THRESH
19 * ..
20 * .. Array Arguments ..
21 * LOGICAL DOTYPE( * )
22 * INTEGER IWORK( * ), NVAL( * )
23 * REAL RWORK( * ), S( * )
24 * COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ),
25 * $ BSAV( * ), WORK( * ), X( * ), XACT( * )
26 * ..
27 *
28 *
29 *> \par Purpose:
30 * =============
31 *>
32 *> \verbatim
33 *>
34 *> CDRVGE tests the driver routines CGESV, -SVX, and -SVXX.
35 *>
36 *> Note that this file is used only when the XBLAS are available,
37 *> otherwise cdrvge.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 REAL
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 array, dimension (NMAX*NMAX)
94 *> \endverbatim
95 *>
96 *> \param[out] AFAC
97 *> \verbatim
98 *> AFAC is COMPLEX array, dimension (NMAX*NMAX)
99 *> \endverbatim
100 *>
101 *> \param[out] ASAV
102 *> \verbatim
103 *> ASAV is COMPLEX array, dimension (NMAX*NMAX)
104 *> \endverbatim
105 *>
106 *> \param[out] B
107 *> \verbatim
108 *> B is COMPLEX array, dimension (NMAX*NRHS)
109 *> \endverbatim
110 *>
111 *> \param[out] BSAV
112 *> \verbatim
113 *> BSAV is COMPLEX array, dimension (NMAX*NRHS)
114 *> \endverbatim
115 *>
116 *> \param[out] X
117 *> \verbatim
118 *> X is COMPLEX array, dimension (NMAX*NRHS)
119 *> \endverbatim
120 *>
121 *> \param[out] XACT
122 *> \verbatim
123 *> XACT is COMPLEX array, dimension (NMAX*NRHS)
124 *> \endverbatim
125 *>
126 *> \param[out] S
127 *> \verbatim
128 *> S is REAL array, dimension (2*NMAX)
129 *> \endverbatim
130 *>
131 *> \param[out] WORK
132 *> \verbatim
133 *> WORK is COMPLEX array, dimension
134 *> (NMAX*max(3,NRHS))
135 *> \endverbatim
136 *>
137 *> \param[out] RWORK
138 *> \verbatim
139 *> RWORK is REAL 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 complex_lin
162 *
163 * =====================================================================
164  SUBROUTINE cdrvge( 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  REAL THRESH
176 * ..
177 * .. Array Arguments ..
178  LOGICAL DOTYPE( * )
179  INTEGER IWORK( * ), NVAL( * )
180  REAL RWORK( * ), S( * )
181  COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ),
182  $ bsav( * ), work( * ), x( * ), xact( * )
183 * ..
184 *
185 * =====================================================================
186 *
187 * .. Parameters ..
188  REAL ONE, ZERO
189  PARAMETER ( ONE = 1.0e+0, zero = 0.0e+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  REAL 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  REAL RDUM( 1 ), RESULT( NTESTS ), BERR( NRHS ),
213  $ errbnds_n( nrhs, 3 ), errbnds_c( nrhs, 3 )
214 * ..
215 * .. External Functions ..
216  LOGICAL LSAME
217  REAL CLANGE, CLANTR, SGET06, SLAMCH, CLA_GERPVGRW
218  EXTERNAL lsame, clange, clantr, sget06, slamch,
219  $ cla_gerpvgrw
220 * ..
221 * .. External Subroutines ..
222  EXTERNAL aladhd, alaerh, alasvm, cerrvx, cgeequ, cgesv,
223  $ cgesvx, cget01, cget02, cget04, cget07, cgetrf,
224  $ cgetri, clacpy, claqge, clarhs, claset, clatb4,
225  $ clatms, xlaenv, cgesvxx
226 * ..
227 * .. Intrinsic Functions ..
228  INTRINSIC abs, cmplx, max
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 ) = 'Complex 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 cerrvx( 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 CLATB4 and generate a test matrix
295 * with CLATMS.
296 *
297  CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
298  $ CNDNUM, DIST )
299  rcondc = one / cndnum
300 *
301  srnamt = 'CLATMS'
302  CALL clatms( 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 CLATMS.
307 *
308  IF( info.NE.0 ) THEN
309  CALL alaerh( path, 'CLATMS', 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 claset( 'Full', n, n-izero+1, cmplx( zero ),
332  $ cmplx( 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 clacpy( '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 CGESVX (FACT = 'N' reuses
366 * the condition number from the previous iteration
367 * with FACT = 'F').
368 *
369  CALL clacpy( '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 cgeequ( 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 claqge( 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 CGET04.
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 = clange( '1', n, n, afac, lda, rwork )
407  anormi = clange( 'I', n, n, afac, lda, rwork )
408 *
409 * Factor the matrix A.
410 *
411  CALL cgetrf( n, n, afac, lda, iwork, info )
412 *
413 * Form the inverse of A.
414 *
415  CALL clacpy( 'Full', n, n, afac, lda, a, lda )
416  lwork = nmax*max( 3, nrhs )
417  CALL cgetri( n, a, lda, iwork, work, lwork, info )
418 *
419 * Compute the 1-norm condition number of A.
420 *
421  ainvnm = clange( '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 = clange( '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 clacpy( 'Full', n, n, asav, lda, a, lda )
452 *
453 * Form an exact solution and set the right hand side.
454 *
455  srnamt = 'CLARHS'
456  CALL clarhs( path, xtype, 'Full', trans, n, n, kl,
457  $ ku, nrhs, a, lda, xact, lda, b, lda,
458  $ iseed, info )
459  xtype = 'C'
460  CALL clacpy( 'Full', n, nrhs, b, lda, bsav, lda )
461 *
462  IF( nofact .AND. itran.EQ.1 ) THEN
463 *
464 * --- Test CGESV ---
465 *
466 * Compute the LU factorization of the matrix and
467 * solve the system.
468 *
469  CALL clacpy( 'Full', n, n, a, lda, afac, lda )
470  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
471 *
472  srnamt = 'CGESV '
473  CALL cgesv( n, nrhs, afac, lda, iwork, x, lda,
474  $ info )
475 *
476 * Check error code from CGESV .
477 *
478  IF( info.NE.izero )
479  $ CALL alaerh( path, 'CGESV ', 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 cget01( 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 clacpy( 'Full', n, nrhs, b, lda, work,
494  $ lda )
495  CALL cget02( '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 cget04( 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 )'CGESV ', 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 CGESVX ---
522 *
523  IF( .NOT.prefac )
524  $ CALL claset( 'Full', n, n, cmplx( zero ),
525  $ cmplx( zero ), afac, lda )
526  CALL claset( 'Full', n, nrhs, cmplx( zero ),
527  $ cmplx( 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 claqge( 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 CGESVX.
539 *
540  srnamt = 'CGESVX'
541  CALL cgesvx( 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 CGESVX.
548 *
549  IF( info.NE.izero )
550  $ CALL alaerh( path, 'CGESVX', info, izero,
551  $ fact // trans, n, n, -1, -1, nrhs,
552  $ imat, nfail, nerrs, nout )
553 *
554 * Compare RWORK(2*NRHS+1) from CGESVX with the
555 * computed reciprocal pivot growth factor RPVGRW
556 *
557  IF( info.NE.0 ) THEN
558  rpvgrw = clantr( 'M', 'U', 'N', info, info,
559  $ afac, lda, rdum )
560  IF( rpvgrw.EQ.zero ) THEN
561  rpvgrw = one
562  ELSE
563  rpvgrw = clange( 'M', n, info, a, lda,
564  $ rdum ) / rpvgrw
565  END IF
566  ELSE
567  rpvgrw = clantr( 'M', 'U', 'N', n, n, afac, lda,
568  $ rdum )
569  IF( rpvgrw.EQ.zero ) THEN
570  rpvgrw = one
571  ELSE
572  rpvgrw = clange( '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  $ slamch( 'E' )
579 *
580  IF( .NOT.prefac ) THEN
581 *
582 * Reconstruct matrix from factors and compute
583 * residual.
584 *
585  CALL cget01( 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 clacpy( 'Full', n, nrhs, bsav, lda, work,
598  $ lda )
599  CALL cget02( 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 cget04( 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 cget04( 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 cget07( 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 CGESVX with the computed value
630 * in RCONDC.
631 *
632  result( 6 ) = sget06( 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 )'CGESVX',
644  $ fact, trans, n, equed, imat, k,
645  $ result( k )
646  ELSE
647  WRITE( nout, fmt = 9998 )'CGESVX',
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 )'CGESVX', fact,
661  $ trans, n, equed, imat, 1, result( 1 )
662  ELSE
663  WRITE( nout, fmt = 9998 )'CGESVX', 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 )'CGESVX', fact,
674  $ trans, n, equed, imat, 6, result( 6 )
675  ELSE
676  WRITE( nout, fmt = 9998 )'CGESVX', 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 )'CGESVX', fact,
687  $ trans, n, equed, imat, 7, result( 7 )
688  ELSE
689  WRITE( nout, fmt = 9998 )'CGESVX', 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 CGESVXX ---
699 *
700 * Restore the matrices A and B.
701 *
702 
703  CALL clacpy( 'Full', n, n, asav, lda, a, lda )
704  CALL clacpy( 'Full', n, nrhs, bsav, lda, b, lda )
705 
706  IF( .NOT.prefac )
707  $ CALL claset( 'Full', n, n, zero, zero, afac,
708  $ lda )
709  CALL claset( '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 claqge( 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 CGESVXX.
721 *
722  srnamt = 'CGESVXX'
723  n_err_bnds = 3
724  CALL cgesvxx( 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 CGESVXX.
731 *
732  IF( info.EQ.n+1 ) GOTO 50
733  IF( info.NE.izero ) THEN
734  CALL alaerh( path, 'CGESVXX', 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 CGESVXX with the computed
741 * reciprocal pivot growth factor RPVGRW
742 *
743 
744  IF ( info .GT. 0 .AND. info .LT. n+1 ) THEN
745  rpvgrw = cla_gerpvgrw
746  $ (n, info, a, lda, afac, lda)
747  ELSE
748  rpvgrw = cla_gerpvgrw
749  $ (n, n, a, lda, afac, lda)
750  ENDIF
751 
752  result( 7 ) = abs( rpvgrw-rpvgrw_svxx ) /
753  $ max( rpvgrw_svxx, rpvgrw ) /
754  $ slamch( 'E' )
755 *
756  IF( .NOT.prefac ) THEN
757 *
758 * Reconstruct matrix from factors and compute
759 * residual.
760 *
761  CALL cget01( 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 clacpy( 'Full', n, nrhs, bsav, lda, work,
774  $ lda )
775  CALL cget02( 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 cget04( 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 cget04( 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 CGESVXX with the computed value
799 * in RCONDC.
800 *
801  result( 6 ) = sget06( 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 )'CGESVXX',
813  $ fact, trans, n, equed, imat, k,
814  $ result( k )
815  ELSE
816  WRITE( nout, fmt = 9998 )'CGESVXX',
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 )'CGESVXX', fact,
830  $ trans, n, equed, imat, 1, result( 1 )
831  ELSE
832  WRITE( nout, fmt = 9998 )'CGESVXX', 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 )'CGESVXX', fact,
843  $ trans, n, equed, imat, 6, result( 6 )
844  ELSE
845  WRITE( nout, fmt = 9998 )'CGESVXX', 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 )'CGESVXX', fact,
856  $ trans, n, equed, imat, 7, result( 7 )
857  ELSE
858  WRITE( nout, fmt = 9998 )'CGESVXX', 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 CGESVXX
879 
880  CALL cebchvxx(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 CDRVGE
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
clarhs
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
Definition: clarhs.f:209
cget02
subroutine cget02(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CGET02
Definition: cget02.f:133
cget01
subroutine cget01(M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, RESID)
CGET01
Definition: cget01.f:108
cdrvge
subroutine cdrvge(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
CDRVGE
Definition: cdrvge.f:164
clatb4
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:121
cget04
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:102
cget07
subroutine cget07(TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, CHKFERR, BERR, RESLTS)
CGET07
Definition: cget07.f:166
cebchvxx
subroutine cebchvxx(THRESH, PATH)
CEBCHVXX
Definition: cebchvxx.f:96
cerrvx
subroutine cerrvx(PATH, NUNIT)
CERRVX
Definition: cerrvx.f:55
clatms
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:332
claqge
subroutine claqge(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED)
CLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ.
Definition: claqge.f:143
cgeequ
subroutine cgeequ(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO)
CGEEQU
Definition: cgeequ.f:140
cgetri
subroutine cgetri(N, A, LDA, IPIV, WORK, LWORK, INFO)
CGETRI
Definition: cgetri.f:114
cgetrf
subroutine cgetrf(M, N, A, LDA, IPIV, INFO)
CGETRF
Definition: cgetrf.f:108
cgesvxx
subroutine cgesvxx(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)
CGESVXX computes the solution to system of linear equations A * X = B for GE matrices
Definition: cgesvxx.f:543
cgesvx
subroutine cgesvx(FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
CGESVX computes the solution to system of linear equations A * X = B for GE matrices
Definition: cgesvx.f:350
cgesv
subroutine cgesv(N, NRHS, A, LDA, IPIV, B, LDB, INFO)
CGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver)
Definition: cgesv.f:122
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:106
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:103