OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sdrvgb.f
Go to the documentation of this file.
1*> \brief \b SDRVGB
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 SDRVGB( 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* REAL THRESH
19* ..
20* .. Array Arguments ..
21* LOGICAL DOTYPE( * )
22* INTEGER IWORK( * ), NVAL( * )
23* REAL A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
24* $ RWORK( * ), S( * ), WORK( * ), X( * ),
25* $ XACT( * )
26* ..
27*
28*
29*> \par Purpose:
30* =============
31*>
32*> \verbatim
33*>
34*> SDRVGB tests the driver routines SGBSV and -SVX.
35*> \endverbatim
36*
37* Arguments:
38* ==========
39*
40*> \param[in] DOTYPE
41*> \verbatim
42*> DOTYPE is LOGICAL array, dimension (NTYPES)
43*> The matrix types to be used for testing. Matrices of type j
44*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
45*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
46*> \endverbatim
47*>
48*> \param[in] NN
49*> \verbatim
50*> NN is INTEGER
51*> The number of values of N contained in the vector NVAL.
52*> \endverbatim
53*>
54*> \param[in] NVAL
55*> \verbatim
56*> NVAL is INTEGER array, dimension (NN)
57*> The values of the matrix column dimension N.
58*> \endverbatim
59*>
60*> \param[in] NRHS
61*> \verbatim
62*> NRHS is INTEGER
63*> The number of right hand side vectors to be generated for
64*> each linear system.
65*> \endverbatim
66*>
67*> \param[in] THRESH
68*> \verbatim
69*> THRESH is REAL
70*> The threshold value for the test ratios. A result is
71*> included in the output file if RESULT >= THRESH. To have
72*> every test ratio printed, use THRESH = 0.
73*> \endverbatim
74*>
75*> \param[in] TSTERR
76*> \verbatim
77*> TSTERR is LOGICAL
78*> Flag that indicates whether error exits are to be tested.
79*> \endverbatim
80*>
81*> \param[out] A
82*> \verbatim
83*> A is REAL array, dimension (LA)
84*> \endverbatim
85*>
86*> \param[in] LA
87*> \verbatim
88*> LA is INTEGER
89*> The length of the array A. LA >= (2*NMAX-1)*NMAX
90*> where NMAX is the largest entry in NVAL.
91*> \endverbatim
92*>
93*> \param[out] AFB
94*> \verbatim
95*> AFB is REAL array, dimension (LAFB)
96*> \endverbatim
97*>
98*> \param[in] LAFB
99*> \verbatim
100*> LAFB is INTEGER
101*> The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX
102*> where NMAX is the largest entry in NVAL.
103*> \endverbatim
104*>
105*> \param[out] ASAV
106*> \verbatim
107*> ASAV is REAL array, dimension (LA)
108*> \endverbatim
109*>
110*> \param[out] B
111*> \verbatim
112*> B is REAL array, dimension (NMAX*NRHS)
113*> \endverbatim
114*>
115*> \param[out] BSAV
116*> \verbatim
117*> BSAV is REAL array, dimension (NMAX*NRHS)
118*> \endverbatim
119*>
120*> \param[out] X
121*> \verbatim
122*> X is REAL array, dimension (NMAX*NRHS)
123*> \endverbatim
124*>
125*> \param[out] XACT
126*> \verbatim
127*> XACT is REAL array, dimension (NMAX*NRHS)
128*> \endverbatim
129*>
130*> \param[out] S
131*> \verbatim
132*> S is REAL array, dimension (2*NMAX)
133*> \endverbatim
134*>
135*> \param[out] WORK
136*> \verbatim
137*> WORK is REAL array, dimension
138*> (NMAX*max(3,NRHS,NMAX))
139*> \endverbatim
140*>
141*> \param[out] RWORK
142*> \verbatim
143*> RWORK is REAL array, dimension
144*> (NMAX+2*NRHS)
145*> \endverbatim
146*>
147*> \param[out] IWORK
148*> \verbatim
149*> IWORK is INTEGER array, dimension (2*NMAX)
150*> \endverbatim
151*>
152*> \param[in] NOUT
153*> \verbatim
154*> NOUT is INTEGER
155*> The unit number for output.
156*> \endverbatim
157*
158* Authors:
159* ========
160*
161*> \author Univ. of Tennessee
162*> \author Univ. of California Berkeley
163*> \author Univ. of Colorado Denver
164*> \author NAG Ltd.
165*
166*> \ingroup single_lin
167*
168* =====================================================================
169 SUBROUTINE sdrvgb( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA,
170 $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK,
171 $ RWORK, IWORK, NOUT )
172*
173* -- LAPACK test routine --
174* -- LAPACK is a software package provided by Univ. of Tennessee, --
175* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176*
177* .. Scalar Arguments ..
178 LOGICAL TSTERR
179 INTEGER LA, LAFB, NN, NOUT, NRHS
180 REAL THRESH
181* ..
182* .. Array Arguments ..
183 LOGICAL DOTYPE( * )
184 INTEGER IWORK( * ), NVAL( * )
185 REAL A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
186 $ rwork( * ), s( * ), work( * ), x( * ),
187 $ xact( * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 REAL ONE, ZERO
194 PARAMETER ( ONE = 1.0e+0, zero = 0.0e+0 )
195 INTEGER NTYPES
196 parameter( ntypes = 8 )
197 INTEGER NTESTS
198 parameter( ntests = 7 )
199 INTEGER NTRAN
200 parameter( ntran = 3 )
201* ..
202* .. Local Scalars ..
203 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
204 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
205 CHARACTER*3 PATH
206 INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN,
207 $ info, ioff, itran, izero, j, k, k1, kl, ku,
208 $ lda, ldafb, ldb, mode, n, nb, nbmin, nerrs,
209 $ nfact, nfail, nimat, nkl, nku, nrun, nt
210 REAL AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV,
211 $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO,
212 $ roldc, roldi, roldo, rowcnd, rpvgrw
213* ..
214* .. Local Arrays ..
215 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
216 INTEGER ISEED( 4 ), ISEEDY( 4 )
217 REAL RESULT( NTESTS )
218* ..
219* .. External Functions ..
220 LOGICAL LSAME
221 REAL SGET06, SLAMCH, SLANGB, SLANGE, SLANTB
222 EXTERNAL lsame, sget06, slamch, slangb, slange, slantb
223* ..
224* .. External Subroutines ..
225 EXTERNAL aladhd, alaerh, alasvm, serrvx, sgbequ, sgbsv,
226 $ sgbsvx, sgbt01, sgbt02, sgbt05, sgbtrf, sgbtrs,
227 $ sget04, slacpy, slaqgb, slarhs, slaset, slatb4,
228 $ slatms, xlaenv
229* ..
230* .. Intrinsic Functions ..
231 INTRINSIC abs, max, min
232* ..
233* .. Scalars in Common ..
234 LOGICAL LERR, OK
235 CHARACTER*32 SRNAMT
236 INTEGER INFOT, NUNIT
237* ..
238* .. Common blocks ..
239 COMMON / infoc / infot, nunit, ok, lerr
240 COMMON / srnamc / srnamt
241* ..
242* .. Data statements ..
243 DATA iseedy / 1988, 1989, 1990, 1991 /
244 DATA transs / 'N', 'T', 'C' /
245 DATA facts / 'F', 'N', 'E' /
246 DATA equeds / 'n', 'r', 'c', 'b' /
247* ..
248* .. Executable Statements ..
249*
250* Initialize constants and the random number seed.
251*
252 PATH( 1: 1 ) = 'single precision'
253 PATH( 2: 3 ) = 'gb'
254 NRUN = 0
255 NFAIL = 0
256 NERRS = 0
257 DO 10 I = 1, 4
258 ISEED( I ) = ISEEDY( I )
259 10 CONTINUE
260*
261* Test the error exits
262*
263 IF( TSTERR )
264 $ CALL SERRVX( PATH, NOUT )
265 INFOT = 0
266*
267* Set the block size and minimum block size for testing.
268*
269 NB = 1
270 NBMIN = 2
271 CALL XLAENV( 1, NB )
272 CALL XLAENV( 2, NBMIN )
273*
274* Do for each value of N in NVAL
275*
276 DO 150 IN = 1, NN
277 N = NVAL( IN )
278 LDB = MAX( N, 1 )
279 XTYPE = 'n'
280*
281* Set limits on the number of loop iterations.
282*
283 NKL = MAX( 1, MIN( N, 4 ) )
284.EQ. IF( N0 )
285 $ NKL = 1
286 NKU = NKL
287 NIMAT = NTYPES
288.LE. IF( N0 )
289 $ NIMAT = 1
290*
291 DO 140 IKL = 1, NKL
292*
293* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes
294* it easier to skip redundant values for small values of N.
295*
296.EQ. IF( IKL1 ) THEN
297 KL = 0
298.EQ. ELSE IF( IKL2 ) THEN
299 KL = MAX( N-1, 0 )
300.EQ. ELSE IF( IKL3 ) THEN
301 KL = ( 3*N-1 ) / 4
302.EQ. ELSE IF( IKL4 ) THEN
303 KL = ( N+1 ) / 4
304 END IF
305 DO 130 IKU = 1, NKU
306*
307* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order
308* makes it easier to skip redundant values for small
309* values of N.
310*
311.EQ. IF( IKU1 ) THEN
312 KU = 0
313.EQ. ELSE IF( IKU2 ) THEN
314 KU = MAX( N-1, 0 )
315.EQ. ELSE IF( IKU3 ) THEN
316 KU = ( 3*N-1 ) / 4
317.EQ. ELSE IF( IKU4 ) THEN
318 KU = ( N+1 ) / 4
319 END IF
320*
321* Check that A and AFB are big enough to generate this
322* matrix.
323*
324 LDA = KL + KU + 1
325 LDAFB = 2*KL + KU + 1
326.GT..OR..GT. IF( LDA*NLA LDAFB*NLAFB ) THEN
327.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
328 $ CALL ALADHD( NOUT, PATH )
329.GT. IF( LDA*NLA ) THEN
330 WRITE( NOUT, FMT = 9999 )LA, N, KL, KU,
331 $ N*( KL+KU+1 )
332 NERRS = NERRS + 1
333 END IF
334.GT. IF( LDAFB*NLAFB ) THEN
335 WRITE( NOUT, FMT = 9998 )LAFB, N, KL, KU,
336 $ N*( 2*KL+KU+1 )
337 NERRS = NERRS + 1
338 END IF
339 GO TO 130
340 END IF
341*
342 DO 120 IMAT = 1, NIMAT
343*
344* Do the tests only if DOTYPE( IMAT ) is true.
345*
346.NOT. IF( DOTYPE( IMAT ) )
347 $ GO TO 120
348*
349* Skip types 2, 3, or 4 if the matrix is too small.
350*
351.GE..AND..LE. ZEROT = IMAT2 IMAT4
352.AND..LT. IF( ZEROT NIMAT-1 )
353 $ GO TO 120
354*
355* Set up parameters with SLATB4 and generate a
356* test matrix with SLATMS.
357*
358 CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM,
359 $ MODE, CNDNUM, DIST )
360 RCONDC = ONE / CNDNUM
361*
362 SRNAMT = 'slatms'
363 CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
364 $ CNDNUM, ANORM, KL, KU, 'z', A, LDA, WORK,
365 $ INFO )
366*
367* Check the error code from SLATMS.
368*
369.NE. IF( INFO0 ) THEN
370 CALL ALAERH( PATH, 'slatms', INFO, 0, ' ', N, N,
371 $ KL, KU, -1, IMAT, NFAIL, NERRS, NOUT )
372 GO TO 120
373 END IF
374*
375* For types 2, 3, and 4, zero one or more columns of
376* the matrix to test that INFO is returned correctly.
377*
378 IZERO = 0
379 IF( ZEROT ) THEN
380.EQ. IF( IMAT2 ) THEN
381 IZERO = 1
382.EQ. ELSE IF( IMAT3 ) THEN
383 IZERO = N
384 ELSE
385 IZERO = N / 2 + 1
386 END IF
387 IOFF = ( IZERO-1 )*LDA
388.LT. IF( IMAT4 ) THEN
389 I1 = MAX( 1, KU+2-IZERO )
390 I2 = MIN( KL+KU+1, KU+1+( N-IZERO ) )
391 DO 20 I = I1, I2
392 A( IOFF+I ) = ZERO
393 20 CONTINUE
394 ELSE
395 DO 40 J = IZERO, N
396 DO 30 I = MAX( 1, KU+2-J ),
397 $ MIN( KL+KU+1, KU+1+( N-J ) )
398 A( IOFF+I ) = ZERO
399 30 CONTINUE
400 IOFF = IOFF + LDA
401 40 CONTINUE
402 END IF
403 END IF
404*
405* Save a copy of the matrix A in ASAV.
406*
407 CALL SLACPY( 'full', KL+KU+1, N, A, LDA, ASAV, LDA )
408*
409 DO 110 IEQUED = 1, 4
410 EQUED = EQUEDS( IEQUED )
411.EQ. IF( IEQUED1 ) THEN
412 NFACT = 3
413 ELSE
414 NFACT = 1
415 END IF
416*
417 DO 100 IFACT = 1, NFACT
418 FACT = FACTS( IFACT )
419 PREFAC = LSAME( FACT, 'f' )
420 NOFACT = LSAME( FACT, 'n' )
421 EQUIL = LSAME( FACT, 'e' )
422*
423 IF( ZEROT ) THEN
424 IF( PREFAC )
425 $ GO TO 100
426 RCONDO = ZERO
427 RCONDI = ZERO
428*
429.NOT. ELSE IF( NOFACT ) THEN
430*
431* Compute the condition number for comparison
432* with the value returned by SGESVX (FACT =
433* 'N' reuses the condition number from the
434* previous iteration with FACT = 'F').
435*
436 CALL SLACPY( 'full', KL+KU+1, N, ASAV, LDA,
437 $ AFB( KL+1 ), LDAFB )
438.OR..GT. IF( EQUIL IEQUED1 ) THEN
439*
440* Compute row and column scale factors to
441* equilibrate the matrix A.
442*
443 CALL SGBEQU( N, N, KL, KU, AFB( KL+1 ),
444 $ LDAFB, S, S( N+1 ), ROWCND,
445 $ COLCND, AMAX, INFO )
446.EQ..AND..GT. IF( INFO0 N0 ) THEN
447 IF( LSAME( EQUED, 'r' ) ) THEN
448 ROWCND = ZERO
449 COLCND = ONE
450 ELSE IF( LSAME( EQUED, 'c' ) ) THEN
451 ROWCND = ONE
452 COLCND = ZERO
453 ELSE IF( LSAME( EQUED, 'b' ) ) THEN
454 ROWCND = ZERO
455 COLCND = ZERO
456 END IF
457*
458* Equilibrate the matrix.
459*
460 CALL SLAQGB( N, N, KL, KU, AFB( KL+1 ),
461 $ LDAFB, S, S( N+1 ),
462 $ ROWCND, COLCND, AMAX,
463 $ EQUED )
464 END IF
465 END IF
466*
467* Save the condition number of the
468* non-equilibrated system for use in SGET04.
469*
470 IF( EQUIL ) THEN
471 ROLDO = RCONDO
472 ROLDI = RCONDI
473 END IF
474*
475* Compute the 1-norm and infinity-norm of A.
476*
477 ANORMO = SLANGB( '1', N, KL, KU, AFB( KL+1 ),
478 $ LDAFB, RWORK )
479 ANORMI = SLANGB( 'i', N, KL, KU, AFB( KL+1 ),
480 $ LDAFB, RWORK )
481*
482* Factor the matrix A.
483*
484 CALL SGBTRF( N, N, KL, KU, AFB, LDAFB, IWORK,
485 $ INFO )
486*
487* Form the inverse of A.
488*
489 CALL SLASET( 'full', N, N, ZERO, ONE, WORK,
490 $ LDB )
491 SRNAMT = 'sgbtrs'
492 CALL SGBTRS( 'no transpose', N, KL, KU, N,
493 $ AFB, LDAFB, IWORK, WORK, LDB,
494 $ INFO )
495*
496* Compute the 1-norm condition number of A.
497*
498 AINVNM = SLANGE( '1', N, N, WORK, LDB,
499 $ RWORK )
500.LE..OR..LE. IF( ANORMOZERO AINVNMZERO ) THEN
501 RCONDO = ONE
502 ELSE
503 RCONDO = ( ONE / ANORMO ) / AINVNM
504 END IF
505*
506* Compute the infinity-norm condition number
507* of A.
508*
509 AINVNM = SLANGE( 'i', N, N, WORK, LDB,
510 $ RWORK )
511.LE..OR..LE. IF( ANORMIZERO AINVNMZERO ) THEN
512 RCONDI = ONE
513 ELSE
514 RCONDI = ( ONE / ANORMI ) / AINVNM
515 END IF
516 END IF
517*
518 DO 90 ITRAN = 1, NTRAN
519*
520* Do for each value of TRANS.
521*
522 TRANS = TRANSS( ITRAN )
523.EQ. IF( ITRAN1 ) THEN
524 RCONDC = RCONDO
525 ELSE
526 RCONDC = RCONDI
527 END IF
528*
529* Restore the matrix A.
530*
531 CALL SLACPY( 'full', KL+KU+1, N, ASAV, LDA,
532 $ A, LDA )
533*
534* Form an exact solution and set the right hand
535* side.
536*
537 SRNAMT = 'slarhs'
538 CALL SLARHS( PATH, XTYPE, 'full', TRANS, N,
539 $ N, KL, KU, NRHS, A, LDA, XACT,
540 $ LDB, B, LDB, ISEED, INFO )
541 XTYPE = 'c'
542 CALL SLACPY( 'full', N, NRHS, B, LDB, BSAV,
543 $ LDB )
544*
545.AND..EQ. IF( NOFACT ITRAN1 ) THEN
546*
547* --- Test SGBSV ---
548*
549* Compute the LU factorization of the matrix
550* and solve the system.
551*
552 CALL SLACPY( 'full', KL+KU+1, N, A, LDA,
553 $ AFB( KL+1 ), LDAFB )
554 CALL SLACPY( 'full', N, NRHS, B, LDB, X,
555 $ LDB )
556*
557 SRNAMT = 'sgbsv '
558 CALL SGBSV( N, KL, KU, NRHS, AFB, LDAFB,
559 $ IWORK, X, LDB, INFO )
560*
561* Check error code from SGBSV .
562*
563.NE. IF( INFOIZERO )
564 $ CALL ALAERH( PATH, 'sgbsv ', INFO,
565 $ IZERO, ' ', N, N, KL, KU,
566 $ NRHS, IMAT, NFAIL, NERRS,
567 $ NOUT )
568*
569* Reconstruct matrix from factors and
570* compute residual.
571*
572 CALL SGBT01( N, N, KL, KU, A, LDA, AFB,
573 $ LDAFB, IWORK, WORK,
574 $ RESULT( 1 ) )
575 NT = 1
576.EQ. IF( IZERO0 ) THEN
577*
578* Compute residual of the computed
579* solution.
580*
581 CALL SLACPY( 'full', N, NRHS, B, LDB,
582 $ WORK, LDB )
583 CALL SGBT02( 'no transpose', N, N, KL,
584 $ KU, NRHS, A, LDA, X, LDB,
585 $ WORK, LDB, RWORK,
586 $ RESULT( 2 ) )
587*
588* Check solution from generated exact
589* solution.
590*
591 CALL SGET04( N, NRHS, X, LDB, XACT,
592 $ LDB, RCONDC, RESULT( 3 ) )
593 NT = 3
594 END IF
595*
596* Print information about the tests that did
597* not pass the threshold.
598*
599 DO 50 K = 1, NT
600.GE. IF( RESULT( K )THRESH ) THEN
601.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
602 $ CALL ALADHD( NOUT, PATH )
603 WRITE( NOUT, FMT = 9997 )'sgbsv ',
604 $ N, KL, KU, IMAT, K, RESULT( K )
605 NFAIL = NFAIL + 1
606 END IF
607 50 CONTINUE
608 NRUN = NRUN + NT
609 END IF
610*
611* --- Test SGBSVX ---
612*
613.NOT. IF( PREFAC )
614 $ CALL SLASET( 'full', 2*KL+KU+1, N, ZERO,
615 $ ZERO, AFB, LDAFB )
616 CALL SLASET( 'full', N, NRHS, ZERO, ZERO, X,
617 $ LDB )
618.GT..AND..GT. IF( IEQUED1 N0 ) THEN
619*
620* Equilibrate the matrix if FACT = 'F' and
621* EQUED = 'R', 'C', or 'B'.
622*
623 CALL SLAQGB( N, N, KL, KU, A, LDA, S,
624 $ S( N+1 ), ROWCND, COLCND,
625 $ AMAX, EQUED )
626 END IF
627*
628* Solve the system and compute the condition
629* number and error bounds using SGBSVX.
630*
631 SRNAMT = 'sgbsvx'
632 CALL SGBSVX( FACT, TRANS, N, KL, KU, NRHS, A,
633 $ LDA, AFB, LDAFB, IWORK, EQUED,
634 $ S, S( N+1 ), B, LDB, X, LDB,
635 $ RCOND, RWORK, RWORK( NRHS+1 ),
636 $ WORK, IWORK( N+1 ), INFO )
637*
638* Check the error code from SGBSVX.
639*
640.NE. IF( INFOIZERO )
641 $ CALL ALAERH( PATH, 'sgbsvx', INFO, IZERO,
642 $ FACT // TRANS, N, N, KL, KU,
643 $ NRHS, IMAT, NFAIL, NERRS,
644 $ NOUT )
645*
646* Compare WORK(1) from SGBSVX with the computed
647* reciprocal pivot growth factor RPVGRW
648*
649.NE..AND..LE. IF( INFO0 INFON) THEN
650 ANRMPV = ZERO
651 DO 70 J = 1, INFO
652 DO 60 I = MAX( KU+2-J, 1 ),
653 $ MIN( N+KU+1-J, KL+KU+1 )
654 ANRMPV = MAX( ANRMPV,
655 $ ABS( A( I+( J-1 )*LDA ) ) )
656 60 CONTINUE
657 70 CONTINUE
658 RPVGRW = SLANTB( 'm', 'u', 'n', INFO,
659 $ MIN( INFO-1, KL+KU ),
660 $ AFB( MAX( 1, KL+KU+2-INFO ) ),
661 $ LDAFB, WORK )
662.EQ. IF( RPVGRWZERO ) THEN
663 RPVGRW = ONE
664 ELSE
665 RPVGRW = ANRMPV / RPVGRW
666 END IF
667 ELSE
668 RPVGRW = SLANTB( 'm', 'u', 'n', N, KL+KU,
669 $ AFB, LDAFB, WORK )
670.EQ. IF( RPVGRWZERO ) THEN
671 RPVGRW = ONE
672 ELSE
673 RPVGRW = SLANGB( 'm', N, KL, KU, A,
674 $ LDA, WORK ) / RPVGRW
675 END IF
676 END IF
677 RESULT( 7 ) = ABS( RPVGRW-WORK( 1 ) ) /
678 $ MAX( WORK( 1 ), RPVGRW ) /
679 $ SLAMCH( 'e' )
680*
681.NOT. IF( PREFAC ) THEN
682*
683* Reconstruct matrix from factors and
684* compute residual.
685*
686 CALL SGBT01( N, N, KL, KU, A, LDA, AFB,
687 $ LDAFB, IWORK, WORK,
688 $ RESULT( 1 ) )
689 K1 = 1
690 ELSE
691 K1 = 2
692 END IF
693*
694.EQ. IF( INFO0 ) THEN
695 TRFCON = .FALSE.
696*
697* Compute residual of the computed solution.
698*
699 CALL SLACPY( 'full', N, NRHS, BSAV, LDB,
700 $ WORK, LDB )
701 CALL SGBT02( TRANS, N, N, KL, KU, NRHS,
702 $ ASAV, LDA, X, LDB, WORK, LDB,
703 $ RWORK( 2*NRHS+1 ),
704 $ RESULT( 2 ) )
705*
706* Check solution from generated exact
707* solution.
708*
709.OR..AND. IF( NOFACT ( PREFAC
710 $ LSAME( EQUED, 'n' ) ) ) THEN
711 CALL SGET04( N, NRHS, X, LDB, XACT,
712 $ LDB, RCONDC, RESULT( 3 ) )
713 ELSE
714.EQ. IF( ITRAN1 ) THEN
715 ROLDC = ROLDO
716 ELSE
717 ROLDC = ROLDI
718 END IF
719 CALL SGET04( N, NRHS, X, LDB, XACT,
720 $ LDB, ROLDC, RESULT( 3 ) )
721 END IF
722*
723* Check the error bounds from iterative
724* refinement.
725*
726 CALL SGBT05( TRANS, N, KL, KU, NRHS, ASAV,
727 $ LDA, B, LDB, X, LDB, XACT,
728 $ LDB, RWORK, RWORK( NRHS+1 ),
729 $ RESULT( 4 ) )
730 ELSE
731 TRFCON = .TRUE.
732 END IF
733*
734* Compare RCOND from SGBSVX with the computed
735* value in RCONDC.
736*
737 RESULT( 6 ) = SGET06( RCOND, RCONDC )
738*
739* Print information about the tests that did
740* not pass the threshold.
741*
742.NOT. IF( TRFCON ) THEN
743 DO 80 K = K1, NTESTS
744.GE. IF( RESULT( K )THRESH ) THEN
745.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
746 $ CALL ALADHD( NOUT, PATH )
747 IF( PREFAC ) THEN
748 WRITE( NOUT, FMT = 9995 )
749 $ 'sgbsvx', FACT, TRANS, N, KL,
750 $ KU, EQUED, IMAT, K,
751 $ RESULT( K )
752 ELSE
753 WRITE( NOUT, FMT = 9996 )
754 $ 'sgbsvx', FACT, TRANS, N, KL,
755 $ KU, IMAT, K, RESULT( K )
756 END IF
757 NFAIL = NFAIL + 1
758 END IF
759 80 CONTINUE
760 NRUN = NRUN + NTESTS - K1 + 1
761 ELSE
762.GE..AND..NOT. IF( RESULT( 1 )THRESH
763 $ PREFAC ) THEN
764.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
765 $ CALL ALADHD( NOUT, PATH )
766 IF( PREFAC ) THEN
767 WRITE( NOUT, FMT = 9995 )'sgbsvx',
768 $ FACT, TRANS, N, KL, KU, EQUED,
769 $ IMAT, 1, RESULT( 1 )
770 ELSE
771 WRITE( NOUT, FMT = 9996 )'sgbsvx',
772 $ FACT, TRANS, N, KL, KU, IMAT, 1,
773 $ RESULT( 1 )
774 END IF
775 NFAIL = NFAIL + 1
776 NRUN = NRUN + 1
777 END IF
778.GE. IF( RESULT( 6 )THRESH ) THEN
779.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
780 $ CALL ALADHD( NOUT, PATH )
781 IF( PREFAC ) THEN
782 WRITE( NOUT, FMT = 9995 )'sgbsvx',
783 $ FACT, TRANS, N, KL, KU, EQUED,
784 $ IMAT, 6, RESULT( 6 )
785 ELSE
786 WRITE( NOUT, FMT = 9996 )'sgbsvx',
787 $ FACT, TRANS, N, KL, KU, IMAT, 6,
788 $ RESULT( 6 )
789 END IF
790 NFAIL = NFAIL + 1
791 NRUN = NRUN + 1
792 END IF
793.GE. IF( RESULT( 7 )THRESH ) THEN
794.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
795 $ CALL ALADHD( NOUT, PATH )
796 IF( PREFAC ) THEN
797 WRITE( NOUT, FMT = 9995 )'sgbsvx',
798 $ FACT, TRANS, N, KL, KU, EQUED,
799 $ IMAT, 7, RESULT( 7 )
800 ELSE
801 WRITE( NOUT, FMT = 9996 )'sgbsvx',
802 $ FACT, TRANS, N, KL, KU, IMAT, 7,
803 $ RESULT( 7 )
804 END IF
805 NFAIL = NFAIL + 1
806 NRUN = NRUN + 1
807 END IF
808*
809 END IF
810 90 CONTINUE
811 100 CONTINUE
812 110 CONTINUE
813 120 CONTINUE
814 130 CONTINUE
815 140 CONTINUE
816 150 CONTINUE
817*
818* Print a summary of the results.
819*
820 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
821*
822 9999 FORMAT( ' *** in sdrvgb, la=', I5, ' is too small for n=', I5,
823 $ ', ku=', I5, ', kl=', I5, / ' ==> increase la to at least ',
824 $ I5 )
825 9998 FORMAT( ' *** in sdrvgb, lafb=', I5, ' is too small for n=', I5,
826 $ ', ku=', I5, ', kl=', I5, /
827 $ ' ==> increase lafb to at least ', I5 )
828 9997 FORMAT( 1X, A, ', n=', I5, ', kl=', I5, ', ku=', I5, ', type ',
829 $ I1, ', test(', I1, ')=', G12.5 )
830 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',
831 $ I5, ',...), type ', I1, ', test(', I1, ')=', G12.5 )
832 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',
833 $ I5, ',...), equed=''', A1, ''', type ', I1, ', test(', I1,
834 $ ')=', G12.5 )
835*
836 RETURN
837*
838* End of SDRVGB
839*
840 END
slaset
subroutine slaset(uplo, m, n, alpha, beta, a, lda)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition slaset.f:110
slacpy
subroutine slacpy(uplo, m, n, a, lda, b, ldb)
SLACPY copies all or part of one two-dimensional array to another.
Definition slacpy.f:103
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
slaqgb
subroutine slaqgb(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, equed)
SLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ.
Definition slaqgb.f:159
sgbtrf
subroutine sgbtrf(m, n, kl, ku, ab, ldab, ipiv, info)
SGBTRF
Definition sgbtrf.f:144
sgbequ
subroutine sgbequ(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, info)
SGBEQU
Definition sgbequ.f:153
sgbtrs
subroutine sgbtrs(trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
SGBTRS
Definition sgbtrs.f:138
sgbsvx
subroutine sgbsvx(fact, trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
SGBSVX computes the solution to system of linear equations A * X = B for GB matrices
Definition sgbsvx.f:368
sgbsv
subroutine sgbsv(n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
SGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver)
Definition sgbsv.f:162
slatms
subroutine slatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
SLATMS
Definition slatms.f:321
slarhs
subroutine slarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
SLARHS
Definition slarhs.f:205
sgbt05
subroutine sgbt05(trans, n, kl, ku, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
SGBT05
Definition sgbt05.f:176
sgbt02
subroutine sgbt02(trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
SGBT02
Definition sgbt02.f:149
serrvx
subroutine serrvx(path, nunit)
SERRVX
Definition serrvx.f:55
sgbt01
subroutine sgbt01(m, n, kl, ku, a, lda, afac, ldafac, ipiv, work, resid)
SGBT01
Definition sgbt01.f:126
sdrvgb
subroutine sdrvgb(dotype, nn, nval, nrhs, thresh, tsterr, a, la, afb, lafb, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
SDRVGB
Definition sdrvgb.f:172
sget04
subroutine sget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
SGET04
Definition sget04.f:102
slatb4
subroutine slatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
SLATB4
Definition slatb4.f:120
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