OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
ddrvgbx.f
Go to the documentation of this file.
1*> \brief \b DDRVGBX
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 DDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA,
12* AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK,
13* RWORK, IWORK, NOUT )
14*
15* .. Scalar Arguments ..
16* LOGICAL TSTERR
17* INTEGER LA, LAFB, NN, NOUT, NRHS
18* DOUBLE PRECISION THRESH
19* ..
20* .. Array Arguments ..
21* LOGICAL DOTYPE( * )
22* INTEGER IWORK( * ), NVAL( * )
23* DOUBLE PRECISION A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
24* $ RWORK( * ), S( * ), WORK( * ), X( * ),
25* $ XACT( * )
26* ..
27*
28*
29*> \par Purpose:
30* =============
31*>
32*> \verbatim
33*>
34*> DDRVGB tests the driver routines DGBSV, -SVX, and -SVXX.
35*>
36*> Note that this file is used only when the XBLAS are available,
37*> otherwise ddrvgb.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[out] A
85*> \verbatim
86*> A is DOUBLE PRECISION array, dimension (LA)
87*> \endverbatim
88*>
89*> \param[in] LA
90*> \verbatim
91*> LA is INTEGER
92*> The length of the array A. LA >= (2*NMAX-1)*NMAX
93*> where NMAX is the largest entry in NVAL.
94*> \endverbatim
95*>
96*> \param[out] AFB
97*> \verbatim
98*> AFB is DOUBLE PRECISION array, dimension (LAFB)
99*> \endverbatim
100*>
101*> \param[in] LAFB
102*> \verbatim
103*> LAFB is INTEGER
104*> The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX
105*> where NMAX is the largest entry in NVAL.
106*> \endverbatim
107*>
108*> \param[out] ASAV
109*> \verbatim
110*> ASAV is DOUBLE PRECISION array, dimension (LA)
111*> \endverbatim
112*>
113*> \param[out] B
114*> \verbatim
115*> B is DOUBLE PRECISION array, dimension (NMAX*NRHS)
116*> \endverbatim
117*>
118*> \param[out] BSAV
119*> \verbatim
120*> BSAV is DOUBLE PRECISION array, dimension (NMAX*NRHS)
121*> \endverbatim
122*>
123*> \param[out] X
124*> \verbatim
125*> X is DOUBLE PRECISION array, dimension (NMAX*NRHS)
126*> \endverbatim
127*>
128*> \param[out] XACT
129*> \verbatim
130*> XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS)
131*> \endverbatim
132*>
133*> \param[out] S
134*> \verbatim
135*> S is DOUBLE PRECISION array, dimension (2*NMAX)
136*> \endverbatim
137*>
138*> \param[out] WORK
139*> \verbatim
140*> WORK is DOUBLE PRECISION array, dimension
141*> (NMAX*max(3,NRHS,NMAX))
142*> \endverbatim
143*>
144*> \param[out] RWORK
145*> \verbatim
146*> RWORK is DOUBLE PRECISION array, dimension
147*> (max(2*NMAX,NMAX+2*NRHS))
148*> \endverbatim
149*>
150*> \param[out] IWORK
151*> \verbatim
152*> IWORK is INTEGER array, dimension (2*NMAX)
153*> \endverbatim
154*>
155*> \param[in] NOUT
156*> \verbatim
157*> NOUT is INTEGER
158*> The unit number for output.
159*> \endverbatim
160*
161* Authors:
162* ========
163*
164*> \author Univ. of Tennessee
165*> \author Univ. of California Berkeley
166*> \author Univ. of Colorado Denver
167*> \author NAG Ltd.
168*
169*> \ingroup double_lin
170*
171* =====================================================================
172 SUBROUTINE ddrvgb( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA,
173 $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK,
174 $ RWORK, IWORK, NOUT )
175*
176* -- LAPACK test routine --
177* -- LAPACK is a software package provided by Univ. of Tennessee, --
178* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
179*
180* .. Scalar Arguments ..
181 LOGICAL TSTERR
182 INTEGER LA, LAFB, NN, NOUT, NRHS
183 DOUBLE PRECISION THRESH
184* ..
185* .. Array Arguments ..
186 LOGICAL DOTYPE( * )
187 INTEGER IWORK( * ), NVAL( * )
188 DOUBLE PRECISION A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
189 $ rwork( * ), s( * ), work( * ), x( * ),
190 $ xact( * )
191* ..
192*
193* =====================================================================
194*
195* .. Parameters ..
196 DOUBLE PRECISION ONE, ZERO
197 PARAMETER ( ONE = 1.0d+0, zero = 0.0d+0 )
198 INTEGER NTYPES
199 parameter( ntypes = 8 )
200 INTEGER NTESTS
201 parameter( ntests = 7 )
202 INTEGER NTRAN
203 parameter( ntran = 3 )
204* ..
205* .. Local Scalars ..
206 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
207 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
208 CHARACTER*3 PATH
209 INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN,
210 $ info, ioff, itran, izero, j, k, k1, kl, ku,
211 $ lda, ldafb, ldb, mode, n, nb, nbmin, nerrs,
212 $ nfact, nfail, nimat, nkl, nku, nrun, nt,
213 $ n_err_bnds
214 DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV,
215 $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO,
216 $ roldc, roldi, roldo, rowcnd, rpvgrw,
217 $ rpvgrw_svxx
218* ..
219* .. Local Arrays ..
220 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
221 INTEGER ISEED( 4 ), ISEEDY( 4 )
222 DOUBLE PRECISION RESULT( NTESTS ), BERR( NRHS ),
223 $ errbnds_n( nrhs, 3 ), errbnds_c( nrhs, 3 )
224* ..
225* .. External Functions ..
226 LOGICAL LSAME
227 DOUBLE PRECISION DGET06, DLAMCH, DLANGB, DLANGE, DLANTB,
228 $ dla_gbrpvgrw
229 EXTERNAL lsame, dget06, dlamch, dlangb, dlange, dlantb,
230 $ dla_gbrpvgrw
231* ..
232* .. External Subroutines ..
233 EXTERNAL aladhd, alaerh, alasvm, derrvx, dgbequ, dgbsv,
234 $ dgbsvx, dgbt01, dgbt02, dgbt05, dgbtrf, dgbtrs,
235 $ dget04, dlacpy, dlaqgb, dlarhs, dlaset, dlatb4,
236 $ dlatms, xlaenv, dgbsvxx, dgbequb
237* ..
238* .. Intrinsic Functions ..
239 INTRINSIC abs, max, min
240* ..
241* .. Scalars in Common ..
242 LOGICAL LERR, OK
243 CHARACTER*32 SRNAMT
244 INTEGER INFOT, NUNIT
245* ..
246* .. Common blocks ..
247 COMMON / infoc / infot, nunit, ok, lerr
248 COMMON / srnamc / srnamt
249* ..
250* .. Data statements ..
251 DATA iseedy / 1988, 1989, 1990, 1991 /
252 DATA transs / 'N', 'T', 'C' /
253 DATA facts / 'F', 'N', 'E' /
254 DATA equeds / 'N', 'R', 'C', 'B' /
255* ..
256* .. Executable Statements ..
257*
258* Initialize constants and the random number seed.
259*
260 path( 1: 1 ) = 'Double precision'
261 path( 2: 3 ) = 'GB'
262 nrun = 0
263 nfail = 0
264 nerrs = 0
265 DO 10 i = 1, 4
266 iseed( i ) = iseedy( i )
267 10 CONTINUE
268*
269* Test the error exits
270*
271 IF( tsterr )
272 $ CALL derrvx( path, nout )
273 infot = 0
274*
275* Set the block size and minimum block size for testing.
276*
277 nb = 1
278 nbmin = 2
279 CALL xlaenv( 1, nb )
280 CALL xlaenv( 2, nbmin )
281*
282* Do for each value of N in NVAL
283*
284 DO 150 in = 1, nn
285 n = nval( in )
286 ldb = max( n, 1 )
287 xtype = 'N'
288*
289* Set limits on the number of loop iterations.
290*
291 nkl = max( 1, min( n, 4 ) )
292 IF( n.EQ.0 )
293 $ nkl = 1
294 nku = nkl
295 nimat = ntypes
296 IF( n.LE.0 )
297 $ nimat = 1
298*
299 DO 140 ikl = 1, nkl
300*
301* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes
302* it easier to skip redundant values for small values of N.
303*
304 IF( ikl.EQ.1 ) THEN
305 kl = 0
306 ELSE IF( ikl.EQ.2 ) THEN
307 kl = max( n-1, 0 )
308 ELSE IF( ikl.EQ.3 ) THEN
309 kl = ( 3*n-1 ) / 4
310 ELSE IF( ikl.EQ.4 ) THEN
311 kl = ( n+1 ) / 4
312 END IF
313 DO 130 iku = 1, nku
314*
315* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order
316* makes it easier to skip redundant values for small
317* values of N.
318*
319 IF( iku.EQ.1 ) THEN
320 ku = 0
321 ELSE IF( iku.EQ.2 ) THEN
322 ku = max( n-1, 0 )
323 ELSE IF( iku.EQ.3 ) THEN
324 ku = ( 3*n-1 ) / 4
325 ELSE IF( iku.EQ.4 ) THEN
326 ku = ( n+1 ) / 4
327 END IF
328*
329* Check that A and AFB are big enough to generate this
330* matrix.
331*
332 lda = kl + ku + 1
333 ldafb = 2*kl + ku + 1
334 IF( lda*n.GT.la .OR. ldafb*n.GT.lafb ) THEN
335 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
336 $ CALL aladhd( nout, path )
337 IF( lda*n.GT.la ) THEN
338 WRITE( nout, fmt = 9999 )la, n, kl, ku,
339 $ n*( kl+ku+1 )
340 nerrs = nerrs + 1
341 END IF
342 IF( ldafb*n.GT.lafb ) THEN
343 WRITE( nout, fmt = 9998 )lafb, n, kl, ku,
344 $ n*( 2*kl+ku+1 )
345 nerrs = nerrs + 1
346 END IF
347 GO TO 130
348 END IF
349*
350 DO 120 imat = 1, nimat
351*
352* Do the tests only if DOTYPE( IMAT ) is true.
353*
354 IF( .NOT.dotype( imat ) )
355 $ GO TO 120
356*
357* Skip types 2, 3, or 4 if the matrix is too small.
358*
359 zerot = imat.GE.2 .AND. imat.LE.4
360 IF( zerot .AND. n.LT.imat-1 )
361 $ GO TO 120
362*
363* Set up parameters with DLATB4 and generate a
364* test matrix with DLATMS.
365*
366 CALL dlatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
367 $ MODE, CNDNUM, DIST )
368 rcondc = one / cndnum
369*
370 srnamt = 'DLATMS'
371 CALL dlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
372 $ cndnum, anorm, kl, ku, 'Z', a, lda, work,
373 $ info )
374*
375* Check the error code from DLATMS.
376*
377 IF( info.NE.0 ) THEN
378 CALL alaerh( path, 'DLATMS', info, 0, ' ', n, n,
379 $ kl, ku, -1, imat, nfail, nerrs, nout )
380 GO TO 120
381 END IF
382*
383* For types 2, 3, and 4, zero one or more columns of
384* the matrix to test that INFO is returned correctly.
385*
386 izero = 0
387 IF( zerot ) THEN
388 IF( imat.EQ.2 ) THEN
389 izero = 1
390 ELSE IF( imat.EQ.3 ) THEN
391 izero = n
392 ELSE
393 izero = n / 2 + 1
394 END IF
395 ioff = ( izero-1 )*lda
396 IF( imat.LT.4 ) THEN
397 i1 = max( 1, ku+2-izero )
398 i2 = min( kl+ku+1, ku+1+( n-izero ) )
399 DO 20 i = i1, i2
400 a( ioff+i ) = zero
401 20 CONTINUE
402 ELSE
403 DO 40 j = izero, n
404 DO 30 i = max( 1, ku+2-j ),
405 $ min( kl+ku+1, ku+1+( n-j ) )
406 a( ioff+i ) = zero
407 30 CONTINUE
408 ioff = ioff + lda
409 40 CONTINUE
410 END IF
411 END IF
412*
413* Save a copy of the matrix A in ASAV.
414*
415 CALL dlacpy( 'Full', kl+ku+1, n, a, lda, asav, lda )
416*
417 DO 110 iequed = 1, 4
418 equed = equeds( iequed )
419 IF( iequed.EQ.1 ) THEN
420 nfact = 3
421 ELSE
422 nfact = 1
423 END IF
424*
425 DO 100 ifact = 1, nfact
426 fact = facts( ifact )
427 prefac = lsame( fact, 'F' )
428 nofact = lsame( fact, 'N' )
429 equil = lsame( fact, 'E' )
430*
431 IF( zerot ) THEN
432 IF( prefac )
433 $ GO TO 100
434 rcondo = zero
435 rcondi = zero
436*
437 ELSE IF( .NOT.nofact ) THEN
438*
439* Compute the condition number for comparison
440* with the value returned by DGESVX (FACT =
441* 'N' reuses the condition number from the
442* previous iteration with FACT = 'F').
443*
444 CALL dlacpy( 'Full', kl+ku+1, n, asav, lda,
445 $ afb( kl+1 ), ldafb )
446 IF( equil .OR. iequed.GT.1 ) THEN
447*
448* Compute row and column scale factors to
449* equilibrate the matrix A.
450*
451 CALL dgbequ( n, n, kl, ku, afb( kl+1 ),
452 $ ldafb, s, s( n+1 ), rowcnd,
453 $ colcnd, amax, info )
454 IF( info.EQ.0 .AND. n.GT.0 ) THEN
455 IF( lsame( equed, 'R' ) ) THEN
456 rowcnd = zero
457 colcnd = one
458 ELSE IF( lsame( equed, 'C' ) ) THEN
459 rowcnd = one
460 colcnd = zero
461 ELSE IF( lsame( equed, 'B' ) ) THEN
462 rowcnd = zero
463 colcnd = zero
464 END IF
465*
466* Equilibrate the matrix.
467*
468 CALL dlaqgb( n, n, kl, ku, afb( kl+1 ),
469 $ ldafb, s, s( n+1 ),
470 $ rowcnd, colcnd, amax,
471 $ equed )
472 END IF
473 END IF
474*
475* Save the condition number of the
476* non-equilibrated system for use in DGET04.
477*
478 IF( equil ) THEN
479 roldo = rcondo
480 roldi = rcondi
481 END IF
482*
483* Compute the 1-norm and infinity-norm of A.
484*
485 anormo = dlangb( '1', n, kl, ku, afb( kl+1 ),
486 $ ldafb, rwork )
487 anormi = dlangb( 'I', n, kl, ku, afb( kl+1 ),
488 $ ldafb, rwork )
489*
490* Factor the matrix A.
491*
492 CALL dgbtrf( n, n, kl, ku, afb, ldafb, iwork,
493 $ info )
494*
495* Form the inverse of A.
496*
497 CALL dlaset( 'Full', n, n, zero, one, work,
498 $ ldb )
499 srnamt = 'DGBTRS'
500 CALL dgbtrs( 'No transpose', n, kl, ku, n,
501 $ afb, ldafb, iwork, work, ldb,
502 $ info )
503*
504* Compute the 1-norm condition number of A.
505*
506 ainvnm = dlange( '1', n, n, work, ldb,
507 $ rwork )
508 IF( anormo.LE.zero .OR. ainvnm.LE.zero ) THEN
509 rcondo = one
510 ELSE
511 rcondo = ( one / anormo ) / ainvnm
512 END IF
513*
514* Compute the infinity-norm condition number
515* of A.
516*
517 ainvnm = dlange( 'I', n, n, work, ldb,
518 $ rwork )
519 IF( anormi.LE.zero .OR. ainvnm.LE.zero ) THEN
520 rcondi = one
521 ELSE
522 rcondi = ( one / anormi ) / ainvnm
523 END IF
524 END IF
525*
526 DO 90 itran = 1, ntran
527*
528* Do for each value of TRANS.
529*
530 trans = transs( itran )
531 IF( itran.EQ.1 ) THEN
532 rcondc = rcondo
533 ELSE
534 rcondc = rcondi
535 END IF
536*
537* Restore the matrix A.
538*
539 CALL dlacpy( 'Full', kl+ku+1, n, asav, lda,
540 $ a, lda )
541*
542* Form an exact solution and set the right hand
543* side.
544*
545 srnamt = 'DLARHS'
546 CALL dlarhs( path, xtype, 'Full', trans, n,
547 $ n, kl, ku, nrhs, a, lda, xact,
548 $ ldb, b, ldb, iseed, info )
549 xtype = 'C'
550 CALL dlacpy( 'Full', n, nrhs, b, ldb, bsav,
551 $ ldb )
552*
553 IF( nofact .AND. itran.EQ.1 ) THEN
554*
555* --- Test DGBSV ---
556*
557* Compute the LU factorization of the matrix
558* and solve the system.
559*
560 CALL dlacpy( 'Full', kl+ku+1, n, a, lda,
561 $ afb( kl+1 ), ldafb )
562 CALL dlacpy( 'Full', n, nrhs, b, ldb, x,
563 $ ldb )
564*
565 srnamt = 'DGBSV '
566 CALL dgbsv( n, kl, ku, nrhs, afb, ldafb,
567 $ iwork, x, ldb, info )
568*
569* Check error code from DGBSV .
570*
571 IF( info.NE.izero )
572 $ CALL alaerh( path, 'DGBSV ', info,
573 $ izero, ' ', n, n, kl, ku,
574 $ nrhs, imat, nfail, nerrs,
575 $ nout )
576*
577* Reconstruct matrix from factors and
578* compute residual.
579*
580 CALL dgbt01( n, n, kl, ku, a, lda, afb,
581 $ ldafb, iwork, work,
582 $ result( 1 ) )
583 nt = 1
584 IF( izero.EQ.0 ) THEN
585*
586* Compute residual of the computed
587* solution.
588*
589 CALL dlacpy( 'Full', n, nrhs, b, ldb,
590 $ work, ldb )
591 CALL dgbt02( 'No transpose', n, n, kl,
592 $ ku, nrhs, a, lda, x, ldb,
593 $ work, ldb, rwork,
594 $ result( 2 ) )
595*
596* Check solution from generated exact
597* solution.
598*
599 CALL dget04( n, nrhs, x, ldb, xact,
600 $ ldb, rcondc, result( 3 ) )
601 nt = 3
602 END IF
603*
604* Print information about the tests that did
605* not pass the threshold.
606*
607 DO 50 k = 1, nt
608 IF( result( k ).GE.thresh ) THEN
609 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
610 $ CALL aladhd( nout, path )
611 WRITE( nout, fmt = 9997 )'DGBSV ',
612 $ n, kl, ku, imat, k, result( k )
613 nfail = nfail + 1
614 END IF
615 50 CONTINUE
616 nrun = nrun + nt
617 END IF
618*
619* --- Test DGBSVX ---
620*
621 IF( .NOT.prefac )
622 $ CALL dlaset( 'Full', 2*kl+ku+1, n, zero,
623 $ zero, afb, ldafb )
624 CALL dlaset( 'Full', n, nrhs, zero, zero, x,
625 $ ldb )
626 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
627*
628* Equilibrate the matrix if FACT = 'F' and
629* EQUED = 'R', 'C', or 'B'.
630*
631 CALL dlaqgb( n, n, kl, ku, a, lda, s,
632 $ s( n+1 ), rowcnd, colcnd,
633 $ amax, equed )
634 END IF
635*
636* Solve the system and compute the condition
637* number and error bounds using DGBSVX.
638*
639 srnamt = 'DGBSVX'
640 CALL dgbsvx( fact, trans, n, kl, ku, nrhs, a,
641 $ lda, afb, ldafb, iwork, equed,
642 $ s, s( n+1 ), b, ldb, x, ldb,
643 $ rcond, rwork, rwork( nrhs+1 ),
644 $ work, iwork( n+1 ), info )
645*
646* Check the error code from DGBSVX.
647*
648 IF( info.NE.izero )
649 $ CALL alaerh( path, 'DGBSVX', info, izero,
650 $ fact // trans, n, n, kl, ku,
651 $ nrhs, imat, nfail, nerrs,
652 $ nout )
653*
654* Compare WORK(1) from DGBSVX with the computed
655* reciprocal pivot growth factor RPVGRW
656*
657 IF( info.NE.0 ) THEN
658 anrmpv = zero
659 DO 70 j = 1, info
660 DO 60 i = max( ku+2-j, 1 ),
661 $ min( n+ku+1-j, kl+ku+1 )
662 anrmpv = max( anrmpv,
663 $ abs( a( i+( j-1 )*lda ) ) )
664 60 CONTINUE
665 70 CONTINUE
666 rpvgrw = dlantb( 'M', 'U', 'N', info,
667 $ min( info-1, kl+ku ),
668 $ afb( max( 1, kl+ku+2-info ) ),
669 $ ldafb, work )
670 IF( rpvgrw.EQ.zero ) THEN
671 rpvgrw = one
672 ELSE
673 rpvgrw = anrmpv / rpvgrw
674 END IF
675 ELSE
676 rpvgrw = dlantb( 'M', 'U', 'N', n, kl+ku,
677 $ afb, ldafb, work )
678 IF( rpvgrw.EQ.zero ) THEN
679 rpvgrw = one
680 ELSE
681 rpvgrw = dlangb( 'M', n, kl, ku, a,
682 $ lda, work ) / rpvgrw
683 END IF
684 END IF
685 result( 7 ) = abs( rpvgrw-work( 1 ) ) /
686 $ max( work( 1 ), rpvgrw ) /
687 $ dlamch( 'E' )
688*
689 IF( .NOT.prefac ) THEN
690*
691* Reconstruct matrix from factors and
692* compute residual.
693*
694 CALL dgbt01( n, n, kl, ku, a, lda, afb,
695 $ ldafb, iwork, work,
696 $ result( 1 ) )
697 k1 = 1
698 ELSE
699 k1 = 2
700 END IF
701*
702 IF( info.EQ.0 ) THEN
703 trfcon = .false.
704*
705* Compute residual of the computed solution.
706*
707 CALL dlacpy( 'Full', n, nrhs, bsav, ldb,
708 $ work, ldb )
709 CALL dgbt02( trans, n, n, kl, ku, nrhs,
710 $ asav, lda, x, ldb, work, ldb,
711 $ rwork( 2*nrhs+1 ),
712 $ result( 2 ) )
713*
714* Check solution from generated exact
715* solution.
716*
717 IF( nofact .OR. ( prefac .AND.
718 $ lsame( equed, 'n' ) ) ) THEN
719 CALL DGET04( N, NRHS, X, LDB, XACT,
720 $ LDB, RCONDC, RESULT( 3 ) )
721 ELSE
722.EQ. IF( ITRAN1 ) THEN
723 ROLDC = ROLDO
724 ELSE
725 ROLDC = ROLDI
726 END IF
727 CALL DGET04( N, NRHS, X, LDB, XACT,
728 $ LDB, ROLDC, RESULT( 3 ) )
729 END IF
730*
731* Check the error bounds from iterative
732* refinement.
733*
734 CALL DGBT05( TRANS, N, KL, KU, NRHS, ASAV,
735 $ LDA, B, LDB, X, LDB, XACT,
736 $ LDB, RWORK, RWORK( NRHS+1 ),
737 $ RESULT( 4 ) )
738 ELSE
739 TRFCON = .TRUE.
740 END IF
741*
742* Compare RCOND from DGBSVX with the computed
743* value in RCONDC.
744*
745 RESULT( 6 ) = DGET06( RCOND, RCONDC )
746*
747* Print information about the tests that did
748* not pass the threshold.
749*
750.NOT. IF( TRFCON ) THEN
751 DO 80 K = K1, NTESTS
752.GE. IF( RESULT( K )THRESH ) THEN
753.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
754 $ CALL ALADHD( NOUT, PATH )
755 IF( PREFAC ) THEN
756 WRITE( NOUT, FMT = 9995 )
757 $ 'dgbsvx', FACT, TRANS, N, KL,
758 $ KU, EQUED, IMAT, K,
759 $ RESULT( K )
760 ELSE
761 WRITE( NOUT, FMT = 9996 )
762 $ 'dgbsvx', FACT, TRANS, N, KL,
763 $ KU, IMAT, K, RESULT( K )
764 END IF
765 NFAIL = NFAIL + 1
766 END IF
767 80 CONTINUE
768 NRUN = NRUN + 7 - K1
769 ELSE
770.GE..AND..NOT. IF( RESULT( 1 )THRESH
771 $ PREFAC ) THEN
772.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
773 $ CALL ALADHD( NOUT, PATH )
774 IF( PREFAC ) THEN
775 WRITE( NOUT, FMT = 9995 )'dgbsvx',
776 $ FACT, TRANS, N, KL, KU, EQUED,
777 $ IMAT, 1, RESULT( 1 )
778 ELSE
779 WRITE( NOUT, FMT = 9996 )'dgbsvx',
780 $ FACT, TRANS, N, KL, KU, IMAT, 1,
781 $ RESULT( 1 )
782 END IF
783 NFAIL = NFAIL + 1
784 NRUN = NRUN + 1
785 END IF
786.GE. IF( RESULT( 6 )THRESH ) THEN
787.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
788 $ CALL ALADHD( NOUT, PATH )
789 IF( PREFAC ) THEN
790 WRITE( NOUT, FMT = 9995 )'dgbsvx',
791 $ FACT, TRANS, N, KL, KU, EQUED,
792 $ IMAT, 6, RESULT( 6 )
793 ELSE
794 WRITE( NOUT, FMT = 9996 )'dgbsvx',
795 $ FACT, TRANS, N, KL, KU, IMAT, 6,
796 $ RESULT( 6 )
797 END IF
798 NFAIL = NFAIL + 1
799 NRUN = NRUN + 1
800 END IF
801.GE. IF( RESULT( 7 )THRESH ) THEN
802.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
803 $ CALL ALADHD( NOUT, PATH )
804 IF( PREFAC ) THEN
805 WRITE( NOUT, FMT = 9995 )'dgbsvx',
806 $ FACT, TRANS, N, KL, KU, EQUED,
807 $ IMAT, 7, RESULT( 7 )
808 ELSE
809 WRITE( NOUT, FMT = 9996 )'dgbsvx',
810 $ FACT, TRANS, N, KL, KU, IMAT, 7,
811 $ RESULT( 7 )
812 END IF
813 NFAIL = NFAIL + 1
814 NRUN = NRUN + 1
815 END IF
816*
817 END IF
818*
819* --- Test DGBSVXX ---
820*
821* Restore the matrices A and B.
822*
823 CALL DLACPY( 'full', KL+KU+1, N, ASAV, LDA, A,
824 $ LDA )
825 CALL DLACPY( 'full', N, NRHS, BSAV, LDB, B, LDB )
826
827.NOT. IF( PREFAC )
828 $ CALL DLASET( 'full', 2*KL+KU+1, N, ZERO, ZERO,
829 $ AFB, LDAFB )
830 CALL DLASET( 'full', N, NRHS, ZERO, ZERO, X, LDB )
831.GT..AND..GT. IF( IEQUED1 N0 ) THEN
832*
833* Equilibrate the matrix if FACT = 'F' and
834* EQUED = 'R', 'C', or 'B'.
835*
836 CALL DLAQGB( N, N, KL, KU, A, LDA, S, S( N+1 ),
837 $ ROWCND, COLCND, AMAX, EQUED )
838 END IF
839*
840* Solve the system and compute the condition number
841* and error bounds using DGBSVXX.
842*
843 SRNAMT = 'dgbsvxx'
844 N_ERR_BNDS = 3
845 CALL DGBSVXX( FACT, TRANS, N, KL, KU, NRHS, A, LDA,
846 $ AFB, LDAFB, IWORK, EQUED, S, S( N+1 ), B, LDB,
847 $ X, LDB, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS,
848 $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK,
849 $ IWORK( N+1 ), INFO )
850*
851* Check the error code from DGBSVXX.
852*
853.EQ. IF( INFON+1 ) GOTO 90
854.NE. IF( INFOIZERO ) THEN
855 CALL ALAERH( PATH, 'dgbsvxx', INFO, IZERO,
856 $ FACT // TRANS, N, N, -1, -1, NRHS,
857 $ IMAT, NFAIL, NERRS, NOUT )
858 GOTO 90
859 END IF
860*
861* Compare rpvgrw_svxx from DGBSVXX with the computed
862* reciprocal pivot growth factor RPVGRW
863*
864
865.GT..AND..LT. IF ( INFO 0 INFO N+1 ) THEN
866 RPVGRW = DLA_GBRPVGRW(N, KL, KU, INFO, A, LDA,
867 $ AFB, LDAFB)
868 ELSE
869 RPVGRW = DLA_GBRPVGRW(N, KL, KU, N, A, LDA,
870 $ AFB, LDAFB)
871 ENDIF
872
873 RESULT( 7 ) = ABS( RPVGRW-rpvgrw_svxx ) /
874 $ MAX( rpvgrw_svxx, RPVGRW ) /
875 $ DLAMCH( 'e' )
876*
877.NOT. IF( PREFAC ) THEN
878*
879* Reconstruct matrix from factors and compute
880* residual.
881*
882 CALL DGBT01( N, N, KL, KU, A, LDA, AFB, LDAFB,
883 $ IWORK, WORK, RESULT( 1 ) )
884 K1 = 1
885 ELSE
886 K1 = 2
887 END IF
888*
889.EQ. IF( INFO0 ) THEN
890 TRFCON = .FALSE.
891*
892* Compute residual of the computed solution.
893*
894 CALL DLACPY( 'full', N, NRHS, BSAV, LDB, WORK,
895 $ LDB )
896 CALL DGBT02( TRANS, N, N, KL, KU, NRHS, ASAV,
897 $ LDA, X, LDB, WORK, LDB, RWORK,
898 $ RESULT( 2 ) )
899*
900* Check solution from generated exact solution.
901*
902.OR..AND. IF( NOFACT ( PREFAC LSAME( EQUED,
903 $ 'n' ) ) ) THEN
904 CALL DGET04( N, NRHS, X, LDB, XACT, LDB,
905 $ RCONDC, RESULT( 3 ) )
906 ELSE
907.EQ. IF( ITRAN1 ) THEN
908 ROLDC = ROLDO
909 ELSE
910 ROLDC = ROLDI
911 END IF
912 CALL DGET04( N, NRHS, X, LDB, XACT, LDB,
913 $ ROLDC, RESULT( 3 ) )
914 END IF
915 ELSE
916 TRFCON = .TRUE.
917 END IF
918*
919* Compare RCOND from DGBSVXX with the computed value
920* in RCONDC.
921*
922 RESULT( 6 ) = DGET06( RCOND, RCONDC )
923*
924* Print information about the tests that did not pass
925* the threshold.
926*
927.NOT. IF( TRFCON ) THEN
928 DO 45 K = K1, NTESTS
929.GE. IF( RESULT( K )THRESH ) THEN
930.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
931 $ CALL ALADHD( NOUT, PATH )
932 IF( PREFAC ) THEN
933 WRITE( NOUT, FMT = 9995 )'dgbsvxx',
934 $ FACT, TRANS, N, KL, KU, EQUED,
935 $ IMAT, K, RESULT( K )
936 ELSE
937 WRITE( NOUT, FMT = 9996 )'dgbsvxx',
938 $ FACT, TRANS, N, KL, KU, IMAT, K,
939 $ RESULT( K )
940 END IF
941 NFAIL = NFAIL + 1
942 END IF
943 45 CONTINUE
944 NRUN = NRUN + 7 - K1
945 ELSE
946.GE..AND..NOT. IF( RESULT( 1 )THRESH PREFAC )
947 $ THEN
948.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
949 $ CALL ALADHD( NOUT, PATH )
950 IF( PREFAC ) THEN
951 WRITE( NOUT, FMT = 9995 )'dgbsvxx', FACT,
952 $ TRANS, N, KL, KU, EQUED, IMAT, 1,
953 $ RESULT( 1 )
954 ELSE
955 WRITE( NOUT, FMT = 9996 )'dgbsvxx', FACT,
956 $ TRANS, N, KL, KU, IMAT, 1,
957 $ RESULT( 1 )
958 END IF
959 NFAIL = NFAIL + 1
960 NRUN = NRUN + 1
961 END IF
962.GE. IF( RESULT( 6 )THRESH ) THEN
963.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
964 $ CALL ALADHD( NOUT, PATH )
965 IF( PREFAC ) THEN
966 WRITE( NOUT, FMT = 9995 )'dgbsvxx', FACT,
967 $ TRANS, N, KL, KU, EQUED, IMAT, 6,
968 $ RESULT( 6 )
969 ELSE
970 WRITE( NOUT, FMT = 9996 )'dgbsvxx', FACT,
971 $ TRANS, N, KL, KU, IMAT, 6,
972 $ RESULT( 6 )
973 END IF
974 NFAIL = NFAIL + 1
975 NRUN = NRUN + 1
976 END IF
977.GE. IF( RESULT( 7 )THRESH ) THEN
978.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
979 $ CALL ALADHD( NOUT, PATH )
980 IF( PREFAC ) THEN
981 WRITE( NOUT, FMT = 9995 )'dgbsvxx', FACT,
982 $ TRANS, N, KL, KU, EQUED, IMAT, 7,
983 $ RESULT( 7 )
984 ELSE
985 WRITE( NOUT, FMT = 9996 )'dgbsvxx', FACT,
986 $ TRANS, N, KL, KU, IMAT, 7,
987 $ RESULT( 7 )
988 END IF
989 NFAIL = NFAIL + 1
990 NRUN = NRUN + 1
991 END IF
992*
993 END IF
994 90 CONTINUE
995 100 CONTINUE
996 110 CONTINUE
997 120 CONTINUE
998 130 CONTINUE
999 140 CONTINUE
1000 150 CONTINUE
1001*
1002* Print a summary of the results.
1003*
1004 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
1005
1006* Test Error Bounds from DGBSVXX
1007
1008 CALL DEBCHVXX(THRESH, PATH)
1009
1010 9999 FORMAT( ' *** in ddrvgb, la=', I5, ' is too small for n=', I5,
1011 $ ', ku=', I5, ', kl=', I5, / ' ==> increase la to at least ',
1012 $ I5 )
1013 9998 FORMAT( ' *** in ddrvgb, lafb=', I5, ' is too small for n=', I5,
1014 $ ', ku=', I5, ', kl=', I5, /
1015 $ ' ==> increase lafb to at least ', I5 )
1016 9997 FORMAT( 1X, A, ', n=', I5, ', kl=', I5, ', ku=', I5, ', type ',
1017 $ I1, ', test(', I1, ')=', G12.5 )
1018 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',
1019 $ I5, ',...), type ', I1, ', test(', I1, ')=', G12.5 )
1020 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',
1021 $ I5, ',...), equed=''', A1, ''', type ', I1, ', test(', I1,
1022 $ ')=', G12.5 )
1023*
1024 RETURN
1025*
1026* End of DDRVGBX
1027*
1028 END
dlacpy
subroutine dlacpy(uplo, m, n, a, lda, b, ldb)
DLACPY copies all or part of one two-dimensional array to another.
Definition dlacpy.f:103
dlaset
subroutine dlaset(uplo, m, n, alpha, beta, a, lda)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition dlaset.f:110
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
alasvm
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
Definition alasvm.f:73
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
dlaqgb
subroutine dlaqgb(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, equed)
DLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ.
Definition dlaqgb.f:159
dgbtrs
subroutine dgbtrs(trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
DGBTRS
Definition dgbtrs.f:138
dgbequb
subroutine dgbequb(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, info)
DGBEQUB
Definition dgbequb.f:160
dgbequ
subroutine dgbequ(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, info)
DGBEQU
Definition dgbequ.f:153
dgbtrf
subroutine dgbtrf(m, n, kl, ku, ab, ldab, ipiv, info)
DGBTRF
Definition dgbtrf.f:144
dla_gbrpvgrw
double precision function dla_gbrpvgrw(n, kl, ku, ncols, ab, ldab, afb, ldafb)
DLA_GBRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a general banded matrix.
Definition dla_gbrpvgrw.f:117
dgbsvx
subroutine dgbsvx(fact, trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
DGBSVX computes the solution to system of linear equations A * X = B for GB matrices
Definition dgbsvx.f:369
dgbsvxx
subroutine dgbsvxx(fact, trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, equed, r, c, b, ldb, x, ldx, rcond, rpvgrw, berr, n_err_bnds, err_bnds_norm, err_bnds_comp, nparams, params, work, iwork, info)
DGBSVXX computes the solution to system of linear equations A * X = B for GB matrices
Definition dgbsvxx.f:560
dgbsv
subroutine dgbsv(n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
DGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver)
Definition dgbsv.f:162
dlarhs
subroutine dlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
DLARHS
Definition dlarhs.f:205
ddrvgb
subroutine ddrvgb(dotype, nn, nval, nrhs, thresh, tsterr, a, la, afb, lafb, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
DDRVGB
Definition ddrvgb.f:172
derrvx
subroutine derrvx(path, nunit)
DERRVX
Definition derrvx.f:55
dgbt02
subroutine dgbt02(trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
DGBT02
Definition dgbt02.f:149
dgbt05
subroutine dgbt05(trans, n, kl, ku, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
DGBT05
Definition dgbt05.f:176
dlatb4
subroutine dlatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
DLATB4
Definition dlatb4.f:120
dgbt01
subroutine dgbt01(m, n, kl, ku, a, lda, afac, ldafac, ipiv, work, resid)
DGBT01
Definition dgbt01.f:126
dget04
subroutine dget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
DGET04
Definition dget04.f:102
dlatms
subroutine dlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
DLATMS
Definition dlatms.f:321
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91