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.

sdrvpb.f 24 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690
  1. *> \brief \b SDRVPB
  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 SDRVPB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
  12. * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
  13. * RWORK, IWORK, NOUT )
  14. *
  15. * .. Scalar Arguments ..
  16. * LOGICAL TSTERR
  17. * INTEGER NMAX, NN, NOUT, NRHS
  18. * REAL THRESH
  19. * ..
  20. * .. Array Arguments ..
  21. * LOGICAL DOTYPE( * )
  22. * INTEGER IWORK( * ), NVAL( * )
  23. * REAL A( * ), AFAC( * ), ASAV( * ), B( * ),
  24. * $ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
  25. * $ X( * ), XACT( * )
  26. * ..
  27. *
  28. *
  29. *> \par Purpose:
  30. * =============
  31. *>
  32. *> \verbatim
  33. *>
  34. *> SDRVPB tests the driver routines SPBSV 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 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[in] NMAX
  82. *> \verbatim
  83. *> NMAX is INTEGER
  84. *> The maximum value permitted for N, used in dimensioning the
  85. *> work arrays.
  86. *> \endverbatim
  87. *>
  88. *> \param[out] A
  89. *> \verbatim
  90. *> A is REAL array, dimension (NMAX*NMAX)
  91. *> \endverbatim
  92. *>
  93. *> \param[out] AFAC
  94. *> \verbatim
  95. *> AFAC is REAL array, dimension (NMAX*NMAX)
  96. *> \endverbatim
  97. *>
  98. *> \param[out] ASAV
  99. *> \verbatim
  100. *> ASAV is REAL array, dimension (NMAX*NMAX)
  101. *> \endverbatim
  102. *>
  103. *> \param[out] B
  104. *> \verbatim
  105. *> B is REAL array, dimension (NMAX*NRHS)
  106. *> \endverbatim
  107. *>
  108. *> \param[out] BSAV
  109. *> \verbatim
  110. *> BSAV is REAL array, dimension (NMAX*NRHS)
  111. *> \endverbatim
  112. *>
  113. *> \param[out] X
  114. *> \verbatim
  115. *> X is REAL array, dimension (NMAX*NRHS)
  116. *> \endverbatim
  117. *>
  118. *> \param[out] XACT
  119. *> \verbatim
  120. *> XACT is REAL array, dimension (NMAX*NRHS)
  121. *> \endverbatim
  122. *>
  123. *> \param[out] S
  124. *> \verbatim
  125. *> S is REAL array, dimension (NMAX)
  126. *> \endverbatim
  127. *>
  128. *> \param[out] WORK
  129. *> \verbatim
  130. *> WORK is REAL array, dimension
  131. *> (NMAX*max(3,NRHS))
  132. *> \endverbatim
  133. *>
  134. *> \param[out] RWORK
  135. *> \verbatim
  136. *> RWORK is REAL array, dimension (NMAX+2*NRHS)
  137. *> \endverbatim
  138. *>
  139. *> \param[out] IWORK
  140. *> \verbatim
  141. *> IWORK is INTEGER array, dimension (NMAX)
  142. *> \endverbatim
  143. *>
  144. *> \param[in] NOUT
  145. *> \verbatim
  146. *> NOUT is INTEGER
  147. *> The unit number for output.
  148. *> \endverbatim
  149. *
  150. * Authors:
  151. * ========
  152. *
  153. *> \author Univ. of Tennessee
  154. *> \author Univ. of California Berkeley
  155. *> \author Univ. of Colorado Denver
  156. *> \author NAG Ltd.
  157. *
  158. *> \ingroup single_lin
  159. *
  160. * =====================================================================
  161. SUBROUTINE SDRVPB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
  162. $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
  163. $ RWORK, IWORK, NOUT )
  164. *
  165. * -- LAPACK test routine --
  166. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  167. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  168. *
  169. * .. Scalar Arguments ..
  170. LOGICAL TSTERR
  171. INTEGER NMAX, NN, NOUT, NRHS
  172. REAL THRESH
  173. * ..
  174. * .. Array Arguments ..
  175. LOGICAL DOTYPE( * )
  176. INTEGER IWORK( * ), NVAL( * )
  177. REAL A( * ), AFAC( * ), ASAV( * ), B( * ),
  178. $ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
  179. $ X( * ), XACT( * )
  180. * ..
  181. *
  182. * =====================================================================
  183. *
  184. * .. Parameters ..
  185. REAL ONE, ZERO
  186. PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
  187. INTEGER NTYPES, NTESTS
  188. PARAMETER ( NTYPES = 8, NTESTS = 6 )
  189. INTEGER NBW
  190. PARAMETER ( NBW = 4 )
  191. * ..
  192. * .. Local Scalars ..
  193. LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
  194. CHARACTER DIST, EQUED, FACT, PACKIT, TYPE, UPLO, XTYPE
  195. CHARACTER*3 PATH
  196. INTEGER I, I1, I2, IEQUED, IFACT, IKD, IMAT, IN, INFO,
  197. $ IOFF, IUPLO, IW, IZERO, K, K1, KD, KL, KOFF,
  198. $ KU, LDA, LDAB, MODE, N, NB, NBMIN, NERRS,
  199. $ NFACT, NFAIL, NIMAT, NKD, NRUN, NT
  200. REAL AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
  201. $ ROLDC, SCOND
  202. * ..
  203. * .. Local Arrays ..
  204. CHARACTER EQUEDS( 2 ), FACTS( 3 )
  205. INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW )
  206. REAL RESULT( NTESTS )
  207. * ..
  208. * .. External Functions ..
  209. LOGICAL LSAME
  210. REAL SGET06, SLANGE, SLANSB
  211. EXTERNAL LSAME, SGET06, SLANGE, SLANSB
  212. * ..
  213. * .. External Subroutines ..
  214. EXTERNAL ALADHD, ALAERH, ALASVM, SCOPY, SERRVX, SGET04,
  215. $ SLACPY, SLAQSB, SLARHS, SLASET, SLATB4, SLATMS,
  216. $ SPBEQU, SPBSV, SPBSVX, SPBT01, SPBT02, SPBT05,
  217. $ SPBTRF, SPBTRS, SSWAP, XLAENV
  218. * ..
  219. * .. Intrinsic Functions ..
  220. INTRINSIC MAX, MIN
  221. * ..
  222. * .. Scalars in Common ..
  223. LOGICAL LERR, OK
  224. CHARACTER*32 SRNAMT
  225. INTEGER INFOT, NUNIT
  226. * ..
  227. * .. Common blocks ..
  228. COMMON / INFOC / INFOT, NUNIT, OK, LERR
  229. COMMON / SRNAMC / SRNAMT
  230. * ..
  231. * .. Data statements ..
  232. DATA ISEEDY / 1988, 1989, 1990, 1991 /
  233. DATA FACTS / 'F', 'N', 'E' /
  234. DATA EQUEDS / 'N', 'Y' /
  235. * ..
  236. * .. Executable Statements ..
  237. *
  238. * Initialize constants and the random number seed.
  239. *
  240. PATH( 1: 1 ) = 'Single precision'
  241. PATH( 2: 3 ) = 'PB'
  242. NRUN = 0
  243. NFAIL = 0
  244. NERRS = 0
  245. DO 10 I = 1, 4
  246. ISEED( I ) = ISEEDY( I )
  247. 10 CONTINUE
  248. *
  249. * Test the error exits
  250. *
  251. IF( TSTERR )
  252. $ CALL SERRVX( PATH, NOUT )
  253. INFOT = 0
  254. KDVAL( 1 ) = 0
  255. *
  256. * Set the block size and minimum block size for testing.
  257. *
  258. NB = 1
  259. NBMIN = 2
  260. CALL XLAENV( 1, NB )
  261. CALL XLAENV( 2, NBMIN )
  262. *
  263. * Do for each value of N in NVAL
  264. *
  265. DO 110 IN = 1, NN
  266. N = NVAL( IN )
  267. LDA = MAX( N, 1 )
  268. XTYPE = 'N'
  269. *
  270. * Set limits on the number of loop iterations.
  271. *
  272. NKD = MAX( 1, MIN( N, 4 ) )
  273. NIMAT = NTYPES
  274. IF( N.EQ.0 )
  275. $ NIMAT = 1
  276. *
  277. KDVAL( 2 ) = N + ( N+1 ) / 4
  278. KDVAL( 3 ) = ( 3*N-1 ) / 4
  279. KDVAL( 4 ) = ( N+1 ) / 4
  280. *
  281. DO 100 IKD = 1, NKD
  282. *
  283. * Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order
  284. * makes it easier to skip redundant values for small values
  285. * of N.
  286. *
  287. KD = KDVAL( IKD )
  288. LDAB = KD + 1
  289. *
  290. * Do first for UPLO = 'U', then for UPLO = 'L'
  291. *
  292. DO 90 IUPLO = 1, 2
  293. KOFF = 1
  294. IF( IUPLO.EQ.1 ) THEN
  295. UPLO = 'U'
  296. PACKIT = 'Q'
  297. KOFF = MAX( 1, KD+2-N )
  298. ELSE
  299. UPLO = 'L'
  300. PACKIT = 'B'
  301. END IF
  302. *
  303. DO 80 IMAT = 1, NIMAT
  304. *
  305. * Do the tests only if DOTYPE( IMAT ) is true.
  306. *
  307. IF( .NOT.DOTYPE( IMAT ) )
  308. $ GO TO 80
  309. *
  310. * Skip types 2, 3, or 4 if the matrix size is too small.
  311. *
  312. ZEROT = IMAT.GE.2 .AND. IMAT.LE.4
  313. IF( ZEROT .AND. N.LT.IMAT-1 )
  314. $ GO TO 80
  315. *
  316. IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 1 ) ) THEN
  317. *
  318. * Set up parameters with SLATB4 and generate a test
  319. * matrix with SLATMS.
  320. *
  321. CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM,
  322. $ MODE, CNDNUM, DIST )
  323. *
  324. SRNAMT = 'SLATMS'
  325. CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
  326. $ CNDNUM, ANORM, KD, KD, PACKIT,
  327. $ A( KOFF ), LDAB, WORK, INFO )
  328. *
  329. * Check error code from SLATMS.
  330. *
  331. IF( INFO.NE.0 ) THEN
  332. CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N,
  333. $ N, -1, -1, -1, IMAT, NFAIL, NERRS,
  334. $ NOUT )
  335. GO TO 80
  336. END IF
  337. ELSE IF( IZERO.GT.0 ) THEN
  338. *
  339. * Use the same matrix for types 3 and 4 as for type
  340. * 2 by copying back the zeroed out column,
  341. *
  342. IW = 2*LDA + 1
  343. IF( IUPLO.EQ.1 ) THEN
  344. IOFF = ( IZERO-1 )*LDAB + KD + 1
  345. CALL SCOPY( IZERO-I1, WORK( IW ), 1,
  346. $ A( IOFF-IZERO+I1 ), 1 )
  347. IW = IW + IZERO - I1
  348. CALL SCOPY( I2-IZERO+1, WORK( IW ), 1,
  349. $ A( IOFF ), MAX( LDAB-1, 1 ) )
  350. ELSE
  351. IOFF = ( I1-1 )*LDAB + 1
  352. CALL SCOPY( IZERO-I1, WORK( IW ), 1,
  353. $ A( IOFF+IZERO-I1 ),
  354. $ MAX( LDAB-1, 1 ) )
  355. IOFF = ( IZERO-1 )*LDAB + 1
  356. IW = IW + IZERO - I1
  357. CALL SCOPY( I2-IZERO+1, WORK( IW ), 1,
  358. $ A( IOFF ), 1 )
  359. END IF
  360. END IF
  361. *
  362. * For types 2-4, zero one row and column of the matrix
  363. * to test that INFO is returned correctly.
  364. *
  365. IZERO = 0
  366. IF( ZEROT ) THEN
  367. IF( IMAT.EQ.2 ) THEN
  368. IZERO = 1
  369. ELSE IF( IMAT.EQ.3 ) THEN
  370. IZERO = N
  371. ELSE
  372. IZERO = N / 2 + 1
  373. END IF
  374. *
  375. * Save the zeroed out row and column in WORK(*,3)
  376. *
  377. IW = 2*LDA
  378. DO 20 I = 1, MIN( 2*KD+1, N )
  379. WORK( IW+I ) = ZERO
  380. 20 CONTINUE
  381. IW = IW + 1
  382. I1 = MAX( IZERO-KD, 1 )
  383. I2 = MIN( IZERO+KD, N )
  384. *
  385. IF( IUPLO.EQ.1 ) THEN
  386. IOFF = ( IZERO-1 )*LDAB + KD + 1
  387. CALL SSWAP( IZERO-I1, A( IOFF-IZERO+I1 ), 1,
  388. $ WORK( IW ), 1 )
  389. IW = IW + IZERO - I1
  390. CALL SSWAP( I2-IZERO+1, A( IOFF ),
  391. $ MAX( LDAB-1, 1 ), WORK( IW ), 1 )
  392. ELSE
  393. IOFF = ( I1-1 )*LDAB + 1
  394. CALL SSWAP( IZERO-I1, A( IOFF+IZERO-I1 ),
  395. $ MAX( LDAB-1, 1 ), WORK( IW ), 1 )
  396. IOFF = ( IZERO-1 )*LDAB + 1
  397. IW = IW + IZERO - I1
  398. CALL SSWAP( I2-IZERO+1, A( IOFF ), 1,
  399. $ WORK( IW ), 1 )
  400. END IF
  401. END IF
  402. *
  403. * Save a copy of the matrix A in ASAV.
  404. *
  405. CALL SLACPY( 'Full', KD+1, N, A, LDAB, ASAV, LDAB )
  406. *
  407. DO 70 IEQUED = 1, 2
  408. EQUED = EQUEDS( IEQUED )
  409. IF( IEQUED.EQ.1 ) THEN
  410. NFACT = 3
  411. ELSE
  412. NFACT = 1
  413. END IF
  414. *
  415. DO 60 IFACT = 1, NFACT
  416. FACT = FACTS( IFACT )
  417. PREFAC = LSAME( FACT, 'F' )
  418. NOFACT = LSAME( FACT, 'N' )
  419. EQUIL = LSAME( FACT, 'E' )
  420. *
  421. IF( ZEROT ) THEN
  422. IF( PREFAC )
  423. $ GO TO 60
  424. RCONDC = ZERO
  425. *
  426. ELSE IF( .NOT.LSAME( FACT, 'N' ) ) THEN
  427. *
  428. * Compute the condition number for comparison
  429. * with the value returned by SPBSVX (FACT =
  430. * 'N' reuses the condition number from the
  431. * previous iteration with FACT = 'F').
  432. *
  433. CALL SLACPY( 'Full', KD+1, N, ASAV, LDAB,
  434. $ AFAC, LDAB )
  435. IF( EQUIL .OR. IEQUED.GT.1 ) THEN
  436. *
  437. * Compute row and column scale factors to
  438. * equilibrate the matrix A.
  439. *
  440. CALL SPBEQU( UPLO, N, KD, AFAC, LDAB, S,
  441. $ SCOND, AMAX, INFO )
  442. IF( INFO.EQ.0 .AND. N.GT.0 ) THEN
  443. IF( IEQUED.GT.1 )
  444. $ SCOND = ZERO
  445. *
  446. * Equilibrate the matrix.
  447. *
  448. CALL SLAQSB( UPLO, N, KD, AFAC, LDAB,
  449. $ S, SCOND, AMAX, EQUED )
  450. END IF
  451. END IF
  452. *
  453. * Save the condition number of the
  454. * non-equilibrated system for use in SGET04.
  455. *
  456. IF( EQUIL )
  457. $ ROLDC = RCONDC
  458. *
  459. * Compute the 1-norm of A.
  460. *
  461. ANORM = SLANSB( '1', UPLO, N, KD, AFAC, LDAB,
  462. $ RWORK )
  463. *
  464. * Factor the matrix A.
  465. *
  466. CALL SPBTRF( UPLO, N, KD, AFAC, LDAB, INFO )
  467. *
  468. * Form the inverse of A.
  469. *
  470. CALL SLASET( 'Full', N, N, ZERO, ONE, A,
  471. $ LDA )
  472. SRNAMT = 'SPBTRS'
  473. CALL SPBTRS( UPLO, N, KD, N, AFAC, LDAB, A,
  474. $ LDA, INFO )
  475. *
  476. * Compute the 1-norm condition number of A.
  477. *
  478. AINVNM = SLANGE( '1', N, N, A, LDA, RWORK )
  479. IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
  480. RCONDC = ONE
  481. ELSE
  482. RCONDC = ( ONE / ANORM ) / AINVNM
  483. END IF
  484. END IF
  485. *
  486. * Restore the matrix A.
  487. *
  488. CALL SLACPY( 'Full', KD+1, N, ASAV, LDAB, A,
  489. $ LDAB )
  490. *
  491. * Form an exact solution and set the right hand
  492. * side.
  493. *
  494. SRNAMT = 'SLARHS'
  495. CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KD,
  496. $ KD, NRHS, A, LDAB, XACT, LDA, B,
  497. $ LDA, ISEED, INFO )
  498. XTYPE = 'C'
  499. CALL SLACPY( 'Full', N, NRHS, B, LDA, BSAV,
  500. $ LDA )
  501. *
  502. IF( NOFACT ) THEN
  503. *
  504. * --- Test SPBSV ---
  505. *
  506. * Compute the L*L' or U'*U factorization of the
  507. * matrix and solve the system.
  508. *
  509. CALL SLACPY( 'Full', KD+1, N, A, LDAB, AFAC,
  510. $ LDAB )
  511. CALL SLACPY( 'Full', N, NRHS, B, LDA, X,
  512. $ LDA )
  513. *
  514. SRNAMT = 'SPBSV '
  515. CALL SPBSV( UPLO, N, KD, NRHS, AFAC, LDAB, X,
  516. $ LDA, INFO )
  517. *
  518. * Check error code from SPBSV .
  519. *
  520. IF( INFO.NE.IZERO ) THEN
  521. CALL ALAERH( PATH, 'SPBSV ', INFO, IZERO,
  522. $ UPLO, N, N, KD, KD, NRHS,
  523. $ IMAT, NFAIL, NERRS, NOUT )
  524. GO TO 40
  525. ELSE IF( INFO.NE.0 ) THEN
  526. GO TO 40
  527. END IF
  528. *
  529. * Reconstruct matrix from factors and compute
  530. * residual.
  531. *
  532. CALL SPBT01( UPLO, N, KD, A, LDAB, AFAC,
  533. $ LDAB, RWORK, RESULT( 1 ) )
  534. *
  535. * Compute residual of the computed solution.
  536. *
  537. CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK,
  538. $ LDA )
  539. CALL SPBT02( UPLO, N, KD, NRHS, A, LDAB, X,
  540. $ LDA, WORK, LDA, RWORK,
  541. $ RESULT( 2 ) )
  542. *
  543. * Check solution from generated exact solution.
  544. *
  545. CALL SGET04( N, NRHS, X, LDA, XACT, LDA,
  546. $ RCONDC, RESULT( 3 ) )
  547. NT = 3
  548. *
  549. * Print information about the tests that did
  550. * not pass the threshold.
  551. *
  552. DO 30 K = 1, NT
  553. IF( RESULT( K ).GE.THRESH ) THEN
  554. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  555. $ CALL ALADHD( NOUT, PATH )
  556. WRITE( NOUT, FMT = 9999 )'SPBSV ',
  557. $ UPLO, N, KD, IMAT, K, RESULT( K )
  558. NFAIL = NFAIL + 1
  559. END IF
  560. 30 CONTINUE
  561. NRUN = NRUN + NT
  562. 40 CONTINUE
  563. END IF
  564. *
  565. * --- Test SPBSVX ---
  566. *
  567. IF( .NOT.PREFAC )
  568. $ CALL SLASET( 'Full', KD+1, N, ZERO, ZERO,
  569. $ AFAC, LDAB )
  570. CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X,
  571. $ LDA )
  572. IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
  573. *
  574. * Equilibrate the matrix if FACT='F' and
  575. * EQUED='Y'
  576. *
  577. CALL SLAQSB( UPLO, N, KD, A, LDAB, S, SCOND,
  578. $ AMAX, EQUED )
  579. END IF
  580. *
  581. * Solve the system and compute the condition
  582. * number and error bounds using SPBSVX.
  583. *
  584. SRNAMT = 'SPBSVX'
  585. CALL SPBSVX( FACT, UPLO, N, KD, NRHS, A, LDAB,
  586. $ AFAC, LDAB, EQUED, S, B, LDA, X,
  587. $ LDA, RCOND, RWORK, RWORK( NRHS+1 ),
  588. $ WORK, IWORK, INFO )
  589. *
  590. * Check the error code from SPBSVX.
  591. *
  592. IF( INFO.NE.IZERO ) THEN
  593. CALL ALAERH( PATH, 'SPBSVX', INFO, IZERO,
  594. $ FACT // UPLO, N, N, KD, KD,
  595. $ NRHS, IMAT, NFAIL, NERRS, NOUT )
  596. GO TO 60
  597. END IF
  598. *
  599. IF( INFO.EQ.0 ) THEN
  600. IF( .NOT.PREFAC ) THEN
  601. *
  602. * Reconstruct matrix from factors and
  603. * compute residual.
  604. *
  605. CALL SPBT01( UPLO, N, KD, A, LDAB, AFAC,
  606. $ LDAB, RWORK( 2*NRHS+1 ),
  607. $ RESULT( 1 ) )
  608. K1 = 1
  609. ELSE
  610. K1 = 2
  611. END IF
  612. *
  613. * Compute residual of the computed solution.
  614. *
  615. CALL SLACPY( 'Full', N, NRHS, BSAV, LDA,
  616. $ WORK, LDA )
  617. CALL SPBT02( UPLO, N, KD, NRHS, ASAV, LDAB,
  618. $ X, LDA, WORK, LDA,
  619. $ RWORK( 2*NRHS+1 ), RESULT( 2 ) )
  620. *
  621. * Check solution from generated exact solution.
  622. *
  623. IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED,
  624. $ 'N' ) ) ) THEN
  625. CALL SGET04( N, NRHS, X, LDA, XACT, LDA,
  626. $ RCONDC, RESULT( 3 ) )
  627. ELSE
  628. CALL SGET04( N, NRHS, X, LDA, XACT, LDA,
  629. $ ROLDC, RESULT( 3 ) )
  630. END IF
  631. *
  632. * Check the error bounds from iterative
  633. * refinement.
  634. *
  635. CALL SPBT05( UPLO, N, KD, NRHS, ASAV, LDAB,
  636. $ B, LDA, X, LDA, XACT, LDA,
  637. $ RWORK, RWORK( NRHS+1 ),
  638. $ RESULT( 4 ) )
  639. ELSE
  640. K1 = 6
  641. END IF
  642. *
  643. * Compare RCOND from SPBSVX with the computed
  644. * value in RCONDC.
  645. *
  646. RESULT( 6 ) = SGET06( RCOND, RCONDC )
  647. *
  648. * Print information about the tests that did not
  649. * pass the threshold.
  650. *
  651. DO 50 K = K1, 6
  652. IF( RESULT( K ).GE.THRESH ) THEN
  653. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  654. $ CALL ALADHD( NOUT, PATH )
  655. IF( PREFAC ) THEN
  656. WRITE( NOUT, FMT = 9997 )'SPBSVX',
  657. $ FACT, UPLO, N, KD, EQUED, IMAT, K,
  658. $ RESULT( K )
  659. ELSE
  660. WRITE( NOUT, FMT = 9998 )'SPBSVX',
  661. $ FACT, UPLO, N, KD, IMAT, K,
  662. $ RESULT( K )
  663. END IF
  664. NFAIL = NFAIL + 1
  665. END IF
  666. 50 CONTINUE
  667. NRUN = NRUN + 7 - K1
  668. 60 CONTINUE
  669. 70 CONTINUE
  670. 80 CONTINUE
  671. 90 CONTINUE
  672. 100 CONTINUE
  673. 110 CONTINUE
  674. *
  675. * Print a summary of the results.
  676. *
  677. CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
  678. *
  679. 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', KD =', I5,
  680. $ ', type ', I1, ', test(', I1, ')=', G12.5 )
  681. 9998 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ', I5, ', ', I5,
  682. $ ', ... ), type ', I1, ', test(', I1, ')=', G12.5 )
  683. 9997 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ', I5, ', ', I5,
  684. $ ', ... ), EQUED=''', A1, ''', type ', I1, ', test(', I1,
  685. $ ')=', G12.5 )
  686. RETURN
  687. *
  688. * End of SDRVPB
  689. *
  690. END