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.

slattb.f 22 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682
  1. *> \brief \b SLATTB
  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 SLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB,
  12. * LDAB, B, WORK, INFO )
  13. *
  14. * .. Scalar Arguments ..
  15. * CHARACTER DIAG, TRANS, UPLO
  16. * INTEGER IMAT, INFO, KD, LDAB, N
  17. * ..
  18. * .. Array Arguments ..
  19. * INTEGER ISEED( 4 )
  20. * REAL AB( LDAB, * ), B( * ), WORK( * )
  21. * ..
  22. *
  23. *
  24. *> \par Purpose:
  25. * =============
  26. *>
  27. *> \verbatim
  28. *>
  29. *> SLATTB generates a triangular test matrix in 2-dimensional storage.
  30. *> IMAT and UPLO uniquely specify the properties of the test matrix,
  31. *> which is returned in the array A.
  32. *> \endverbatim
  33. *
  34. * Arguments:
  35. * ==========
  36. *
  37. *> \param[in] IMAT
  38. *> \verbatim
  39. *> IMAT is INTEGER
  40. *> An integer key describing which matrix to generate for this
  41. *> path.
  42. *> \endverbatim
  43. *>
  44. *> \param[in] UPLO
  45. *> \verbatim
  46. *> UPLO is CHARACTER*1
  47. *> Specifies whether the matrix A will be upper or lower
  48. *> triangular.
  49. *> = 'U': Upper triangular
  50. *> = 'L': Lower triangular
  51. *> \endverbatim
  52. *>
  53. *> \param[in] TRANS
  54. *> \verbatim
  55. *> TRANS is CHARACTER*1
  56. *> Specifies whether the matrix or its transpose will be used.
  57. *> = 'N': No transpose
  58. *> = 'T': Transpose
  59. *> = 'C': Conjugate transpose (= transpose)
  60. *> \endverbatim
  61. *>
  62. *> \param[out] DIAG
  63. *> \verbatim
  64. *> DIAG is CHARACTER*1
  65. *> Specifies whether or not the matrix A is unit triangular.
  66. *> = 'N': Non-unit triangular
  67. *> = 'U': Unit triangular
  68. *> \endverbatim
  69. *>
  70. *> \param[in,out] ISEED
  71. *> \verbatim
  72. *> ISEED is INTEGER array, dimension (4)
  73. *> The seed vector for the random number generator (used in
  74. *> SLATMS). Modified on exit.
  75. *> \endverbatim
  76. *>
  77. *> \param[in] N
  78. *> \verbatim
  79. *> N is INTEGER
  80. *> The order of the matrix to be generated.
  81. *> \endverbatim
  82. *>
  83. *> \param[in] KD
  84. *> \verbatim
  85. *> KD is INTEGER
  86. *> The number of superdiagonals or subdiagonals of the banded
  87. *> triangular matrix A. KD >= 0.
  88. *> \endverbatim
  89. *>
  90. *> \param[out] AB
  91. *> \verbatim
  92. *> AB is REAL array, dimension (LDAB,N)
  93. *> The upper or lower triangular banded matrix A, stored in the
  94. *> first KD+1 rows of AB. Let j be a column of A, 1<=j<=n.
  95. *> If UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j.
  96. *> If UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
  97. *> \endverbatim
  98. *>
  99. *> \param[in] LDAB
  100. *> \verbatim
  101. *> LDAB is INTEGER
  102. *> The leading dimension of the array AB. LDAB >= KD+1.
  103. *> \endverbatim
  104. *>
  105. *> \param[out] B
  106. *> \verbatim
  107. *> B is REAL array, dimension (N)
  108. *> \endverbatim
  109. *>
  110. *> \param[out] WORK
  111. *> \verbatim
  112. *> WORK is REAL array, dimension (2*N)
  113. *> \endverbatim
  114. *>
  115. *> \param[out] INFO
  116. *> \verbatim
  117. *> INFO is INTEGER
  118. *> = 0: successful exit
  119. *> < 0: if INFO = -k, the k-th argument had an illegal value
  120. *> \endverbatim
  121. *
  122. * Authors:
  123. * ========
  124. *
  125. *> \author Univ. of Tennessee
  126. *> \author Univ. of California Berkeley
  127. *> \author Univ. of Colorado Denver
  128. *> \author NAG Ltd.
  129. *
  130. *> \ingroup single_lin
  131. *
  132. * =====================================================================
  133. SUBROUTINE SLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB,
  134. $ LDAB, B, WORK, INFO )
  135. *
  136. * -- LAPACK test routine --
  137. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  138. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  139. *
  140. * .. Scalar Arguments ..
  141. CHARACTER DIAG, TRANS, UPLO
  142. INTEGER IMAT, INFO, KD, LDAB, N
  143. * ..
  144. * .. Array Arguments ..
  145. INTEGER ISEED( 4 )
  146. REAL AB( LDAB, * ), B( * ), WORK( * )
  147. * ..
  148. *
  149. * =====================================================================
  150. *
  151. * .. Parameters ..
  152. REAL ONE, TWO, ZERO
  153. PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0, ZERO = 0.0E+0 )
  154. * ..
  155. * .. Local Scalars ..
  156. LOGICAL UPPER
  157. CHARACTER DIST, PACKIT, TYPE
  158. CHARACTER*3 PATH
  159. INTEGER I, IOFF, IY, J, JCOUNT, KL, KU, LENJ, MODE
  160. REAL ANORM, BIGNUM, BNORM, BSCAL, CNDNUM, PLUS1,
  161. $ PLUS2, REXP, SFAC, SMLNUM, STAR1, TEXP, TLEFT,
  162. $ TNORM, TSCAL, ULP, UNFL
  163. * ..
  164. * .. External Functions ..
  165. LOGICAL LSAME
  166. INTEGER ISAMAX
  167. REAL SLAMCH, SLARND
  168. EXTERNAL LSAME, ISAMAX, SLAMCH, SLARND
  169. * ..
  170. * .. External Subroutines ..
  171. EXTERNAL SCOPY, SLABAD, SLARNV, SLATB4, SLATMS, SSCAL,
  172. $ SSWAP
  173. * ..
  174. * .. Intrinsic Functions ..
  175. INTRINSIC ABS, MAX, MIN, REAL, SIGN, SQRT
  176. * ..
  177. * .. Executable Statements ..
  178. *
  179. PATH( 1: 1 ) = 'Single precision'
  180. PATH( 2: 3 ) = 'TB'
  181. UNFL = SLAMCH( 'Safe minimum' )
  182. ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
  183. SMLNUM = UNFL
  184. BIGNUM = ( ONE-ULP ) / SMLNUM
  185. CALL SLABAD( SMLNUM, BIGNUM )
  186. IF( ( IMAT.GE.6 .AND. IMAT.LE.9 ) .OR. IMAT.EQ.17 ) THEN
  187. DIAG = 'U'
  188. ELSE
  189. DIAG = 'N'
  190. END IF
  191. INFO = 0
  192. *
  193. * Quick return if N.LE.0.
  194. *
  195. IF( N.LE.0 )
  196. $ RETURN
  197. *
  198. * Call SLATB4 to set parameters for SLATMS.
  199. *
  200. UPPER = LSAME( UPLO, 'U' )
  201. IF( UPPER ) THEN
  202. CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
  203. $ CNDNUM, DIST )
  204. KU = KD
  205. IOFF = 1 + MAX( 0, KD-N+1 )
  206. KL = 0
  207. PACKIT = 'Q'
  208. ELSE
  209. CALL SLATB4( PATH, -IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
  210. $ CNDNUM, DIST )
  211. KL = KD
  212. IOFF = 1
  213. KU = 0
  214. PACKIT = 'B'
  215. END IF
  216. *
  217. * IMAT <= 5: Non-unit triangular matrix
  218. *
  219. IF( IMAT.LE.5 ) THEN
  220. CALL SLATMS( N, N, DIST, ISEED, TYPE, B, MODE, CNDNUM, ANORM,
  221. $ KL, KU, PACKIT, AB( IOFF, 1 ), LDAB, WORK, INFO )
  222. *
  223. * IMAT > 5: Unit triangular matrix
  224. * The diagonal is deliberately set to something other than 1.
  225. *
  226. * IMAT = 6: Matrix is the identity
  227. *
  228. ELSE IF( IMAT.EQ.6 ) THEN
  229. IF( UPPER ) THEN
  230. DO 20 J = 1, N
  231. DO 10 I = MAX( 1, KD+2-J ), KD
  232. AB( I, J ) = ZERO
  233. 10 CONTINUE
  234. AB( KD+1, J ) = J
  235. 20 CONTINUE
  236. ELSE
  237. DO 40 J = 1, N
  238. AB( 1, J ) = J
  239. DO 30 I = 2, MIN( KD+1, N-J+1 )
  240. AB( I, J ) = ZERO
  241. 30 CONTINUE
  242. 40 CONTINUE
  243. END IF
  244. *
  245. * IMAT > 6: Non-trivial unit triangular matrix
  246. *
  247. * A unit triangular matrix T with condition CNDNUM is formed.
  248. * In this version, T only has bandwidth 2, the rest of it is zero.
  249. *
  250. ELSE IF( IMAT.LE.9 ) THEN
  251. TNORM = SQRT( CNDNUM )
  252. *
  253. * Initialize AB to zero.
  254. *
  255. IF( UPPER ) THEN
  256. DO 60 J = 1, N
  257. DO 50 I = MAX( 1, KD+2-J ), KD
  258. AB( I, J ) = ZERO
  259. 50 CONTINUE
  260. AB( KD+1, J ) = REAL( J )
  261. 60 CONTINUE
  262. ELSE
  263. DO 80 J = 1, N
  264. DO 70 I = 2, MIN( KD+1, N-J+1 )
  265. AB( I, J ) = ZERO
  266. 70 CONTINUE
  267. AB( 1, J ) = REAL( J )
  268. 80 CONTINUE
  269. END IF
  270. *
  271. * Special case: T is tridiagonal. Set every other offdiagonal
  272. * so that the matrix has norm TNORM+1.
  273. *
  274. IF( KD.EQ.1 ) THEN
  275. IF( UPPER ) THEN
  276. AB( 1, 2 ) = SIGN( TNORM, SLARND( 2, ISEED ) )
  277. LENJ = ( N-3 ) / 2
  278. CALL SLARNV( 2, ISEED, LENJ, WORK )
  279. DO 90 J = 1, LENJ
  280. AB( 1, 2*( J+1 ) ) = TNORM*WORK( J )
  281. 90 CONTINUE
  282. ELSE
  283. AB( 2, 1 ) = SIGN( TNORM, SLARND( 2, ISEED ) )
  284. LENJ = ( N-3 ) / 2
  285. CALL SLARNV( 2, ISEED, LENJ, WORK )
  286. DO 100 J = 1, LENJ
  287. AB( 2, 2*J+1 ) = TNORM*WORK( J )
  288. 100 CONTINUE
  289. END IF
  290. ELSE IF( KD.GT.1 ) THEN
  291. *
  292. * Form a unit triangular matrix T with condition CNDNUM. T is
  293. * given by
  294. * | 1 + * |
  295. * | 1 + |
  296. * T = | 1 + * |
  297. * | 1 + |
  298. * | 1 + * |
  299. * | 1 + |
  300. * | . . . |
  301. * Each element marked with a '*' is formed by taking the product
  302. * of the adjacent elements marked with '+'. The '*'s can be
  303. * chosen freely, and the '+'s are chosen so that the inverse of
  304. * T will have elements of the same magnitude as T.
  305. *
  306. * The two offdiagonals of T are stored in WORK.
  307. *
  308. STAR1 = SIGN( TNORM, SLARND( 2, ISEED ) )
  309. SFAC = SQRT( TNORM )
  310. PLUS1 = SIGN( SFAC, SLARND( 2, ISEED ) )
  311. DO 110 J = 1, N, 2
  312. PLUS2 = STAR1 / PLUS1
  313. WORK( J ) = PLUS1
  314. WORK( N+J ) = STAR1
  315. IF( J+1.LE.N ) THEN
  316. WORK( J+1 ) = PLUS2
  317. WORK( N+J+1 ) = ZERO
  318. PLUS1 = STAR1 / PLUS2
  319. *
  320. * Generate a new *-value with norm between sqrt(TNORM)
  321. * and TNORM.
  322. *
  323. REXP = SLARND( 2, ISEED )
  324. IF( REXP.LT.ZERO ) THEN
  325. STAR1 = -SFAC**( ONE-REXP )
  326. ELSE
  327. STAR1 = SFAC**( ONE+REXP )
  328. END IF
  329. END IF
  330. 110 CONTINUE
  331. *
  332. * Copy the tridiagonal T to AB.
  333. *
  334. IF( UPPER ) THEN
  335. CALL SCOPY( N-1, WORK, 1, AB( KD, 2 ), LDAB )
  336. CALL SCOPY( N-2, WORK( N+1 ), 1, AB( KD-1, 3 ), LDAB )
  337. ELSE
  338. CALL SCOPY( N-1, WORK, 1, AB( 2, 1 ), LDAB )
  339. CALL SCOPY( N-2, WORK( N+1 ), 1, AB( 3, 1 ), LDAB )
  340. END IF
  341. END IF
  342. *
  343. * IMAT > 9: Pathological test cases. These triangular matrices
  344. * are badly scaled or badly conditioned, so when used in solving a
  345. * triangular system they may cause overflow in the solution vector.
  346. *
  347. ELSE IF( IMAT.EQ.10 ) THEN
  348. *
  349. * Type 10: Generate a triangular matrix with elements between
  350. * -1 and 1. Give the diagonal norm 2 to make it well-conditioned.
  351. * Make the right hand side large so that it requires scaling.
  352. *
  353. IF( UPPER ) THEN
  354. DO 120 J = 1, N
  355. LENJ = MIN( J, KD+1 )
  356. CALL SLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
  357. AB( KD+1, J ) = SIGN( TWO, AB( KD+1, J ) )
  358. 120 CONTINUE
  359. ELSE
  360. DO 130 J = 1, N
  361. LENJ = MIN( N-J+1, KD+1 )
  362. IF( LENJ.GT.0 )
  363. $ CALL SLARNV( 2, ISEED, LENJ, AB( 1, J ) )
  364. AB( 1, J ) = SIGN( TWO, AB( 1, J ) )
  365. 130 CONTINUE
  366. END IF
  367. *
  368. * Set the right hand side so that the largest value is BIGNUM.
  369. *
  370. CALL SLARNV( 2, ISEED, N, B )
  371. IY = ISAMAX( N, B, 1 )
  372. BNORM = ABS( B( IY ) )
  373. BSCAL = BIGNUM / MAX( ONE, BNORM )
  374. CALL SSCAL( N, BSCAL, B, 1 )
  375. *
  376. ELSE IF( IMAT.EQ.11 ) THEN
  377. *
  378. * Type 11: Make the first diagonal element in the solve small to
  379. * cause immediate overflow when dividing by T(j,j).
  380. * In type 11, the offdiagonal elements are small (CNORM(j) < 1).
  381. *
  382. CALL SLARNV( 2, ISEED, N, B )
  383. TSCAL = ONE / REAL( KD+1 )
  384. IF( UPPER ) THEN
  385. DO 140 J = 1, N
  386. LENJ = MIN( J, KD+1 )
  387. CALL SLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
  388. CALL SSCAL( LENJ-1, TSCAL, AB( KD+2-LENJ, J ), 1 )
  389. AB( KD+1, J ) = SIGN( ONE, AB( KD+1, J ) )
  390. 140 CONTINUE
  391. AB( KD+1, N ) = SMLNUM*AB( KD+1, N )
  392. ELSE
  393. DO 150 J = 1, N
  394. LENJ = MIN( N-J+1, KD+1 )
  395. CALL SLARNV( 2, ISEED, LENJ, AB( 1, J ) )
  396. IF( LENJ.GT.1 )
  397. $ CALL SSCAL( LENJ-1, TSCAL, AB( 2, J ), 1 )
  398. AB( 1, J ) = SIGN( ONE, AB( 1, J ) )
  399. 150 CONTINUE
  400. AB( 1, 1 ) = SMLNUM*AB( 1, 1 )
  401. END IF
  402. *
  403. ELSE IF( IMAT.EQ.12 ) THEN
  404. *
  405. * Type 12: Make the first diagonal element in the solve small to
  406. * cause immediate overflow when dividing by T(j,j).
  407. * In type 12, the offdiagonal elements are O(1) (CNORM(j) > 1).
  408. *
  409. CALL SLARNV( 2, ISEED, N, B )
  410. IF( UPPER ) THEN
  411. DO 160 J = 1, N
  412. LENJ = MIN( J, KD+1 )
  413. CALL SLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
  414. AB( KD+1, J ) = SIGN( ONE, AB( KD+1, J ) )
  415. 160 CONTINUE
  416. AB( KD+1, N ) = SMLNUM*AB( KD+1, N )
  417. ELSE
  418. DO 170 J = 1, N
  419. LENJ = MIN( N-J+1, KD+1 )
  420. CALL SLARNV( 2, ISEED, LENJ, AB( 1, J ) )
  421. AB( 1, J ) = SIGN( ONE, AB( 1, J ) )
  422. 170 CONTINUE
  423. AB( 1, 1 ) = SMLNUM*AB( 1, 1 )
  424. END IF
  425. *
  426. ELSE IF( IMAT.EQ.13 ) THEN
  427. *
  428. * Type 13: T is diagonal with small numbers on the diagonal to
  429. * make the growth factor underflow, but a small right hand side
  430. * chosen so that the solution does not overflow.
  431. *
  432. IF( UPPER ) THEN
  433. JCOUNT = 1
  434. DO 190 J = N, 1, -1
  435. DO 180 I = MAX( 1, KD+1-( J-1 ) ), KD
  436. AB( I, J ) = ZERO
  437. 180 CONTINUE
  438. IF( JCOUNT.LE.2 ) THEN
  439. AB( KD+1, J ) = SMLNUM
  440. ELSE
  441. AB( KD+1, J ) = ONE
  442. END IF
  443. JCOUNT = JCOUNT + 1
  444. IF( JCOUNT.GT.4 )
  445. $ JCOUNT = 1
  446. 190 CONTINUE
  447. ELSE
  448. JCOUNT = 1
  449. DO 210 J = 1, N
  450. DO 200 I = 2, MIN( N-J+1, KD+1 )
  451. AB( I, J ) = ZERO
  452. 200 CONTINUE
  453. IF( JCOUNT.LE.2 ) THEN
  454. AB( 1, J ) = SMLNUM
  455. ELSE
  456. AB( 1, J ) = ONE
  457. END IF
  458. JCOUNT = JCOUNT + 1
  459. IF( JCOUNT.GT.4 )
  460. $ JCOUNT = 1
  461. 210 CONTINUE
  462. END IF
  463. *
  464. * Set the right hand side alternately zero and small.
  465. *
  466. IF( UPPER ) THEN
  467. B( 1 ) = ZERO
  468. DO 220 I = N, 2, -2
  469. B( I ) = ZERO
  470. B( I-1 ) = SMLNUM
  471. 220 CONTINUE
  472. ELSE
  473. B( N ) = ZERO
  474. DO 230 I = 1, N - 1, 2
  475. B( I ) = ZERO
  476. B( I+1 ) = SMLNUM
  477. 230 CONTINUE
  478. END IF
  479. *
  480. ELSE IF( IMAT.EQ.14 ) THEN
  481. *
  482. * Type 14: Make the diagonal elements small to cause gradual
  483. * overflow when dividing by T(j,j). To control the amount of
  484. * scaling needed, the matrix is bidiagonal.
  485. *
  486. TEXP = ONE / REAL( KD+1 )
  487. TSCAL = SMLNUM**TEXP
  488. CALL SLARNV( 2, ISEED, N, B )
  489. IF( UPPER ) THEN
  490. DO 250 J = 1, N
  491. DO 240 I = MAX( 1, KD+2-J ), KD
  492. AB( I, J ) = ZERO
  493. 240 CONTINUE
  494. IF( J.GT.1 .AND. KD.GT.0 )
  495. $ AB( KD, J ) = -ONE
  496. AB( KD+1, J ) = TSCAL
  497. 250 CONTINUE
  498. B( N ) = ONE
  499. ELSE
  500. DO 270 J = 1, N
  501. DO 260 I = 3, MIN( N-J+1, KD+1 )
  502. AB( I, J ) = ZERO
  503. 260 CONTINUE
  504. IF( J.LT.N .AND. KD.GT.0 )
  505. $ AB( 2, J ) = -ONE
  506. AB( 1, J ) = TSCAL
  507. 270 CONTINUE
  508. B( 1 ) = ONE
  509. END IF
  510. *
  511. ELSE IF( IMAT.EQ.15 ) THEN
  512. *
  513. * Type 15: One zero diagonal element.
  514. *
  515. IY = N / 2 + 1
  516. IF( UPPER ) THEN
  517. DO 280 J = 1, N
  518. LENJ = MIN( J, KD+1 )
  519. CALL SLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
  520. IF( J.NE.IY ) THEN
  521. AB( KD+1, J ) = SIGN( TWO, AB( KD+1, J ) )
  522. ELSE
  523. AB( KD+1, J ) = ZERO
  524. END IF
  525. 280 CONTINUE
  526. ELSE
  527. DO 290 J = 1, N
  528. LENJ = MIN( N-J+1, KD+1 )
  529. CALL SLARNV( 2, ISEED, LENJ, AB( 1, J ) )
  530. IF( J.NE.IY ) THEN
  531. AB( 1, J ) = SIGN( TWO, AB( 1, J ) )
  532. ELSE
  533. AB( 1, J ) = ZERO
  534. END IF
  535. 290 CONTINUE
  536. END IF
  537. CALL SLARNV( 2, ISEED, N, B )
  538. CALL SSCAL( N, TWO, B, 1 )
  539. *
  540. ELSE IF( IMAT.EQ.16 ) THEN
  541. *
  542. * Type 16: Make the offdiagonal elements large to cause overflow
  543. * when adding a column of T. In the non-transposed case, the
  544. * matrix is constructed to cause overflow when adding a column in
  545. * every other step.
  546. *
  547. TSCAL = UNFL / ULP
  548. TSCAL = ( ONE-ULP ) / TSCAL
  549. DO 310 J = 1, N
  550. DO 300 I = 1, KD + 1
  551. AB( I, J ) = ZERO
  552. 300 CONTINUE
  553. 310 CONTINUE
  554. TEXP = ONE
  555. IF( KD.GT.0 ) THEN
  556. IF( UPPER ) THEN
  557. DO 330 J = N, 1, -KD
  558. DO 320 I = J, MAX( 1, J-KD+1 ), -2
  559. AB( 1+( J-I ), I ) = -TSCAL / REAL( KD+2 )
  560. AB( KD+1, I ) = ONE
  561. B( I ) = TEXP*( ONE-ULP )
  562. IF( I.GT.MAX( 1, J-KD+1 ) ) THEN
  563. AB( 2+( J-I ), I-1 ) = -( TSCAL / REAL( KD+2 ) )
  564. $ / REAL( KD+3 )
  565. AB( KD+1, I-1 ) = ONE
  566. B( I-1 ) = TEXP*REAL( ( KD+1 )*( KD+1 )+KD )
  567. END IF
  568. TEXP = TEXP*TWO
  569. 320 CONTINUE
  570. B( MAX( 1, J-KD+1 ) ) = ( REAL( KD+2 ) /
  571. $ REAL( KD+3 ) )*TSCAL
  572. 330 CONTINUE
  573. ELSE
  574. DO 350 J = 1, N, KD
  575. TEXP = ONE
  576. LENJ = MIN( KD+1, N-J+1 )
  577. DO 340 I = J, MIN( N, J+KD-1 ), 2
  578. AB( LENJ-( I-J ), J ) = -TSCAL / REAL( KD+2 )
  579. AB( 1, J ) = ONE
  580. B( J ) = TEXP*( ONE-ULP )
  581. IF( I.LT.MIN( N, J+KD-1 ) ) THEN
  582. AB( LENJ-( I-J+1 ), I+1 ) = -( TSCAL /
  583. $ REAL( KD+2 ) ) / REAL( KD+3 )
  584. AB( 1, I+1 ) = ONE
  585. B( I+1 ) = TEXP*REAL( ( KD+1 )*( KD+1 )+KD )
  586. END IF
  587. TEXP = TEXP*TWO
  588. 340 CONTINUE
  589. B( MIN( N, J+KD-1 ) ) = ( REAL( KD+2 ) /
  590. $ REAL( KD+3 ) )*TSCAL
  591. 350 CONTINUE
  592. END IF
  593. ELSE
  594. DO 360 J = 1, N
  595. AB( 1, J ) = ONE
  596. B( J ) = REAL( J )
  597. 360 CONTINUE
  598. END IF
  599. *
  600. ELSE IF( IMAT.EQ.17 ) THEN
  601. *
  602. * Type 17: Generate a unit triangular matrix with elements
  603. * between -1 and 1, and make the right hand side large so that it
  604. * requires scaling.
  605. *
  606. IF( UPPER ) THEN
  607. DO 370 J = 1, N
  608. LENJ = MIN( J-1, KD )
  609. CALL SLARNV( 2, ISEED, LENJ, AB( KD+1-LENJ, J ) )
  610. AB( KD+1, J ) = REAL( J )
  611. 370 CONTINUE
  612. ELSE
  613. DO 380 J = 1, N
  614. LENJ = MIN( N-J, KD )
  615. IF( LENJ.GT.0 )
  616. $ CALL SLARNV( 2, ISEED, LENJ, AB( 2, J ) )
  617. AB( 1, J ) = REAL( J )
  618. 380 CONTINUE
  619. END IF
  620. *
  621. * Set the right hand side so that the largest value is BIGNUM.
  622. *
  623. CALL SLARNV( 2, ISEED, N, B )
  624. IY = ISAMAX( N, B, 1 )
  625. BNORM = ABS( B( IY ) )
  626. BSCAL = BIGNUM / MAX( ONE, BNORM )
  627. CALL SSCAL( N, BSCAL, B, 1 )
  628. *
  629. ELSE IF( IMAT.EQ.18 ) THEN
  630. *
  631. * Type 18: Generate a triangular matrix with elements between
  632. * BIGNUM/KD and BIGNUM so that at least one of the column
  633. * norms will exceed BIGNUM.
  634. *
  635. TLEFT = BIGNUM / MAX( ONE, REAL( KD ) )
  636. TSCAL = BIGNUM*( REAL( KD ) / REAL( KD+1 ) )
  637. IF( UPPER ) THEN
  638. DO 400 J = 1, N
  639. LENJ = MIN( J, KD+1 )
  640. CALL SLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
  641. DO 390 I = KD + 2 - LENJ, KD + 1
  642. AB( I, J ) = SIGN( TLEFT, AB( I, J ) ) +
  643. $ TSCAL*AB( I, J )
  644. 390 CONTINUE
  645. 400 CONTINUE
  646. ELSE
  647. DO 420 J = 1, N
  648. LENJ = MIN( N-J+1, KD+1 )
  649. CALL SLARNV( 2, ISEED, LENJ, AB( 1, J ) )
  650. DO 410 I = 1, LENJ
  651. AB( I, J ) = SIGN( TLEFT, AB( I, J ) ) +
  652. $ TSCAL*AB( I, J )
  653. 410 CONTINUE
  654. 420 CONTINUE
  655. END IF
  656. CALL SLARNV( 2, ISEED, N, B )
  657. CALL SSCAL( N, TWO, B, 1 )
  658. END IF
  659. *
  660. * Flip the matrix if the transpose will be used.
  661. *
  662. IF( .NOT.LSAME( TRANS, 'N' ) ) THEN
  663. IF( UPPER ) THEN
  664. DO 430 J = 1, N / 2
  665. LENJ = MIN( N-2*J+1, KD+1 )
  666. CALL SSWAP( LENJ, AB( KD+1, J ), LDAB-1,
  667. $ AB( KD+2-LENJ, N-J+1 ), -1 )
  668. 430 CONTINUE
  669. ELSE
  670. DO 440 J = 1, N / 2
  671. LENJ = MIN( N-2*J+1, KD+1 )
  672. CALL SSWAP( LENJ, AB( 1, J ), 1, AB( LENJ, N-J+2-LENJ ),
  673. $ -LDAB+1 )
  674. 440 CONTINUE
  675. END IF
  676. END IF
  677. *
  678. RETURN
  679. *
  680. * End of SLATTB
  681. *
  682. END