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.

ddrvgb.f 32 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840
  1. *> \brief \b DDRVGB
  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 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 DOUBLE PRECISION
  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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LA)
  108. *> \endverbatim
  109. *>
  110. *> \param[out] B
  111. *> \verbatim
  112. *> B is DOUBLE PRECISION array, dimension (NMAX*NRHS)
  113. *> \endverbatim
  114. *>
  115. *> \param[out] BSAV
  116. *> \verbatim
  117. *> BSAV is DOUBLE PRECISION array, dimension (NMAX*NRHS)
  118. *> \endverbatim
  119. *>
  120. *> \param[out] X
  121. *> \verbatim
  122. *> X is DOUBLE PRECISION array, dimension (NMAX*NRHS)
  123. *> \endverbatim
  124. *>
  125. *> \param[out] XACT
  126. *> \verbatim
  127. *> XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS)
  128. *> \endverbatim
  129. *>
  130. *> \param[out] S
  131. *> \verbatim
  132. *> S is DOUBLE PRECISION array, dimension (2*NMAX)
  133. *> \endverbatim
  134. *>
  135. *> \param[out] WORK
  136. *> \verbatim
  137. *> WORK is DOUBLE PRECISION array, dimension
  138. *> (NMAX*max(3,NRHS,NMAX))
  139. *> \endverbatim
  140. *>
  141. *> \param[out] RWORK
  142. *> \verbatim
  143. *> RWORK is DOUBLE PRECISION 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 double_lin
  167. *
  168. * =====================================================================
  169. SUBROUTINE DDRVGB( 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. DOUBLE PRECISION THRESH
  181. * ..
  182. * .. Array Arguments ..
  183. LOGICAL DOTYPE( * )
  184. INTEGER IWORK( * ), NVAL( * )
  185. DOUBLE PRECISION A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
  186. $ RWORK( * ), S( * ), WORK( * ), X( * ),
  187. $ XACT( * )
  188. * ..
  189. *
  190. * =====================================================================
  191. *
  192. * .. Parameters ..
  193. DOUBLE PRECISION ONE, ZERO
  194. PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+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. DOUBLE PRECISION 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. DOUBLE PRECISION RESULT( NTESTS )
  218. * ..
  219. * .. External Functions ..
  220. LOGICAL LSAME
  221. DOUBLE PRECISION DGET06, DLAMCH, DLANGB, DLANGE, DLANTB
  222. EXTERNAL LSAME, DGET06, DLAMCH, DLANGB, DLANGE, DLANTB
  223. * ..
  224. * .. External Subroutines ..
  225. EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGBEQU, DGBSV,
  226. $ DGBSVX, DGBT01, DGBT02, DGBT05, DGBTRF, DGBTRS,
  227. $ DGET04, DLACPY, DLAQGB, DLARHS, DLASET, DLATB4,
  228. $ DLATMS, 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 ) = 'Double 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 DERRVX( 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. IF( N.EQ.0 )
  285. $ NKL = 1
  286. NKU = NKL
  287. NIMAT = NTYPES
  288. IF( N.LE.0 )
  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. IF( IKL.EQ.1 ) THEN
  297. KL = 0
  298. ELSE IF( IKL.EQ.2 ) THEN
  299. KL = MAX( N-1, 0 )
  300. ELSE IF( IKL.EQ.3 ) THEN
  301. KL = ( 3*N-1 ) / 4
  302. ELSE IF( IKL.EQ.4 ) 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. IF( IKU.EQ.1 ) THEN
  312. KU = 0
  313. ELSE IF( IKU.EQ.2 ) THEN
  314. KU = MAX( N-1, 0 )
  315. ELSE IF( IKU.EQ.3 ) THEN
  316. KU = ( 3*N-1 ) / 4
  317. ELSE IF( IKU.EQ.4 ) 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. IF( LDA*N.GT.LA .OR. LDAFB*N.GT.LAFB ) THEN
  327. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  328. $ CALL ALADHD( NOUT, PATH )
  329. IF( LDA*N.GT.LA ) THEN
  330. WRITE( NOUT, FMT = 9999 )LA, N, KL, KU,
  331. $ N*( KL+KU+1 )
  332. NERRS = NERRS + 1
  333. END IF
  334. IF( LDAFB*N.GT.LAFB ) 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. IF( .NOT.DOTYPE( IMAT ) )
  347. $ GO TO 120
  348. *
  349. * Skip types 2, 3, or 4 if the matrix is too small.
  350. *
  351. ZEROT = IMAT.GE.2 .AND. IMAT.LE.4
  352. IF( ZEROT .AND. N.LT.IMAT-1 )
  353. $ GO TO 120
  354. *
  355. * Set up parameters with DLATB4 and generate a
  356. * test matrix with DLATMS.
  357. *
  358. CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM,
  359. $ MODE, CNDNUM, DIST )
  360. RCONDC = ONE / CNDNUM
  361. *
  362. SRNAMT = 'DLATMS'
  363. CALL DLATMS( 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 DLATMS.
  368. *
  369. IF( INFO.NE.0 ) THEN
  370. CALL ALAERH( PATH, 'DLATMS', 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. IF( IMAT.EQ.2 ) THEN
  381. IZERO = 1
  382. ELSE IF( IMAT.EQ.3 ) THEN
  383. IZERO = N
  384. ELSE
  385. IZERO = N / 2 + 1
  386. END IF
  387. IOFF = ( IZERO-1 )*LDA
  388. IF( IMAT.LT.4 ) 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 DLACPY( 'Full', KL+KU+1, N, A, LDA, ASAV, LDA )
  408. *
  409. DO 110 IEQUED = 1, 4
  410. EQUED = EQUEDS( IEQUED )
  411. IF( IEQUED.EQ.1 ) 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. ELSE IF( .NOT.NOFACT ) THEN
  430. *
  431. * Compute the condition number for comparison
  432. * with the value returned by DGESVX (FACT =
  433. * 'N' reuses the condition number from the
  434. * previous iteration with FACT = 'F').
  435. *
  436. CALL DLACPY( 'Full', KL+KU+1, N, ASAV, LDA,
  437. $ AFB( KL+1 ), LDAFB )
  438. IF( EQUIL .OR. IEQUED.GT.1 ) THEN
  439. *
  440. * Compute row and column scale factors to
  441. * equilibrate the matrix A.
  442. *
  443. CALL DGBEQU( N, N, KL, KU, AFB( KL+1 ),
  444. $ LDAFB, S, S( N+1 ), ROWCND,
  445. $ COLCND, AMAX, INFO )
  446. IF( INFO.EQ.0 .AND. N.GT.0 ) 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 DLAQGB( 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 DGET04.
  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 = DLANGB( '1', N, KL, KU, AFB( KL+1 ),
  478. $ LDAFB, RWORK )
  479. ANORMI = DLANGB( 'I', N, KL, KU, AFB( KL+1 ),
  480. $ LDAFB, RWORK )
  481. *
  482. * Factor the matrix A.
  483. *
  484. CALL DGBTRF( N, N, KL, KU, AFB, LDAFB, IWORK,
  485. $ INFO )
  486. *
  487. * Form the inverse of A.
  488. *
  489. CALL DLASET( 'Full', N, N, ZERO, ONE, WORK,
  490. $ LDB )
  491. SRNAMT = 'DGBTRS'
  492. CALL DGBTRS( '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 = DLANGE( '1', N, N, WORK, LDB,
  499. $ RWORK )
  500. IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) 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 = DLANGE( 'I', N, N, WORK, LDB,
  510. $ RWORK )
  511. IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) 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. IF( ITRAN.EQ.1 ) THEN
  524. RCONDC = RCONDO
  525. ELSE
  526. RCONDC = RCONDI
  527. END IF
  528. *
  529. * Restore the matrix A.
  530. *
  531. CALL DLACPY( '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 = 'DLARHS'
  538. CALL DLARHS( PATH, XTYPE, 'Full', TRANS, N,
  539. $ N, KL, KU, NRHS, A, LDA, XACT,
  540. $ LDB, B, LDB, ISEED, INFO )
  541. XTYPE = 'C'
  542. CALL DLACPY( 'Full', N, NRHS, B, LDB, BSAV,
  543. $ LDB )
  544. *
  545. IF( NOFACT .AND. ITRAN.EQ.1 ) THEN
  546. *
  547. * --- Test DGBSV ---
  548. *
  549. * Compute the LU factorization of the matrix
  550. * and solve the system.
  551. *
  552. CALL DLACPY( 'Full', KL+KU+1, N, A, LDA,
  553. $ AFB( KL+1 ), LDAFB )
  554. CALL DLACPY( 'Full', N, NRHS, B, LDB, X,
  555. $ LDB )
  556. *
  557. SRNAMT = 'DGBSV '
  558. CALL DGBSV( N, KL, KU, NRHS, AFB, LDAFB,
  559. $ IWORK, X, LDB, INFO )
  560. *
  561. * Check error code from DGBSV .
  562. *
  563. IF( INFO.NE.IZERO )
  564. $ CALL ALAERH( PATH, 'DGBSV ', 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 DGBT01( N, N, KL, KU, A, LDA, AFB,
  573. $ LDAFB, IWORK, WORK,
  574. $ RESULT( 1 ) )
  575. NT = 1
  576. IF( IZERO.EQ.0 ) THEN
  577. *
  578. * Compute residual of the computed
  579. * solution.
  580. *
  581. CALL DLACPY( 'Full', N, NRHS, B, LDB,
  582. $ WORK, LDB )
  583. CALL DGBT02( '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 DGET04( 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. IF( RESULT( K ).GE.THRESH ) THEN
  601. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  602. $ CALL ALADHD( NOUT, PATH )
  603. WRITE( NOUT, FMT = 9997 )'DGBSV ',
  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 DGBSVX ---
  612. *
  613. IF( .NOT.PREFAC )
  614. $ CALL DLASET( 'Full', 2*KL+KU+1, N, ZERO,
  615. $ ZERO, AFB, LDAFB )
  616. CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X,
  617. $ LDB )
  618. IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
  619. *
  620. * Equilibrate the matrix if FACT = 'F' and
  621. * EQUED = 'R', 'C', or 'B'.
  622. *
  623. CALL DLAQGB( 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 DGBSVX.
  630. *
  631. SRNAMT = 'DGBSVX'
  632. CALL DGBSVX( 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 DGBSVX.
  639. *
  640. IF( INFO.NE.IZERO )
  641. $ CALL ALAERH( PATH, 'DGBSVX', INFO, IZERO,
  642. $ FACT // TRANS, N, N, KL, KU,
  643. $ NRHS, IMAT, NFAIL, NERRS,
  644. $ NOUT )
  645. *
  646. * Compare WORK(1) from DGBSVX with the computed
  647. * reciprocal pivot growth factor RPVGRW
  648. *
  649. IF( INFO.NE.0 .AND. INFO.LE.N) 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 = DLANTB( 'M', 'U', 'N', INFO,
  659. $ MIN( INFO-1, KL+KU ),
  660. $ AFB( MAX( 1, KL+KU+2-INFO ) ),
  661. $ LDAFB, WORK )
  662. IF( RPVGRW.EQ.ZERO ) THEN
  663. RPVGRW = ONE
  664. ELSE
  665. RPVGRW = ANRMPV / RPVGRW
  666. END IF
  667. ELSE
  668. RPVGRW = DLANTB( 'M', 'U', 'N', N, KL+KU,
  669. $ AFB, LDAFB, WORK )
  670. IF( RPVGRW.EQ.ZERO ) THEN
  671. RPVGRW = ONE
  672. ELSE
  673. RPVGRW = DLANGB( '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. $ DLAMCH( 'E' )
  680. *
  681. IF( .NOT.PREFAC ) THEN
  682. *
  683. * Reconstruct matrix from factors and
  684. * compute residual.
  685. *
  686. CALL DGBT01( 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. IF( INFO.EQ.0 ) THEN
  695. TRFCON = .FALSE.
  696. *
  697. * Compute residual of the computed solution.
  698. *
  699. CALL DLACPY( 'Full', N, NRHS, BSAV, LDB,
  700. $ WORK, LDB )
  701. CALL DGBT02( 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. IF( NOFACT .OR. ( PREFAC .AND.
  710. $ LSAME( EQUED, 'N' ) ) ) THEN
  711. CALL DGET04( N, NRHS, X, LDB, XACT,
  712. $ LDB, RCONDC, RESULT( 3 ) )
  713. ELSE
  714. IF( ITRAN.EQ.1 ) THEN
  715. ROLDC = ROLDO
  716. ELSE
  717. ROLDC = ROLDI
  718. END IF
  719. CALL DGET04( 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 DGBT05( 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 DGBSVX with the computed
  735. * value in RCONDC.
  736. *
  737. RESULT( 6 ) = DGET06( RCOND, RCONDC )
  738. *
  739. * Print information about the tests that did
  740. * not pass the threshold.
  741. *
  742. IF( .NOT.TRFCON ) THEN
  743. DO 80 K = K1, NTESTS
  744. IF( RESULT( K ).GE.THRESH ) THEN
  745. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  746. $ CALL ALADHD( NOUT, PATH )
  747. IF( PREFAC ) THEN
  748. WRITE( NOUT, FMT = 9995 )
  749. $ 'DGBSVX', FACT, TRANS, N, KL,
  750. $ KU, EQUED, IMAT, K,
  751. $ RESULT( K )
  752. ELSE
  753. WRITE( NOUT, FMT = 9996 )
  754. $ 'DGBSVX', 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. IF( RESULT( 1 ).GE.THRESH .AND. .NOT.
  763. $ PREFAC ) THEN
  764. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  765. $ CALL ALADHD( NOUT, PATH )
  766. IF( PREFAC ) THEN
  767. WRITE( NOUT, FMT = 9995 )'DGBSVX',
  768. $ FACT, TRANS, N, KL, KU, EQUED,
  769. $ IMAT, 1, RESULT( 1 )
  770. ELSE
  771. WRITE( NOUT, FMT = 9996 )'DGBSVX',
  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. IF( RESULT( 6 ).GE.THRESH ) THEN
  779. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  780. $ CALL ALADHD( NOUT, PATH )
  781. IF( PREFAC ) THEN
  782. WRITE( NOUT, FMT = 9995 )'DGBSVX',
  783. $ FACT, TRANS, N, KL, KU, EQUED,
  784. $ IMAT, 6, RESULT( 6 )
  785. ELSE
  786. WRITE( NOUT, FMT = 9996 )'DGBSVX',
  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. IF( RESULT( 7 ).GE.THRESH ) THEN
  794. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  795. $ CALL ALADHD( NOUT, PATH )
  796. IF( PREFAC ) THEN
  797. WRITE( NOUT, FMT = 9995 )'DGBSVX',
  798. $ FACT, TRANS, N, KL, KU, EQUED,
  799. $ IMAT, 7, RESULT( 7 )
  800. ELSE
  801. WRITE( NOUT, FMT = 9996 )'DGBSVX',
  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 DDRVGB, LA=', I5, ' is too small for N=', I5,
  823. $ ', KU=', I5, ', KL=', I5, / ' ==> Increase LA to at least ',
  824. $ I5 )
  825. 9998 FORMAT( ' *** In DDRVGB, 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 DDRVGB
  839. *
  840. END