You can not select more than 25 topics Topics must start with a chinese character,a letter or number, can include dashes ('-') and can be up to 35 characters long.

sdrvgbx.f 40 kB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031
  1. *> \brief \b SDRVGBX
  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, -SVX, and -SVXX.
  35. *>
  36. *> Note that this file is used only when the XBLAS are available,
  37. *> otherwise sdrvgb.f defines this subroutine.
  38. *> \endverbatim
  39. *
  40. * Arguments:
  41. * ==========
  42. *
  43. *> \param[in] DOTYPE
  44. *> \verbatim
  45. *> DOTYPE is LOGICAL array, dimension (NTYPES)
  46. *> The matrix types to be used for testing. Matrices of type j
  47. *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
  48. *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
  49. *> \endverbatim
  50. *>
  51. *> \param[in] NN
  52. *> \verbatim
  53. *> NN is INTEGER
  54. *> The number of values of N contained in the vector NVAL.
  55. *> \endverbatim
  56. *>
  57. *> \param[in] NVAL
  58. *> \verbatim
  59. *> NVAL is INTEGER array, dimension (NN)
  60. *> The values of the matrix column dimension N.
  61. *> \endverbatim
  62. *>
  63. *> \param[in] NRHS
  64. *> \verbatim
  65. *> NRHS is INTEGER
  66. *> The number of right hand side vectors to be generated for
  67. *> each linear system.
  68. *> \endverbatim
  69. *>
  70. *> \param[in] THRESH
  71. *> \verbatim
  72. *> THRESH is REAL
  73. *> The threshold value for the test ratios. A result is
  74. *> included in the output file if RESULT >= THRESH. To have
  75. *> every test ratio printed, use THRESH = 0.
  76. *> \endverbatim
  77. *>
  78. *> \param[in] TSTERR
  79. *> \verbatim
  80. *> TSTERR is LOGICAL
  81. *> Flag that indicates whether error exits are to be tested.
  82. *> \endverbatim
  83. *>
  84. *> \param[out] A
  85. *> \verbatim
  86. *> A is REAL 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 REAL 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 REAL array, dimension (LA)
  111. *> \endverbatim
  112. *>
  113. *> \param[out] B
  114. *> \verbatim
  115. *> B is REAL array, dimension (NMAX*NRHS)
  116. *> \endverbatim
  117. *>
  118. *> \param[out] BSAV
  119. *> \verbatim
  120. *> BSAV is REAL array, dimension (NMAX*NRHS)
  121. *> \endverbatim
  122. *>
  123. *> \param[out] X
  124. *> \verbatim
  125. *> X is REAL array, dimension (NMAX*NRHS)
  126. *> \endverbatim
  127. *>
  128. *> \param[out] XACT
  129. *> \verbatim
  130. *> XACT is REAL array, dimension (NMAX*NRHS)
  131. *> \endverbatim
  132. *>
  133. *> \param[out] S
  134. *> \verbatim
  135. *> S is REAL array, dimension (2*NMAX)
  136. *> \endverbatim
  137. *>
  138. *> \param[out] WORK
  139. *> \verbatim
  140. *> WORK is REAL array, dimension
  141. *> (NMAX*max(3,NRHS,NMAX))
  142. *> \endverbatim
  143. *>
  144. *> \param[out] RWORK
  145. *> \verbatim
  146. *> RWORK is REAL 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 single_lin
  170. *
  171. * =====================================================================
  172. SUBROUTINE SDRVGB( 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. REAL THRESH
  184. * ..
  185. * .. Array Arguments ..
  186. LOGICAL DOTYPE( * )
  187. INTEGER IWORK( * ), NVAL( * )
  188. REAL A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
  189. $ RWORK( * ), S( * ), WORK( * ), X( * ),
  190. $ XACT( * )
  191. * ..
  192. *
  193. * =====================================================================
  194. *
  195. * .. Parameters ..
  196. REAL ONE, ZERO
  197. PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+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. REAL 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. REAL RESULT( NTESTS ), BERR( NRHS ),
  223. $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 )
  224. * ..
  225. * .. External Functions ..
  226. LOGICAL LSAME
  227. REAL SGET06, SLAMCH, SLANGB, SLANGE, SLANTB,
  228. $ SLA_GBRPVGRW
  229. EXTERNAL LSAME, SGET06, SLAMCH, SLANGB, SLANGE, SLANTB,
  230. $ SLA_GBRPVGRW
  231. * ..
  232. * .. External Subroutines ..
  233. EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGBEQU, SGBSV,
  234. $ SGBSVX, SGBT01, SGBT02, SGBT05, SGBTRF, SGBTRS,
  235. $ SGET04, SLACPY, SLAQGB, SLARHS, SLASET, SLATB4,
  236. $ SLATMS, XLAENV, SGBSVXX
  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 ) = 'Single 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 SERRVX( 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 SLATB4 and generate a
  364. * test matrix with SLATMS.
  365. *
  366. CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM,
  367. $ MODE, CNDNUM, DIST )
  368. RCONDC = ONE / CNDNUM
  369. *
  370. SRNAMT = 'SLATMS'
  371. CALL SLATMS( 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 SLATMS.
  376. *
  377. IF( INFO.NE.0 ) THEN
  378. CALL ALAERH( PATH, 'SLATMS', 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 SLACPY( '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 SGESVX (FACT =
  441. * 'N' reuses the condition number from the
  442. * previous iteration with FACT = 'F').
  443. *
  444. CALL SLACPY( '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 SGBEQU( 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 SLAQGB( 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 SGET04.
  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 = SLANGB( '1', N, KL, KU, AFB( KL+1 ),
  486. $ LDAFB, RWORK )
  487. ANORMI = SLANGB( 'I', N, KL, KU, AFB( KL+1 ),
  488. $ LDAFB, RWORK )
  489. *
  490. * Factor the matrix A.
  491. *
  492. CALL SGBTRF( N, N, KL, KU, AFB, LDAFB, IWORK,
  493. $ INFO )
  494. *
  495. * Form the inverse of A.
  496. *
  497. CALL SLASET( 'Full', N, N, ZERO, ONE, WORK,
  498. $ LDB )
  499. SRNAMT = 'SGBTRS'
  500. CALL SGBTRS( '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 = SLANGE( '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 = SLANGE( '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 SLACPY( '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 = 'SLARHS'
  546. CALL SLARHS( PATH, XTYPE, 'Full', TRANS, N,
  547. $ N, KL, KU, NRHS, A, LDA, XACT,
  548. $ LDB, B, LDB, ISEED, INFO )
  549. XTYPE = 'C'
  550. CALL SLACPY( 'Full', N, NRHS, B, LDB, BSAV,
  551. $ LDB )
  552. *
  553. IF( NOFACT .AND. ITRAN.EQ.1 ) THEN
  554. *
  555. * --- Test SGBSV ---
  556. *
  557. * Compute the LU factorization of the matrix
  558. * and solve the system.
  559. *
  560. CALL SLACPY( 'Full', KL+KU+1, N, A, LDA,
  561. $ AFB( KL+1 ), LDAFB )
  562. CALL SLACPY( 'Full', N, NRHS, B, LDB, X,
  563. $ LDB )
  564. *
  565. SRNAMT = 'SGBSV '
  566. CALL SGBSV( N, KL, KU, NRHS, AFB, LDAFB,
  567. $ IWORK, X, LDB, INFO )
  568. *
  569. * Check error code from SGBSV .
  570. *
  571. IF( INFO.NE.IZERO )
  572. $ CALL ALAERH( PATH, 'SGBSV ', 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 SGBT01( 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 SLACPY( 'Full', N, NRHS, B, LDB,
  590. $ WORK, LDB )
  591. CALL SGBT02( '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 SGET04( 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 )'SGBSV ',
  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 SGBSVX ---
  620. *
  621. IF( .NOT.PREFAC )
  622. $ CALL SLASET( 'Full', 2*KL+KU+1, N, ZERO,
  623. $ ZERO, AFB, LDAFB )
  624. CALL SLASET( '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 SLAQGB( 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 SGBSVX.
  638. *
  639. SRNAMT = 'SGBSVX'
  640. CALL SGBSVX( 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 SGBSVX.
  647. *
  648. IF( INFO.NE.IZERO )
  649. $ CALL ALAERH( PATH, 'SGBSVX', INFO, IZERO,
  650. $ FACT // TRANS, N, N, KL, KU,
  651. $ NRHS, IMAT, NFAIL, NERRS,
  652. $ NOUT )
  653. *
  654. * Compare WORK(1) from SGBSVX 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 = SLANTB( '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 = SLANTB( 'M', 'U', 'N', N, KL+KU,
  677. $ AFB, LDAFB, WORK )
  678. IF( RPVGRW.EQ.ZERO ) THEN
  679. RPVGRW = ONE
  680. ELSE
  681. RPVGRW = SLANGB( '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. $ SLAMCH( 'E' )
  688. *
  689. IF( .NOT.PREFAC ) THEN
  690. *
  691. * Reconstruct matrix from factors and
  692. * compute residual.
  693. *
  694. CALL SGBT01( 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 SLACPY( 'Full', N, NRHS, BSAV, LDB,
  708. $ WORK, LDB )
  709. CALL SGBT02( 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 SGET04( N, NRHS, X, LDB, XACT,
  720. $ LDB, RCONDC, RESULT( 3 ) )
  721. ELSE
  722. IF( ITRAN.EQ.1 ) THEN
  723. ROLDC = ROLDO
  724. ELSE
  725. ROLDC = ROLDI
  726. END IF
  727. CALL SGET04( 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 SGBT05( 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 SGBSVX with the computed
  743. * value in RCONDC.
  744. *
  745. RESULT( 6 ) = SGET06( RCOND, RCONDC )
  746. *
  747. * Print information about the tests that did
  748. * not pass the threshold.
  749. *
  750. IF( .NOT.TRFCON ) THEN
  751. DO 80 K = K1, NTESTS
  752. IF( RESULT( K ).GE.THRESH ) THEN
  753. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  754. $ CALL ALADHD( NOUT, PATH )
  755. IF( PREFAC ) THEN
  756. WRITE( NOUT, FMT = 9995 )
  757. $ 'SGBSVX', FACT, TRANS, N, KL,
  758. $ KU, EQUED, IMAT, K,
  759. $ RESULT( K )
  760. ELSE
  761. WRITE( NOUT, FMT = 9996 )
  762. $ 'SGBSVX', 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. IF( RESULT( 1 ).GE.THRESH .AND. .NOT.
  771. $ PREFAC ) THEN
  772. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  773. $ CALL ALADHD( NOUT, PATH )
  774. IF( PREFAC ) THEN
  775. WRITE( NOUT, FMT = 9995 )'SGBSVX',
  776. $ FACT, TRANS, N, KL, KU, EQUED,
  777. $ IMAT, 1, RESULT( 1 )
  778. ELSE
  779. WRITE( NOUT, FMT = 9996 )'SGBSVX',
  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. IF( RESULT( 6 ).GE.THRESH ) THEN
  787. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  788. $ CALL ALADHD( NOUT, PATH )
  789. IF( PREFAC ) THEN
  790. WRITE( NOUT, FMT = 9995 )'SGBSVX',
  791. $ FACT, TRANS, N, KL, KU, EQUED,
  792. $ IMAT, 6, RESULT( 6 )
  793. ELSE
  794. WRITE( NOUT, FMT = 9996 )'SGBSVX',
  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. IF( RESULT( 7 ).GE.THRESH ) THEN
  802. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  803. $ CALL ALADHD( NOUT, PATH )
  804. IF( PREFAC ) THEN
  805. WRITE( NOUT, FMT = 9995 )'SGBSVX',
  806. $ FACT, TRANS, N, KL, KU, EQUED,
  807. $ IMAT, 7, RESULT( 7 )
  808. ELSE
  809. WRITE( NOUT, FMT = 9996 )'SGBSVX',
  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 SGBSVXX ---
  820. *
  821. * Restore the matrices A and B.
  822. *
  823. CALL SLACPY( 'Full', KL+KU+1, N, ASAV, LDA, A,
  824. $ LDA )
  825. CALL SLACPY( 'Full', N, NRHS, BSAV, LDB, B, LDB )
  826. IF( .NOT.PREFAC )
  827. $ CALL SLASET( 'Full', 2*KL+KU+1, N, ZERO, ZERO,
  828. $ AFB, LDAFB )
  829. CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDB )
  830. IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
  831. *
  832. * Equilibrate the matrix if FACT = 'F' and
  833. * EQUED = 'R', 'C', or 'B'.
  834. *
  835. CALL SLAQGB( N, N, KL, KU, A, LDA, S,
  836. $ S( N+1 ), ROWCND, COLCND, AMAX, EQUED )
  837. END IF
  838. *
  839. * Solve the system and compute the condition number
  840. * and error bounds using SGBSVXX.
  841. *
  842. SRNAMT = 'SGBSVXX'
  843. N_ERR_BNDS = 3
  844. CALL SGBSVXX( FACT, TRANS, N, KL, KU, NRHS, A, LDA,
  845. $ AFB, LDAFB, IWORK, EQUED, S, S( N+1 ), B, LDB,
  846. $ X, LDB, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS,
  847. $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK,
  848. $ IWORK( N+1 ), INFO )
  849. * Check the error code from SGBSVXX.
  850. *
  851. IF( INFO.EQ.N+1 ) GOTO 90
  852. IF( INFO.NE.IZERO ) THEN
  853. CALL ALAERH( PATH, 'SGBSVXX', INFO, IZERO,
  854. $ FACT // TRANS, N, N, -1, -1, NRHS,
  855. $ IMAT, NFAIL, NERRS, NOUT )
  856. GOTO 90
  857. END IF
  858. *
  859. * Compare rpvgrw_svxx from SGBSVXX with the computed
  860. * reciprocal pivot growth factor RPVGRW
  861. *
  862. IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN
  863. RPVGRW = SLA_GBRPVGRW(N, KL, KU, INFO, A, LDA,
  864. $ AFB, LDAFB )
  865. ELSE
  866. RPVGRW = SLA_GBRPVGRW(N, KL, KU, N, A, LDA,
  867. $ AFB, LDAFB )
  868. ENDIF
  869. RESULT( 7 ) = ABS( RPVGRW-rpvgrw_svxx ) /
  870. $ MAX( rpvgrw_svxx, RPVGRW ) /
  871. $ SLAMCH( 'E' )
  872. *
  873. IF( .NOT.PREFAC ) THEN
  874. *
  875. * Reconstruct matrix from factors and compute
  876. * residual.
  877. *
  878. CALL SGBT01( N, N, KL, KU, A, LDA, AFB, LDAFB,
  879. $ IWORK, WORK,
  880. $ RESULT( 1 ) )
  881. K1 = 1
  882. ELSE
  883. K1 = 2
  884. END IF
  885. *
  886. IF( INFO.EQ.0 ) THEN
  887. TRFCON = .FALSE.
  888. *
  889. * Compute residual of the computed solution.
  890. *
  891. CALL SLACPY( 'Full', N, NRHS, BSAV, LDB, WORK,
  892. $ LDB )
  893. CALL SGBT02( TRANS, N, N, KL, KU, NRHS, ASAV,
  894. $ LDA, X, LDB, WORK, LDB, RWORK,
  895. $ RESULT( 2 ) )
  896. *
  897. * Check solution from generated exact solution.
  898. *
  899. IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED,
  900. $ 'N' ) ) ) THEN
  901. CALL SGET04( N, NRHS, X, LDB, XACT, LDB,
  902. $ RCONDC, RESULT( 3 ) )
  903. ELSE
  904. IF( ITRAN.EQ.1 ) THEN
  905. ROLDC = ROLDO
  906. ELSE
  907. ROLDC = ROLDI
  908. END IF
  909. CALL SGET04( N, NRHS, X, LDB, XACT, LDB,
  910. $ ROLDC, RESULT( 3 ) )
  911. END IF
  912. ELSE
  913. TRFCON = .TRUE.
  914. END IF
  915. *
  916. * Compare RCOND from SGBSVXX with the computed value
  917. * in RCONDC.
  918. *
  919. RESULT( 6 ) = SGET06( RCOND, RCONDC )
  920. *
  921. * Print information about the tests that did not pass
  922. * the threshold.
  923. *
  924. IF( .NOT.TRFCON ) THEN
  925. DO 45 K = K1, NTESTS
  926. IF( RESULT( K ).GE.THRESH ) THEN
  927. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  928. $ CALL ALADHD( NOUT, PATH )
  929. IF( PREFAC ) THEN
  930. WRITE( NOUT, FMT = 9995 )'SGBSVXX',
  931. $ FACT, TRANS, N, KL, KU, EQUED,
  932. $ IMAT, K, RESULT( K )
  933. ELSE
  934. WRITE( NOUT, FMT = 9996 )'SGBSVXX',
  935. $ FACT, TRANS, N, KL, KU, IMAT, K,
  936. $ RESULT( K )
  937. END IF
  938. NFAIL = NFAIL + 1
  939. END IF
  940. 45 CONTINUE
  941. NRUN = NRUN + 7 - K1
  942. ELSE
  943. IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC )
  944. $ THEN
  945. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  946. $ CALL ALADHD( NOUT, PATH )
  947. IF( PREFAC ) THEN
  948. WRITE( NOUT, FMT = 9995 )'SGBSVXX', FACT,
  949. $ TRANS, N, KL, KU, EQUED, IMAT, 1,
  950. $ RESULT( 1 )
  951. ELSE
  952. WRITE( NOUT, FMT = 9996 )'SGBSVXX', FACT,
  953. $ TRANS, N, KL, KU, IMAT, 1,
  954. $ RESULT( 1 )
  955. END IF
  956. NFAIL = NFAIL + 1
  957. NRUN = NRUN + 1
  958. END IF
  959. IF( RESULT( 6 ).GE.THRESH ) THEN
  960. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  961. $ CALL ALADHD( NOUT, PATH )
  962. IF( PREFAC ) THEN
  963. WRITE( NOUT, FMT = 9995 )'SGBSVXX', FACT,
  964. $ TRANS, N, KL, KU, EQUED, IMAT, 6,
  965. $ RESULT( 6 )
  966. ELSE
  967. WRITE( NOUT, FMT = 9996 )'SGBSVXX', FACT,
  968. $ TRANS, N, KL, KU, IMAT, 6,
  969. $ RESULT( 6 )
  970. END IF
  971. NFAIL = NFAIL + 1
  972. NRUN = NRUN + 1
  973. END IF
  974. IF( RESULT( 7 ).GE.THRESH ) THEN
  975. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  976. $ CALL ALADHD( NOUT, PATH )
  977. IF( PREFAC ) THEN
  978. WRITE( NOUT, FMT = 9995 )'SGBSVXX', FACT,
  979. $ TRANS, N, KL, KU, EQUED, IMAT, 7,
  980. $ RESULT( 7 )
  981. ELSE
  982. WRITE( NOUT, FMT = 9996 )'SGBSVXX', FACT,
  983. $ TRANS, N, KL, KU, IMAT, 7,
  984. $ RESULT( 7 )
  985. END IF
  986. NFAIL = NFAIL + 1
  987. NRUN = NRUN + 1
  988. END IF
  989. END IF
  990. *
  991. 90 CONTINUE
  992. 100 CONTINUE
  993. 110 CONTINUE
  994. 120 CONTINUE
  995. 130 CONTINUE
  996. 140 CONTINUE
  997. 150 CONTINUE
  998. *
  999. * Print a summary of the results.
  1000. *
  1001. CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
  1002. *
  1003. * Test Error Bounds from SGBSVXX
  1004. CALL SEBCHVXX(THRESH, PATH)
  1005. 9999 FORMAT( ' *** In SDRVGB, LA=', I5, ' is too small for N=', I5,
  1006. $ ', KU=', I5, ', KL=', I5, / ' ==> Increase LA to at least ',
  1007. $ I5 )
  1008. 9998 FORMAT( ' *** In SDRVGB, LAFB=', I5, ' is too small for N=', I5,
  1009. $ ', KU=', I5, ', KL=', I5, /
  1010. $ ' ==> Increase LAFB to at least ', I5 )
  1011. 9997 FORMAT( 1X, A, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ',
  1012. $ I1, ', test(', I1, ')=', G12.5 )
  1013. 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',
  1014. $ I5, ',...), type ', I1, ', test(', I1, ')=', G12.5 )
  1015. 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',
  1016. $ I5, ',...), EQUED=''', A1, ''', type ', I1, ', test(', I1,
  1017. $ ')=', G12.5 )
  1018. *
  1019. RETURN
  1020. *
  1021. * End of SDRVGBX
  1022. *
  1023. END