1 SUBROUTINE DDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
2 $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
3 $ RWORK, IWORK, NOUT )
4 *
5 * -- LAPACK test routine (version 3.2.1) --
6 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
7 * April 2009
8 *
9 * .. Scalar Arguments ..
10 LOGICAL TSTERR
11 INTEGER NMAX, NN, NOUT, NRHS
12 DOUBLE PRECISION THRESH
13 * ..
14 * .. Array Arguments ..
15 LOGICAL DOTYPE( * )
16 INTEGER IWORK( * ), NVAL( * )
17 DOUBLE PRECISION A( * ), AFAC( * ), ASAV( * ), B( * ),
18 $ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
19 $ X( * ), XACT( * )
20 * ..
21 *
22 * Purpose
23 * =======
24 *
25 * DDRVGE tests the driver routines DGESV, -SVX, and -SVXX.
26 *
27 * Note that this file is used only when the XBLAS are available,
28 * otherwise ddrvge.f defines this subroutine.
29 *
30 * Arguments
31 * =========
32 *
33 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
34 * The matrix types to be used for testing. Matrices of type j
35 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
36 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
37 *
38 * NN (input) INTEGER
39 * The number of values of N contained in the vector NVAL.
40 *
41 * NVAL (input) INTEGER array, dimension (NN)
42 * The values of the matrix column dimension N.
43 *
44 * NRHS (input) INTEGER
45 * The number of right hand side vectors to be generated for
46 * each linear system.
47 *
48 * THRESH (input) DOUBLE PRECISION
49 * The threshold value for the test ratios. A result is
50 * included in the output file if RESULT >= THRESH. To have
51 * every test ratio printed, use THRESH = 0.
52 *
53 * TSTERR (input) LOGICAL
54 * Flag that indicates whether error exits are to be tested.
55 *
56 * NMAX (input) INTEGER
57 * The maximum value permitted for N, used in dimensioning the
58 * work arrays.
59 *
60 * A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
61 *
62 * AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
63 *
64 * ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
65 *
66 * B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
67 *
68 * BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
69 *
70 * X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
71 *
72 * XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
73 *
74 * S (workspace) DOUBLE PRECISION array, dimension (2*NMAX)
75 *
76 * WORK (workspace) DOUBLE PRECISION array, dimension
77 * (NMAX*max(3,NRHS))
78 *
79 * RWORK (workspace) DOUBLE PRECISION array, dimension (2*NRHS+NMAX)
80 *
81 * IWORK (workspace) INTEGER array, dimension (2*NMAX)
82 *
83 * NOUT (input) INTEGER
84 * The unit number for output.
85 *
86 * =====================================================================
87 *
88 * .. Parameters ..
89 DOUBLE PRECISION ONE, ZERO
90 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
91 INTEGER NTYPES
92 PARAMETER ( NTYPES = 11 )
93 INTEGER NTESTS
94 PARAMETER ( NTESTS = 7 )
95 INTEGER NTRAN
96 PARAMETER ( NTRAN = 3 )
97 * ..
98 * .. Local Scalars ..
99 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
100 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
101 CHARACTER*3 PATH
102 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, ITRAN,
103 $ IZERO, K, K1, KL, KU, LDA, LWORK, MODE, N, NB,
104 $ NBMIN, NERRS, NFACT, NFAIL, NIMAT, NRUN, NT,
105 $ N_ERR_BNDS
106 DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, CNDNUM,
107 $ COLCND, RCOND, RCONDC, RCONDI, RCONDO, ROLDC,
108 $ ROLDI, ROLDO, ROWCND, RPVGRW, RPVGRW_SVXX
109 * ..
110 * .. Local Arrays ..
111 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
112 INTEGER ISEED( 4 ), ISEEDY( 4 )
113 DOUBLE PRECISION RESULT( NTESTS ), BERR( NRHS ),
114 $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 )
115 * ..
116 * .. External Functions ..
117 LOGICAL LSAME
118 DOUBLE PRECISION DGET06, DLAMCH, DLANGE, DLANTR, DLA_RPVGRW
119 EXTERNAL LSAME, DGET06, DLAMCH, DLANGE, DLANTR,
120 $ DLA_RPVGRW
121 * ..
122 * .. External Subroutines ..
123 EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGEEQU, DGESV,
124 $ DGESVX, DGET01, DGET02, DGET04, DGET07, DGETRF,
125 $ DGETRI, DLACPY, DLAQGE, DLARHS, DLASET, DLATB4,
126 $ DLATMS, XLAENV, DGESVXX
127 * ..
128 * .. Intrinsic Functions ..
129 INTRINSIC ABS, MAX
130 * ..
131 * .. Scalars in Common ..
132 LOGICAL LERR, OK
133 CHARACTER*32 SRNAMT
134 INTEGER INFOT, NUNIT
135 * ..
136 * .. Common blocks ..
137 COMMON / INFOC / INFOT, NUNIT, OK, LERR
138 COMMON / SRNAMC / SRNAMT
139 * ..
140 * .. Data statements ..
141 DATA ISEEDY / 1988, 1989, 1990, 1991 /
142 DATA TRANSS / 'N', 'T', 'C' /
143 DATA FACTS / 'F', 'N', 'E' /
144 DATA EQUEDS / 'N', 'R', 'C', 'B' /
145 * ..
146 * .. Executable Statements ..
147 *
148 * Initialize constants and the random number seed.
149 *
150 PATH( 1: 1 ) = 'Double precision'
151 PATH( 2: 3 ) = 'GE'
152 NRUN = 0
153 NFAIL = 0
154 NERRS = 0
155 DO 10 I = 1, 4
156 ISEED( I ) = ISEEDY( I )
157 10 CONTINUE
158 *
159 * Test the error exits
160 *
161 IF( TSTERR )
162 $ CALL DERRVX( PATH, NOUT )
163 INFOT = 0
164 *
165 * Set the block size and minimum block size for testing.
166 *
167 NB = 1
168 NBMIN = 2
169 CALL XLAENV( 1, NB )
170 CALL XLAENV( 2, NBMIN )
171 *
172 * Do for each value of N in NVAL
173 *
174 DO 90 IN = 1, NN
175 N = NVAL( IN )
176 LDA = MAX( N, 1 )
177 XTYPE = 'N'
178 NIMAT = NTYPES
179 IF( N.LE.0 )
180 $ NIMAT = 1
181 *
182 DO 80 IMAT = 1, NIMAT
183 *
184 * Do the tests only if DOTYPE( IMAT ) is true.
185 *
186 IF( .NOT.DOTYPE( IMAT ) )
187 $ GO TO 80
188 *
189 * Skip types 5, 6, or 7 if the matrix size is too small.
190 *
191 ZEROT = IMAT.GE.5 .AND. IMAT.LE.7
192 IF( ZEROT .AND. N.LT.IMAT-4 )
193 $ GO TO 80
194 *
195 * Set up parameters with DLATB4 and generate a test matrix
196 * with DLATMS.
197 *
198 CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
199 $ CNDNUM, DIST )
200 RCONDC = ONE / CNDNUM
201 *
202 SRNAMT = 'DLATMS'
203 CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, CNDNUM,
204 $ ANORM, KL, KU, 'No packing', A, LDA, WORK,
205 $ INFO )
206 *
207 * Check error code from DLATMS.
208 *
209 IF( INFO.NE.0 ) THEN
210 CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', N, N, -1, -1,
211 $ -1, IMAT, NFAIL, NERRS, NOUT )
212 GO TO 80
213 END IF
214 *
215 * For types 5-7, zero one or more columns of the matrix to
216 * test that INFO is returned correctly.
217 *
218 IF( ZEROT ) THEN
219 IF( IMAT.EQ.5 ) THEN
220 IZERO = 1
221 ELSE IF( IMAT.EQ.6 ) THEN
222 IZERO = N
223 ELSE
224 IZERO = N / 2 + 1
225 END IF
226 IOFF = ( IZERO-1 )*LDA
227 IF( IMAT.LT.7 ) THEN
228 DO 20 I = 1, N
229 A( IOFF+I ) = ZERO
230 20 CONTINUE
231 ELSE
232 CALL DLASET( 'Full', N, N-IZERO+1, ZERO, ZERO,
233 $ A( IOFF+1 ), LDA )
234 END IF
235 ELSE
236 IZERO = 0
237 END IF
238 *
239 * Save a copy of the matrix A in ASAV.
240 *
241 CALL DLACPY( 'Full', N, N, A, LDA, ASAV, LDA )
242 *
243 DO 70 IEQUED = 1, 4
244 EQUED = EQUEDS( IEQUED )
245 IF( IEQUED.EQ.1 ) THEN
246 NFACT = 3
247 ELSE
248 NFACT = 1
249 END IF
250 *
251 DO 60 IFACT = 1, NFACT
252 FACT = FACTS( IFACT )
253 PREFAC = LSAME( FACT, 'F' )
254 NOFACT = LSAME( FACT, 'N' )
255 EQUIL = LSAME( FACT, 'E' )
256 *
257 IF( ZEROT ) THEN
258 IF( PREFAC )
259 $ GO TO 60
260 RCONDO = ZERO
261 RCONDI = ZERO
262 *
263 ELSE IF( .NOT.NOFACT ) THEN
264 *
265 * Compute the condition number for comparison with
266 * the value returned by DGESVX (FACT = 'N' reuses
267 * the condition number from the previous iteration
268 * with FACT = 'F').
269 *
270 CALL DLACPY( 'Full', N, N, ASAV, LDA, AFAC, LDA )
271 IF( EQUIL .OR. IEQUED.GT.1 ) THEN
272 *
273 * Compute row and column scale factors to
274 * equilibrate the matrix A.
275 *
276 CALL DGEEQU( N, N, AFAC, LDA, S, S( N+1 ),
277 $ ROWCND, COLCND, AMAX, INFO )
278 IF( INFO.EQ.0 .AND. N.GT.0 ) THEN
279 IF( LSAME( EQUED, 'R' ) ) THEN
280 ROWCND = ZERO
281 COLCND = ONE
282 ELSE IF( LSAME( EQUED, 'C' ) ) THEN
283 ROWCND = ONE
284 COLCND = ZERO
285 ELSE IF( LSAME( EQUED, 'B' ) ) THEN
286 ROWCND = ZERO
287 COLCND = ZERO
288 END IF
289 *
290 * Equilibrate the matrix.
291 *
292 CALL DLAQGE( N, N, AFAC, LDA, S, S( N+1 ),
293 $ ROWCND, COLCND, AMAX, EQUED )
294 END IF
295 END IF
296 *
297 * Save the condition number of the non-equilibrated
298 * system for use in DGET04.
299 *
300 IF( EQUIL ) THEN
301 ROLDO = RCONDO
302 ROLDI = RCONDI
303 END IF
304 *
305 * Compute the 1-norm and infinity-norm of A.
306 *
307 ANORMO = DLANGE( '1', N, N, AFAC, LDA, RWORK )
308 ANORMI = DLANGE( 'I', N, N, AFAC, LDA, RWORK )
309 *
310 * Factor the matrix A.
311 *
312 CALL DGETRF( N, N, AFAC, LDA, IWORK, INFO )
313 *
314 * Form the inverse of A.
315 *
316 CALL DLACPY( 'Full', N, N, AFAC, LDA, A, LDA )
317 LWORK = NMAX*MAX( 3, NRHS )
318 CALL DGETRI( N, A, LDA, IWORK, WORK, LWORK, INFO )
319 *
320 * Compute the 1-norm condition number of A.
321 *
322 AINVNM = DLANGE( '1', N, N, A, LDA, RWORK )
323 IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
324 RCONDO = ONE
325 ELSE
326 RCONDO = ( ONE / ANORMO ) / AINVNM
327 END IF
328 *
329 * Compute the infinity-norm condition number of A.
330 *
331 AINVNM = DLANGE( 'I', N, N, A, LDA, RWORK )
332 IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
333 RCONDI = ONE
334 ELSE
335 RCONDI = ( ONE / ANORMI ) / AINVNM
336 END IF
337 END IF
338 *
339 DO 50 ITRAN = 1, NTRAN
340 *
341 * Do for each value of TRANS.
342 *
343 TRANS = TRANSS( ITRAN )
344 IF( ITRAN.EQ.1 ) THEN
345 RCONDC = RCONDO
346 ELSE
347 RCONDC = RCONDI
348 END IF
349 *
350 * Restore the matrix A.
351 *
352 CALL DLACPY( 'Full', N, N, ASAV, LDA, A, LDA )
353 *
354 * Form an exact solution and set the right hand side.
355 *
356 SRNAMT = 'DLARHS'
357 CALL DLARHS( PATH, XTYPE, 'Full', TRANS, N, N, KL,
358 $ KU, NRHS, A, LDA, XACT, LDA, B, LDA,
359 $ ISEED, INFO )
360 XTYPE = 'C'
361 CALL DLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA )
362 *
363 IF( NOFACT .AND. ITRAN.EQ.1 ) THEN
364 *
365 * --- Test DGESV ---
366 *
367 * Compute the LU factorization of the matrix and
368 * solve the system.
369 *
370 CALL DLACPY( 'Full', N, N, A, LDA, AFAC, LDA )
371 CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
372 *
373 SRNAMT = 'DGESV '
374 CALL DGESV( N, NRHS, AFAC, LDA, IWORK, X, LDA,
375 $ INFO )
376 *
377 * Check error code from DGESV .
378 *
379 IF( INFO.NE.IZERO )
380 $ CALL ALAERH( PATH, 'DGESV ', INFO, IZERO,
381 $ ' ', N, N, -1, -1, NRHS, IMAT,
382 $ NFAIL, NERRS, NOUT )
383 *
384 * Reconstruct matrix from factors and compute
385 * residual.
386 *
387 CALL DGET01( N, N, A, LDA, AFAC, LDA, IWORK,
388 $ RWORK, RESULT( 1 ) )
389 NT = 1
390 IF( IZERO.EQ.0 ) THEN
391 *
392 * Compute residual of the computed solution.
393 *
394 CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK,
395 $ LDA )
396 CALL DGET02( 'No transpose', N, N, NRHS, A,
397 $ LDA, X, LDA, WORK, LDA, RWORK,
398 $ RESULT( 2 ) )
399 *
400 * Check solution from generated exact solution.
401 *
402 CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
403 $ RCONDC, RESULT( 3 ) )
404 NT = 3
405 END IF
406 *
407 * Print information about the tests that did not
408 * pass the threshold.
409 *
410 DO 30 K = 1, NT
411 IF( RESULT( K ).GE.THRESH ) THEN
412 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
413 $ CALL ALADHD( NOUT, PATH )
414 WRITE( NOUT, FMT = 9999 )'DGESV ', N,
415 $ IMAT, K, RESULT( K )
416 NFAIL = NFAIL + 1
417 END IF
418 30 CONTINUE
419 NRUN = NRUN + NT
420 END IF
421 *
422 * --- Test DGESVX ---
423 *
424 IF( .NOT.PREFAC )
425 $ CALL DLASET( 'Full', N, N, ZERO, ZERO, AFAC,
426 $ LDA )
427 CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
428 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
429 *
430 * Equilibrate the matrix if FACT = 'F' and
431 * EQUED = 'R', 'C', or 'B'.
432 *
433 CALL DLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND,
434 $ COLCND, AMAX, EQUED )
435 END IF
436 *
437 * Solve the system and compute the condition number
438 * and error bounds using DGESVX.
439 *
440 SRNAMT = 'DGESVX'
441 CALL DGESVX( FACT, TRANS, N, NRHS, A, LDA, AFAC,
442 $ LDA, IWORK, EQUED, S, S( N+1 ), B,
443 $ LDA, X, LDA, RCOND, RWORK,
444 $ RWORK( NRHS+1 ), WORK, IWORK( N+1 ),
445 $ INFO )
446 *
447 * Check the error code from DGESVX.
448 *
449 IF( INFO.NE.IZERO )
450 $ CALL ALAERH( PATH, 'DGESVX', INFO, IZERO,
451 $ FACT // TRANS, N, N, -1, -1, NRHS,
452 $ IMAT, NFAIL, NERRS, NOUT )
453 *
454 * Compare WORK(1) from DGESVX with the computed
455 * reciprocal pivot growth factor RPVGRW
456 *
457 IF( INFO.NE.0 ) THEN
458 RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO,
459 $ AFAC, LDA, WORK )
460 IF( RPVGRW.EQ.ZERO ) THEN
461 RPVGRW = ONE
462 ELSE
463 RPVGRW = DLANGE( 'M', N, INFO, A, LDA,
464 $ WORK ) / RPVGRW
465 END IF
466 ELSE
467 RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AFAC, LDA,
468 $ WORK )
469 IF( RPVGRW.EQ.ZERO ) THEN
470 RPVGRW = ONE
471 ELSE
472 RPVGRW = DLANGE( 'M', N, N, A, LDA, WORK ) /
473 $ RPVGRW
474 END IF
475 END IF
476 RESULT( 7 ) = ABS( RPVGRW-WORK( 1 ) ) /
477 $ MAX( WORK( 1 ), RPVGRW ) /
478 $ DLAMCH( 'E' )
479 *
480 IF( .NOT.PREFAC ) THEN
481 *
482 * Reconstruct matrix from factors and compute
483 * residual.
484 *
485 CALL DGET01( N, N, A, LDA, AFAC, LDA, IWORK,
486 $ RWORK( 2*NRHS+1 ), RESULT( 1 ) )
487 K1 = 1
488 ELSE
489 K1 = 2
490 END IF
491 *
492 IF( INFO.EQ.0 ) THEN
493 TRFCON = .FALSE.
494 *
495 * Compute residual of the computed solution.
496 *
497 CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, WORK,
498 $ LDA )
499 CALL DGET02( TRANS, N, N, NRHS, ASAV, LDA, X,
500 $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ),
501 $ RESULT( 2 ) )
502 *
503 * Check solution from generated exact solution.
504 *
505 IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED,
506 $ 'N' ) ) ) THEN
507 CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
508 $ RCONDC, RESULT( 3 ) )
509 ELSE
510 IF( ITRAN.EQ.1 ) THEN
511 ROLDC = ROLDO
512 ELSE
513 ROLDC = ROLDI
514 END IF
515 CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
516 $ ROLDC, RESULT( 3 ) )
517 END IF
518 *
519 * Check the error bounds from iterative
520 * refinement.
521 *
522 CALL DGET07( TRANS, N, NRHS, ASAV, LDA, B, LDA,
523 $ X, LDA, XACT, LDA, RWORK, .TRUE.,
524 $ RWORK( NRHS+1 ), RESULT( 4 ) )
525 ELSE
526 TRFCON = .TRUE.
527 END IF
528 *
529 * Compare RCOND from DGESVX with the computed value
530 * in RCONDC.
531 *
532 RESULT( 6 ) = DGET06( RCOND, RCONDC )
533 *
534 * Print information about the tests that did not pass
535 * the threshold.
536 *
537 IF( .NOT.TRFCON ) THEN
538 DO 40 K = K1, NTESTS
539 IF( RESULT( K ).GE.THRESH ) THEN
540 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
541 $ CALL ALADHD( NOUT, PATH )
542 IF( PREFAC ) THEN
543 WRITE( NOUT, FMT = 9997 )'DGESVX',
544 $ FACT, TRANS, N, EQUED, IMAT, K,
545 $ RESULT( K )
546 ELSE
547 WRITE( NOUT, FMT = 9998 )'DGESVX',
548 $ FACT, TRANS, N, IMAT, K, RESULT( K )
549 END IF
550 NFAIL = NFAIL + 1
551 END IF
552 40 CONTINUE
553 NRUN = NRUN + 7 - K1
554 ELSE
555 IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC )
556 $ THEN
557 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
558 $ CALL ALADHD( NOUT, PATH )
559 IF( PREFAC ) THEN
560 WRITE( NOUT, FMT = 9997 )'DGESVX', FACT,
561 $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 )
562 ELSE
563 WRITE( NOUT, FMT = 9998 )'DGESVX', FACT,
564 $ TRANS, N, IMAT, 1, RESULT( 1 )
565 END IF
566 NFAIL = NFAIL + 1
567 NRUN = NRUN + 1
568 END IF
569 IF( RESULT( 6 ).GE.THRESH ) THEN
570 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
571 $ CALL ALADHD( NOUT, PATH )
572 IF( PREFAC ) THEN
573 WRITE( NOUT, FMT = 9997 )'DGESVX', FACT,
574 $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 )
575 ELSE
576 WRITE( NOUT, FMT = 9998 )'DGESVX', FACT,
577 $ TRANS, N, IMAT, 6, RESULT( 6 )
578 END IF
579 NFAIL = NFAIL + 1
580 NRUN = NRUN + 1
581 END IF
582 IF( RESULT( 7 ).GE.THRESH ) THEN
583 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
584 $ CALL ALADHD( NOUT, PATH )
585 IF( PREFAC ) THEN
586 WRITE( NOUT, FMT = 9997 )'DGESVX', FACT,
587 $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 )
588 ELSE
589 WRITE( NOUT, FMT = 9998 )'DGESVX', FACT,
590 $ TRANS, N, IMAT, 7, RESULT( 7 )
591 END IF
592 NFAIL = NFAIL + 1
593 NRUN = NRUN + 1
594 END IF
595 *
596 END IF
597 *
598 * --- Test DGESVXX ---
599 *
600 * Restore the matrices A and B.
601 *
602 CALL DLACPY( 'Full', N, N, ASAV, LDA, A, LDA )
603 CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, B, LDA )
604
605 IF( .NOT.PREFAC )
606 $ CALL DLASET( 'Full', N, N, ZERO, ZERO, AFAC,
607 $ LDA )
608 CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
609 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
610 *
611 * Equilibrate the matrix if FACT = 'F' and
612 * EQUED = 'R', 'C', or 'B'.
613 *
614 CALL DLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND,
615 $ COLCND, AMAX, EQUED )
616 END IF
617 *
618 * Solve the system and compute the condition number
619 * and error bounds using DGESVXX.
620 *
621 SRNAMT = 'DGESVXX'
622 N_ERR_BNDS = 3
623 CALL DGESVXX( FACT, TRANS, N, NRHS, A, LDA, AFAC,
624 $ LDA, IWORK, EQUED, S, S( N+1 ), B, LDA, X,
625 $ LDA, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS,
626 $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK,
627 $ IWORK( N+1 ), INFO )
628 *
629 * Check the error code from DGESVXX.
630 *
631 IF( INFO.EQ.N+1 ) GOTO 50
632 IF( INFO.NE.IZERO ) THEN
633 CALL ALAERH( PATH, 'DGESVXX', INFO, IZERO,
634 $ FACT // TRANS, N, N, -1, -1, NRHS,
635 $ IMAT, NFAIL, NERRS, NOUT )
636 GOTO 50
637 END IF
638 *
639 * Compare rpvgrw_svxx from DGESVXX with the computed
640 * reciprocal pivot growth factor RPVGRW
641 *
642
643 IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN
644 RPVGRW = DLA_RPVGRW(N, INFO, A, LDA, AFAC, LDA)
645 ELSE
646 RPVGRW = DLA_RPVGRW(N, N, A, LDA, AFAC, LDA)
647 ENDIF
648
649 RESULT( 7 ) = ABS( RPVGRW-RPVGRW_SVXX ) /
650 $ MAX( RPVGRW_SVXX, RPVGRW ) /
651 $ DLAMCH( 'E' )
652 *
653 IF( .NOT.PREFAC ) THEN
654 *
655 * Reconstruct matrix from factors and compute
656 * residual.
657 *
658 CALL DGET01( N, N, A, LDA, AFAC, LDA, IWORK,
659 $ RWORK( 2*NRHS+1 ), RESULT( 1 ) )
660 K1 = 1
661 ELSE
662 K1 = 2
663 END IF
664 *
665 IF( INFO.EQ.0 ) THEN
666 TRFCON = .FALSE.
667 *
668 * Compute residual of the computed solution.
669 *
670 CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, WORK,
671 $ LDA )
672 CALL DGET02( TRANS, N, N, NRHS, ASAV, LDA, X,
673 $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ),
674 $ RESULT( 2 ) )
675 *
676 * Check solution from generated exact solution.
677 *
678 IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED,
679 $ 'N' ) ) ) THEN
680 CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
681 $ RCONDC, RESULT( 3 ) )
682 ELSE
683 IF( ITRAN.EQ.1 ) THEN
684 ROLDC = ROLDO
685 ELSE
686 ROLDC = ROLDI
687 END IF
688 CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
689 $ ROLDC, RESULT( 3 ) )
690 END IF
691 ELSE
692 TRFCON = .TRUE.
693 END IF
694 *
695 * Compare RCOND from DGESVXX with the computed value
696 * in RCONDC.
697 *
698 RESULT( 6 ) = DGET06( RCOND, RCONDC )
699 *
700 * Print information about the tests that did not pass
701 * the threshold.
702 *
703 IF( .NOT.TRFCON ) THEN
704 DO 45 K = K1, NTESTS
705 IF( RESULT( K ).GE.THRESH ) THEN
706 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
707 $ CALL ALADHD( NOUT, PATH )
708 IF( PREFAC ) THEN
709 WRITE( NOUT, FMT = 9997 )'DGESVXX',
710 $ FACT, TRANS, N, EQUED, IMAT, K,
711 $ RESULT( K )
712 ELSE
713 WRITE( NOUT, FMT = 9998 )'DGESVXX',
714 $ FACT, TRANS, N, IMAT, K, RESULT( K )
715 END IF
716 NFAIL = NFAIL + 1
717 END IF
718 45 CONTINUE
719 NRUN = NRUN + 7 - K1
720 ELSE
721 IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC )
722 $ THEN
723 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
724 $ CALL ALADHD( NOUT, PATH )
725 IF( PREFAC ) THEN
726 WRITE( NOUT, FMT = 9997 )'DGESVXX', FACT,
727 $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 )
728 ELSE
729 WRITE( NOUT, FMT = 9998 )'DGESVXX', FACT,
730 $ TRANS, N, IMAT, 1, RESULT( 1 )
731 END IF
732 NFAIL = NFAIL + 1
733 NRUN = NRUN + 1
734 END IF
735 IF( RESULT( 6 ).GE.THRESH ) THEN
736 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
737 $ CALL ALADHD( NOUT, PATH )
738 IF( PREFAC ) THEN
739 WRITE( NOUT, FMT = 9997 )'DGESVXX', FACT,
740 $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 )
741 ELSE
742 WRITE( NOUT, FMT = 9998 )'DGESVXX', FACT,
743 $ TRANS, N, IMAT, 6, RESULT( 6 )
744 END IF
745 NFAIL = NFAIL + 1
746 NRUN = NRUN + 1
747 END IF
748 IF( RESULT( 7 ).GE.THRESH ) THEN
749 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
750 $ CALL ALADHD( NOUT, PATH )
751 IF( PREFAC ) THEN
752 WRITE( NOUT, FMT = 9997 )'DGESVXX', FACT,
753 $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 )
754 ELSE
755 WRITE( NOUT, FMT = 9998 )'DGESVXX', FACT,
756 $ TRANS, N, IMAT, 7, RESULT( 7 )
757 END IF
758 NFAIL = NFAIL + 1
759 NRUN = NRUN + 1
760 END IF
761 *
762 END IF
763 *
764 50 CONTINUE
765 60 CONTINUE
766 70 CONTINUE
767 80 CONTINUE
768 90 CONTINUE
769 *
770 * Print a summary of the results.
771 *
772 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
773 *
774
775 * Test Error Bounds from DGESVXX
776
777 CALL DEBCHVXX( THRESH, PATH )
778
779 9999 FORMAT( 1X, A, ', N =', I5, ', type ', I2, ', test(', I2, ') =',
780 $ G12.5 )
781 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,
782 $ ', type ', I2, ', test(', I1, ')=', G12.5 )
783 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,
784 $ ', EQUED=''', A1, ''', type ', I2, ', test(', I1, ')=',
785 $ G12.5 )
786 RETURN
787 *
788 * End of DDRVGE
789 *
790 END
2 $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
3 $ RWORK, IWORK, NOUT )
4 *
5 * -- LAPACK test routine (version 3.2.1) --
6 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
7 * April 2009
8 *
9 * .. Scalar Arguments ..
10 LOGICAL TSTERR
11 INTEGER NMAX, NN, NOUT, NRHS
12 DOUBLE PRECISION THRESH
13 * ..
14 * .. Array Arguments ..
15 LOGICAL DOTYPE( * )
16 INTEGER IWORK( * ), NVAL( * )
17 DOUBLE PRECISION A( * ), AFAC( * ), ASAV( * ), B( * ),
18 $ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
19 $ X( * ), XACT( * )
20 * ..
21 *
22 * Purpose
23 * =======
24 *
25 * DDRVGE tests the driver routines DGESV, -SVX, and -SVXX.
26 *
27 * Note that this file is used only when the XBLAS are available,
28 * otherwise ddrvge.f defines this subroutine.
29 *
30 * Arguments
31 * =========
32 *
33 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
34 * The matrix types to be used for testing. Matrices of type j
35 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
36 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
37 *
38 * NN (input) INTEGER
39 * The number of values of N contained in the vector NVAL.
40 *
41 * NVAL (input) INTEGER array, dimension (NN)
42 * The values of the matrix column dimension N.
43 *
44 * NRHS (input) INTEGER
45 * The number of right hand side vectors to be generated for
46 * each linear system.
47 *
48 * THRESH (input) DOUBLE PRECISION
49 * The threshold value for the test ratios. A result is
50 * included in the output file if RESULT >= THRESH. To have
51 * every test ratio printed, use THRESH = 0.
52 *
53 * TSTERR (input) LOGICAL
54 * Flag that indicates whether error exits are to be tested.
55 *
56 * NMAX (input) INTEGER
57 * The maximum value permitted for N, used in dimensioning the
58 * work arrays.
59 *
60 * A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
61 *
62 * AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
63 *
64 * ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
65 *
66 * B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
67 *
68 * BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
69 *
70 * X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
71 *
72 * XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
73 *
74 * S (workspace) DOUBLE PRECISION array, dimension (2*NMAX)
75 *
76 * WORK (workspace) DOUBLE PRECISION array, dimension
77 * (NMAX*max(3,NRHS))
78 *
79 * RWORK (workspace) DOUBLE PRECISION array, dimension (2*NRHS+NMAX)
80 *
81 * IWORK (workspace) INTEGER array, dimension (2*NMAX)
82 *
83 * NOUT (input) INTEGER
84 * The unit number for output.
85 *
86 * =====================================================================
87 *
88 * .. Parameters ..
89 DOUBLE PRECISION ONE, ZERO
90 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
91 INTEGER NTYPES
92 PARAMETER ( NTYPES = 11 )
93 INTEGER NTESTS
94 PARAMETER ( NTESTS = 7 )
95 INTEGER NTRAN
96 PARAMETER ( NTRAN = 3 )
97 * ..
98 * .. Local Scalars ..
99 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
100 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
101 CHARACTER*3 PATH
102 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, ITRAN,
103 $ IZERO, K, K1, KL, KU, LDA, LWORK, MODE, N, NB,
104 $ NBMIN, NERRS, NFACT, NFAIL, NIMAT, NRUN, NT,
105 $ N_ERR_BNDS
106 DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, CNDNUM,
107 $ COLCND, RCOND, RCONDC, RCONDI, RCONDO, ROLDC,
108 $ ROLDI, ROLDO, ROWCND, RPVGRW, RPVGRW_SVXX
109 * ..
110 * .. Local Arrays ..
111 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
112 INTEGER ISEED( 4 ), ISEEDY( 4 )
113 DOUBLE PRECISION RESULT( NTESTS ), BERR( NRHS ),
114 $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 )
115 * ..
116 * .. External Functions ..
117 LOGICAL LSAME
118 DOUBLE PRECISION DGET06, DLAMCH, DLANGE, DLANTR, DLA_RPVGRW
119 EXTERNAL LSAME, DGET06, DLAMCH, DLANGE, DLANTR,
120 $ DLA_RPVGRW
121 * ..
122 * .. External Subroutines ..
123 EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGEEQU, DGESV,
124 $ DGESVX, DGET01, DGET02, DGET04, DGET07, DGETRF,
125 $ DGETRI, DLACPY, DLAQGE, DLARHS, DLASET, DLATB4,
126 $ DLATMS, XLAENV, DGESVXX
127 * ..
128 * .. Intrinsic Functions ..
129 INTRINSIC ABS, MAX
130 * ..
131 * .. Scalars in Common ..
132 LOGICAL LERR, OK
133 CHARACTER*32 SRNAMT
134 INTEGER INFOT, NUNIT
135 * ..
136 * .. Common blocks ..
137 COMMON / INFOC / INFOT, NUNIT, OK, LERR
138 COMMON / SRNAMC / SRNAMT
139 * ..
140 * .. Data statements ..
141 DATA ISEEDY / 1988, 1989, 1990, 1991 /
142 DATA TRANSS / 'N', 'T', 'C' /
143 DATA FACTS / 'F', 'N', 'E' /
144 DATA EQUEDS / 'N', 'R', 'C', 'B' /
145 * ..
146 * .. Executable Statements ..
147 *
148 * Initialize constants and the random number seed.
149 *
150 PATH( 1: 1 ) = 'Double precision'
151 PATH( 2: 3 ) = 'GE'
152 NRUN = 0
153 NFAIL = 0
154 NERRS = 0
155 DO 10 I = 1, 4
156 ISEED( I ) = ISEEDY( I )
157 10 CONTINUE
158 *
159 * Test the error exits
160 *
161 IF( TSTERR )
162 $ CALL DERRVX( PATH, NOUT )
163 INFOT = 0
164 *
165 * Set the block size and minimum block size for testing.
166 *
167 NB = 1
168 NBMIN = 2
169 CALL XLAENV( 1, NB )
170 CALL XLAENV( 2, NBMIN )
171 *
172 * Do for each value of N in NVAL
173 *
174 DO 90 IN = 1, NN
175 N = NVAL( IN )
176 LDA = MAX( N, 1 )
177 XTYPE = 'N'
178 NIMAT = NTYPES
179 IF( N.LE.0 )
180 $ NIMAT = 1
181 *
182 DO 80 IMAT = 1, NIMAT
183 *
184 * Do the tests only if DOTYPE( IMAT ) is true.
185 *
186 IF( .NOT.DOTYPE( IMAT ) )
187 $ GO TO 80
188 *
189 * Skip types 5, 6, or 7 if the matrix size is too small.
190 *
191 ZEROT = IMAT.GE.5 .AND. IMAT.LE.7
192 IF( ZEROT .AND. N.LT.IMAT-4 )
193 $ GO TO 80
194 *
195 * Set up parameters with DLATB4 and generate a test matrix
196 * with DLATMS.
197 *
198 CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
199 $ CNDNUM, DIST )
200 RCONDC = ONE / CNDNUM
201 *
202 SRNAMT = 'DLATMS'
203 CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, CNDNUM,
204 $ ANORM, KL, KU, 'No packing', A, LDA, WORK,
205 $ INFO )
206 *
207 * Check error code from DLATMS.
208 *
209 IF( INFO.NE.0 ) THEN
210 CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', N, N, -1, -1,
211 $ -1, IMAT, NFAIL, NERRS, NOUT )
212 GO TO 80
213 END IF
214 *
215 * For types 5-7, zero one or more columns of the matrix to
216 * test that INFO is returned correctly.
217 *
218 IF( ZEROT ) THEN
219 IF( IMAT.EQ.5 ) THEN
220 IZERO = 1
221 ELSE IF( IMAT.EQ.6 ) THEN
222 IZERO = N
223 ELSE
224 IZERO = N / 2 + 1
225 END IF
226 IOFF = ( IZERO-1 )*LDA
227 IF( IMAT.LT.7 ) THEN
228 DO 20 I = 1, N
229 A( IOFF+I ) = ZERO
230 20 CONTINUE
231 ELSE
232 CALL DLASET( 'Full', N, N-IZERO+1, ZERO, ZERO,
233 $ A( IOFF+1 ), LDA )
234 END IF
235 ELSE
236 IZERO = 0
237 END IF
238 *
239 * Save a copy of the matrix A in ASAV.
240 *
241 CALL DLACPY( 'Full', N, N, A, LDA, ASAV, LDA )
242 *
243 DO 70 IEQUED = 1, 4
244 EQUED = EQUEDS( IEQUED )
245 IF( IEQUED.EQ.1 ) THEN
246 NFACT = 3
247 ELSE
248 NFACT = 1
249 END IF
250 *
251 DO 60 IFACT = 1, NFACT
252 FACT = FACTS( IFACT )
253 PREFAC = LSAME( FACT, 'F' )
254 NOFACT = LSAME( FACT, 'N' )
255 EQUIL = LSAME( FACT, 'E' )
256 *
257 IF( ZEROT ) THEN
258 IF( PREFAC )
259 $ GO TO 60
260 RCONDO = ZERO
261 RCONDI = ZERO
262 *
263 ELSE IF( .NOT.NOFACT ) THEN
264 *
265 * Compute the condition number for comparison with
266 * the value returned by DGESVX (FACT = 'N' reuses
267 * the condition number from the previous iteration
268 * with FACT = 'F').
269 *
270 CALL DLACPY( 'Full', N, N, ASAV, LDA, AFAC, LDA )
271 IF( EQUIL .OR. IEQUED.GT.1 ) THEN
272 *
273 * Compute row and column scale factors to
274 * equilibrate the matrix A.
275 *
276 CALL DGEEQU( N, N, AFAC, LDA, S, S( N+1 ),
277 $ ROWCND, COLCND, AMAX, INFO )
278 IF( INFO.EQ.0 .AND. N.GT.0 ) THEN
279 IF( LSAME( EQUED, 'R' ) ) THEN
280 ROWCND = ZERO
281 COLCND = ONE
282 ELSE IF( LSAME( EQUED, 'C' ) ) THEN
283 ROWCND = ONE
284 COLCND = ZERO
285 ELSE IF( LSAME( EQUED, 'B' ) ) THEN
286 ROWCND = ZERO
287 COLCND = ZERO
288 END IF
289 *
290 * Equilibrate the matrix.
291 *
292 CALL DLAQGE( N, N, AFAC, LDA, S, S( N+1 ),
293 $ ROWCND, COLCND, AMAX, EQUED )
294 END IF
295 END IF
296 *
297 * Save the condition number of the non-equilibrated
298 * system for use in DGET04.
299 *
300 IF( EQUIL ) THEN
301 ROLDO = RCONDO
302 ROLDI = RCONDI
303 END IF
304 *
305 * Compute the 1-norm and infinity-norm of A.
306 *
307 ANORMO = DLANGE( '1', N, N, AFAC, LDA, RWORK )
308 ANORMI = DLANGE( 'I', N, N, AFAC, LDA, RWORK )
309 *
310 * Factor the matrix A.
311 *
312 CALL DGETRF( N, N, AFAC, LDA, IWORK, INFO )
313 *
314 * Form the inverse of A.
315 *
316 CALL DLACPY( 'Full', N, N, AFAC, LDA, A, LDA )
317 LWORK = NMAX*MAX( 3, NRHS )
318 CALL DGETRI( N, A, LDA, IWORK, WORK, LWORK, INFO )
319 *
320 * Compute the 1-norm condition number of A.
321 *
322 AINVNM = DLANGE( '1', N, N, A, LDA, RWORK )
323 IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
324 RCONDO = ONE
325 ELSE
326 RCONDO = ( ONE / ANORMO ) / AINVNM
327 END IF
328 *
329 * Compute the infinity-norm condition number of A.
330 *
331 AINVNM = DLANGE( 'I', N, N, A, LDA, RWORK )
332 IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
333 RCONDI = ONE
334 ELSE
335 RCONDI = ( ONE / ANORMI ) / AINVNM
336 END IF
337 END IF
338 *
339 DO 50 ITRAN = 1, NTRAN
340 *
341 * Do for each value of TRANS.
342 *
343 TRANS = TRANSS( ITRAN )
344 IF( ITRAN.EQ.1 ) THEN
345 RCONDC = RCONDO
346 ELSE
347 RCONDC = RCONDI
348 END IF
349 *
350 * Restore the matrix A.
351 *
352 CALL DLACPY( 'Full', N, N, ASAV, LDA, A, LDA )
353 *
354 * Form an exact solution and set the right hand side.
355 *
356 SRNAMT = 'DLARHS'
357 CALL DLARHS( PATH, XTYPE, 'Full', TRANS, N, N, KL,
358 $ KU, NRHS, A, LDA, XACT, LDA, B, LDA,
359 $ ISEED, INFO )
360 XTYPE = 'C'
361 CALL DLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA )
362 *
363 IF( NOFACT .AND. ITRAN.EQ.1 ) THEN
364 *
365 * --- Test DGESV ---
366 *
367 * Compute the LU factorization of the matrix and
368 * solve the system.
369 *
370 CALL DLACPY( 'Full', N, N, A, LDA, AFAC, LDA )
371 CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
372 *
373 SRNAMT = 'DGESV '
374 CALL DGESV( N, NRHS, AFAC, LDA, IWORK, X, LDA,
375 $ INFO )
376 *
377 * Check error code from DGESV .
378 *
379 IF( INFO.NE.IZERO )
380 $ CALL ALAERH( PATH, 'DGESV ', INFO, IZERO,
381 $ ' ', N, N, -1, -1, NRHS, IMAT,
382 $ NFAIL, NERRS, NOUT )
383 *
384 * Reconstruct matrix from factors and compute
385 * residual.
386 *
387 CALL DGET01( N, N, A, LDA, AFAC, LDA, IWORK,
388 $ RWORK, RESULT( 1 ) )
389 NT = 1
390 IF( IZERO.EQ.0 ) THEN
391 *
392 * Compute residual of the computed solution.
393 *
394 CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK,
395 $ LDA )
396 CALL DGET02( 'No transpose', N, N, NRHS, A,
397 $ LDA, X, LDA, WORK, LDA, RWORK,
398 $ RESULT( 2 ) )
399 *
400 * Check solution from generated exact solution.
401 *
402 CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
403 $ RCONDC, RESULT( 3 ) )
404 NT = 3
405 END IF
406 *
407 * Print information about the tests that did not
408 * pass the threshold.
409 *
410 DO 30 K = 1, NT
411 IF( RESULT( K ).GE.THRESH ) THEN
412 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
413 $ CALL ALADHD( NOUT, PATH )
414 WRITE( NOUT, FMT = 9999 )'DGESV ', N,
415 $ IMAT, K, RESULT( K )
416 NFAIL = NFAIL + 1
417 END IF
418 30 CONTINUE
419 NRUN = NRUN + NT
420 END IF
421 *
422 * --- Test DGESVX ---
423 *
424 IF( .NOT.PREFAC )
425 $ CALL DLASET( 'Full', N, N, ZERO, ZERO, AFAC,
426 $ LDA )
427 CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
428 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
429 *
430 * Equilibrate the matrix if FACT = 'F' and
431 * EQUED = 'R', 'C', or 'B'.
432 *
433 CALL DLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND,
434 $ COLCND, AMAX, EQUED )
435 END IF
436 *
437 * Solve the system and compute the condition number
438 * and error bounds using DGESVX.
439 *
440 SRNAMT = 'DGESVX'
441 CALL DGESVX( FACT, TRANS, N, NRHS, A, LDA, AFAC,
442 $ LDA, IWORK, EQUED, S, S( N+1 ), B,
443 $ LDA, X, LDA, RCOND, RWORK,
444 $ RWORK( NRHS+1 ), WORK, IWORK( N+1 ),
445 $ INFO )
446 *
447 * Check the error code from DGESVX.
448 *
449 IF( INFO.NE.IZERO )
450 $ CALL ALAERH( PATH, 'DGESVX', INFO, IZERO,
451 $ FACT // TRANS, N, N, -1, -1, NRHS,
452 $ IMAT, NFAIL, NERRS, NOUT )
453 *
454 * Compare WORK(1) from DGESVX with the computed
455 * reciprocal pivot growth factor RPVGRW
456 *
457 IF( INFO.NE.0 ) THEN
458 RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO,
459 $ AFAC, LDA, WORK )
460 IF( RPVGRW.EQ.ZERO ) THEN
461 RPVGRW = ONE
462 ELSE
463 RPVGRW = DLANGE( 'M', N, INFO, A, LDA,
464 $ WORK ) / RPVGRW
465 END IF
466 ELSE
467 RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AFAC, LDA,
468 $ WORK )
469 IF( RPVGRW.EQ.ZERO ) THEN
470 RPVGRW = ONE
471 ELSE
472 RPVGRW = DLANGE( 'M', N, N, A, LDA, WORK ) /
473 $ RPVGRW
474 END IF
475 END IF
476 RESULT( 7 ) = ABS( RPVGRW-WORK( 1 ) ) /
477 $ MAX( WORK( 1 ), RPVGRW ) /
478 $ DLAMCH( 'E' )
479 *
480 IF( .NOT.PREFAC ) THEN
481 *
482 * Reconstruct matrix from factors and compute
483 * residual.
484 *
485 CALL DGET01( N, N, A, LDA, AFAC, LDA, IWORK,
486 $ RWORK( 2*NRHS+1 ), RESULT( 1 ) )
487 K1 = 1
488 ELSE
489 K1 = 2
490 END IF
491 *
492 IF( INFO.EQ.0 ) THEN
493 TRFCON = .FALSE.
494 *
495 * Compute residual of the computed solution.
496 *
497 CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, WORK,
498 $ LDA )
499 CALL DGET02( TRANS, N, N, NRHS, ASAV, LDA, X,
500 $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ),
501 $ RESULT( 2 ) )
502 *
503 * Check solution from generated exact solution.
504 *
505 IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED,
506 $ 'N' ) ) ) THEN
507 CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
508 $ RCONDC, RESULT( 3 ) )
509 ELSE
510 IF( ITRAN.EQ.1 ) THEN
511 ROLDC = ROLDO
512 ELSE
513 ROLDC = ROLDI
514 END IF
515 CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
516 $ ROLDC, RESULT( 3 ) )
517 END IF
518 *
519 * Check the error bounds from iterative
520 * refinement.
521 *
522 CALL DGET07( TRANS, N, NRHS, ASAV, LDA, B, LDA,
523 $ X, LDA, XACT, LDA, RWORK, .TRUE.,
524 $ RWORK( NRHS+1 ), RESULT( 4 ) )
525 ELSE
526 TRFCON = .TRUE.
527 END IF
528 *
529 * Compare RCOND from DGESVX with the computed value
530 * in RCONDC.
531 *
532 RESULT( 6 ) = DGET06( RCOND, RCONDC )
533 *
534 * Print information about the tests that did not pass
535 * the threshold.
536 *
537 IF( .NOT.TRFCON ) THEN
538 DO 40 K = K1, NTESTS
539 IF( RESULT( K ).GE.THRESH ) THEN
540 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
541 $ CALL ALADHD( NOUT, PATH )
542 IF( PREFAC ) THEN
543 WRITE( NOUT, FMT = 9997 )'DGESVX',
544 $ FACT, TRANS, N, EQUED, IMAT, K,
545 $ RESULT( K )
546 ELSE
547 WRITE( NOUT, FMT = 9998 )'DGESVX',
548 $ FACT, TRANS, N, IMAT, K, RESULT( K )
549 END IF
550 NFAIL = NFAIL + 1
551 END IF
552 40 CONTINUE
553 NRUN = NRUN + 7 - K1
554 ELSE
555 IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC )
556 $ THEN
557 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
558 $ CALL ALADHD( NOUT, PATH )
559 IF( PREFAC ) THEN
560 WRITE( NOUT, FMT = 9997 )'DGESVX', FACT,
561 $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 )
562 ELSE
563 WRITE( NOUT, FMT = 9998 )'DGESVX', FACT,
564 $ TRANS, N, IMAT, 1, RESULT( 1 )
565 END IF
566 NFAIL = NFAIL + 1
567 NRUN = NRUN + 1
568 END IF
569 IF( RESULT( 6 ).GE.THRESH ) THEN
570 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
571 $ CALL ALADHD( NOUT, PATH )
572 IF( PREFAC ) THEN
573 WRITE( NOUT, FMT = 9997 )'DGESVX', FACT,
574 $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 )
575 ELSE
576 WRITE( NOUT, FMT = 9998 )'DGESVX', FACT,
577 $ TRANS, N, IMAT, 6, RESULT( 6 )
578 END IF
579 NFAIL = NFAIL + 1
580 NRUN = NRUN + 1
581 END IF
582 IF( RESULT( 7 ).GE.THRESH ) THEN
583 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
584 $ CALL ALADHD( NOUT, PATH )
585 IF( PREFAC ) THEN
586 WRITE( NOUT, FMT = 9997 )'DGESVX', FACT,
587 $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 )
588 ELSE
589 WRITE( NOUT, FMT = 9998 )'DGESVX', FACT,
590 $ TRANS, N, IMAT, 7, RESULT( 7 )
591 END IF
592 NFAIL = NFAIL + 1
593 NRUN = NRUN + 1
594 END IF
595 *
596 END IF
597 *
598 * --- Test DGESVXX ---
599 *
600 * Restore the matrices A and B.
601 *
602 CALL DLACPY( 'Full', N, N, ASAV, LDA, A, LDA )
603 CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, B, LDA )
604
605 IF( .NOT.PREFAC )
606 $ CALL DLASET( 'Full', N, N, ZERO, ZERO, AFAC,
607 $ LDA )
608 CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
609 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
610 *
611 * Equilibrate the matrix if FACT = 'F' and
612 * EQUED = 'R', 'C', or 'B'.
613 *
614 CALL DLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND,
615 $ COLCND, AMAX, EQUED )
616 END IF
617 *
618 * Solve the system and compute the condition number
619 * and error bounds using DGESVXX.
620 *
621 SRNAMT = 'DGESVXX'
622 N_ERR_BNDS = 3
623 CALL DGESVXX( FACT, TRANS, N, NRHS, A, LDA, AFAC,
624 $ LDA, IWORK, EQUED, S, S( N+1 ), B, LDA, X,
625 $ LDA, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS,
626 $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK,
627 $ IWORK( N+1 ), INFO )
628 *
629 * Check the error code from DGESVXX.
630 *
631 IF( INFO.EQ.N+1 ) GOTO 50
632 IF( INFO.NE.IZERO ) THEN
633 CALL ALAERH( PATH, 'DGESVXX', INFO, IZERO,
634 $ FACT // TRANS, N, N, -1, -1, NRHS,
635 $ IMAT, NFAIL, NERRS, NOUT )
636 GOTO 50
637 END IF
638 *
639 * Compare rpvgrw_svxx from DGESVXX with the computed
640 * reciprocal pivot growth factor RPVGRW
641 *
642
643 IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN
644 RPVGRW = DLA_RPVGRW(N, INFO, A, LDA, AFAC, LDA)
645 ELSE
646 RPVGRW = DLA_RPVGRW(N, N, A, LDA, AFAC, LDA)
647 ENDIF
648
649 RESULT( 7 ) = ABS( RPVGRW-RPVGRW_SVXX ) /
650 $ MAX( RPVGRW_SVXX, RPVGRW ) /
651 $ DLAMCH( 'E' )
652 *
653 IF( .NOT.PREFAC ) THEN
654 *
655 * Reconstruct matrix from factors and compute
656 * residual.
657 *
658 CALL DGET01( N, N, A, LDA, AFAC, LDA, IWORK,
659 $ RWORK( 2*NRHS+1 ), RESULT( 1 ) )
660 K1 = 1
661 ELSE
662 K1 = 2
663 END IF
664 *
665 IF( INFO.EQ.0 ) THEN
666 TRFCON = .FALSE.
667 *
668 * Compute residual of the computed solution.
669 *
670 CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, WORK,
671 $ LDA )
672 CALL DGET02( TRANS, N, N, NRHS, ASAV, LDA, X,
673 $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ),
674 $ RESULT( 2 ) )
675 *
676 * Check solution from generated exact solution.
677 *
678 IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED,
679 $ 'N' ) ) ) THEN
680 CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
681 $ RCONDC, RESULT( 3 ) )
682 ELSE
683 IF( ITRAN.EQ.1 ) THEN
684 ROLDC = ROLDO
685 ELSE
686 ROLDC = ROLDI
687 END IF
688 CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
689 $ ROLDC, RESULT( 3 ) )
690 END IF
691 ELSE
692 TRFCON = .TRUE.
693 END IF
694 *
695 * Compare RCOND from DGESVXX with the computed value
696 * in RCONDC.
697 *
698 RESULT( 6 ) = DGET06( RCOND, RCONDC )
699 *
700 * Print information about the tests that did not pass
701 * the threshold.
702 *
703 IF( .NOT.TRFCON ) THEN
704 DO 45 K = K1, NTESTS
705 IF( RESULT( K ).GE.THRESH ) THEN
706 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
707 $ CALL ALADHD( NOUT, PATH )
708 IF( PREFAC ) THEN
709 WRITE( NOUT, FMT = 9997 )'DGESVXX',
710 $ FACT, TRANS, N, EQUED, IMAT, K,
711 $ RESULT( K )
712 ELSE
713 WRITE( NOUT, FMT = 9998 )'DGESVXX',
714 $ FACT, TRANS, N, IMAT, K, RESULT( K )
715 END IF
716 NFAIL = NFAIL + 1
717 END IF
718 45 CONTINUE
719 NRUN = NRUN + 7 - K1
720 ELSE
721 IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC )
722 $ THEN
723 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
724 $ CALL ALADHD( NOUT, PATH )
725 IF( PREFAC ) THEN
726 WRITE( NOUT, FMT = 9997 )'DGESVXX', FACT,
727 $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 )
728 ELSE
729 WRITE( NOUT, FMT = 9998 )'DGESVXX', FACT,
730 $ TRANS, N, IMAT, 1, RESULT( 1 )
731 END IF
732 NFAIL = NFAIL + 1
733 NRUN = NRUN + 1
734 END IF
735 IF( RESULT( 6 ).GE.THRESH ) THEN
736 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
737 $ CALL ALADHD( NOUT, PATH )
738 IF( PREFAC ) THEN
739 WRITE( NOUT, FMT = 9997 )'DGESVXX', FACT,
740 $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 )
741 ELSE
742 WRITE( NOUT, FMT = 9998 )'DGESVXX', FACT,
743 $ TRANS, N, IMAT, 6, RESULT( 6 )
744 END IF
745 NFAIL = NFAIL + 1
746 NRUN = NRUN + 1
747 END IF
748 IF( RESULT( 7 ).GE.THRESH ) THEN
749 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
750 $ CALL ALADHD( NOUT, PATH )
751 IF( PREFAC ) THEN
752 WRITE( NOUT, FMT = 9997 )'DGESVXX', FACT,
753 $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 )
754 ELSE
755 WRITE( NOUT, FMT = 9998 )'DGESVXX', FACT,
756 $ TRANS, N, IMAT, 7, RESULT( 7 )
757 END IF
758 NFAIL = NFAIL + 1
759 NRUN = NRUN + 1
760 END IF
761 *
762 END IF
763 *
764 50 CONTINUE
765 60 CONTINUE
766 70 CONTINUE
767 80 CONTINUE
768 90 CONTINUE
769 *
770 * Print a summary of the results.
771 *
772 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
773 *
774
775 * Test Error Bounds from DGESVXX
776
777 CALL DEBCHVXX( THRESH, PATH )
778
779 9999 FORMAT( 1X, A, ', N =', I5, ', type ', I2, ', test(', I2, ') =',
780 $ G12.5 )
781 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,
782 $ ', type ', I2, ', test(', I1, ')=', G12.5 )
783 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,
784 $ ', EQUED=''', A1, ''', type ', I2, ', test(', I1, ')=',
785 $ G12.5 )
786 RETURN
787 *
788 * End of DDRVGE
789 *
790 END