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.

clattr.f 23 kB

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