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.

dlatmr.f 43 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227
  1. *> \brief \b DLATMR
  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 DLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
  12. * RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER,
  13. * CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM,
  14. * PACK, A, LDA, IWORK, INFO )
  15. *
  16. * .. Scalar Arguments ..
  17. * CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM
  18. * INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N
  19. * DOUBLE PRECISION ANORM, COND, CONDL, CONDR, DMAX, SPARSE
  20. * ..
  21. * .. Array Arguments ..
  22. * INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * )
  23. * DOUBLE PRECISION A( LDA, * ), D( * ), DL( * ), DR( * )
  24. * ..
  25. *
  26. *
  27. *> \par Purpose:
  28. * =============
  29. *>
  30. *> \verbatim
  31. *>
  32. *> DLATMR generates random matrices of various types for testing
  33. *> LAPACK programs.
  34. *>
  35. *> DLATMR operates by applying the following sequence of
  36. *> operations:
  37. *>
  38. *> Generate a matrix A with random entries of distribution DIST
  39. *> which is symmetric if SYM='S', and nonsymmetric
  40. *> if SYM='N'.
  41. *>
  42. *> Set the diagonal to D, where D may be input or
  43. *> computed according to MODE, COND, DMAX and RSIGN
  44. *> as described below.
  45. *>
  46. *> Grade the matrix, if desired, from the left and/or right
  47. *> as specified by GRADE. The inputs DL, MODEL, CONDL, DR,
  48. *> MODER and CONDR also determine the grading as described
  49. *> below.
  50. *>
  51. *> Permute, if desired, the rows and/or columns as specified by
  52. *> PIVTNG and IPIVOT.
  53. *>
  54. *> Set random entries to zero, if desired, to get a random sparse
  55. *> matrix as specified by SPARSE.
  56. *>
  57. *> Make A a band matrix, if desired, by zeroing out the matrix
  58. *> outside a band of lower bandwidth KL and upper bandwidth KU.
  59. *>
  60. *> Scale A, if desired, to have maximum entry ANORM.
  61. *>
  62. *> Pack the matrix if desired. Options specified by PACK are:
  63. *> no packing
  64. *> zero out upper half (if symmetric)
  65. *> zero out lower half (if symmetric)
  66. *> store the upper half columnwise (if symmetric or
  67. *> square upper triangular)
  68. *> store the lower half columnwise (if symmetric or
  69. *> square lower triangular)
  70. *> same as upper half rowwise if symmetric
  71. *> store the lower triangle in banded format (if symmetric)
  72. *> store the upper triangle in banded format (if symmetric)
  73. *> store the entire matrix in banded format
  74. *>
  75. *> Note: If two calls to DLATMR differ only in the PACK parameter,
  76. *> they will generate mathematically equivalent matrices.
  77. *>
  78. *> If two calls to DLATMR both have full bandwidth (KL = M-1
  79. *> and KU = N-1), and differ only in the PIVTNG and PACK
  80. *> parameters, then the matrices generated will differ only
  81. *> in the order of the rows and/or columns, and otherwise
  82. *> contain the same data. This consistency cannot be and
  83. *> is not maintained with less than full bandwidth.
  84. *> \endverbatim
  85. *
  86. * Arguments:
  87. * ==========
  88. *
  89. *> \param[in] M
  90. *> \verbatim
  91. *> M is INTEGER
  92. *> Number of rows of A. Not modified.
  93. *> \endverbatim
  94. *>
  95. *> \param[in] N
  96. *> \verbatim
  97. *> N is INTEGER
  98. *> Number of columns of A. Not modified.
  99. *> \endverbatim
  100. *>
  101. *> \param[in] DIST
  102. *> \verbatim
  103. *> DIST is CHARACTER*1
  104. *> On entry, DIST specifies the type of distribution to be used
  105. *> to generate a random matrix .
  106. *> 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
  107. *> 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
  108. *> 'N' => NORMAL( 0, 1 ) ( 'N' for normal )
  109. *> Not modified.
  110. *> \endverbatim
  111. *>
  112. *> \param[in,out] ISEED
  113. *> \verbatim
  114. *> ISEED is INTEGER array, dimension (4)
  115. *> On entry ISEED specifies the seed of the random number
  116. *> generator. They should lie between 0 and 4095 inclusive,
  117. *> and ISEED(4) should be odd. The random number generator
  118. *> uses a linear congruential sequence limited to small
  119. *> integers, and so should produce machine independent
  120. *> random numbers. The values of ISEED are changed on
  121. *> exit, and can be used in the next call to DLATMR
  122. *> to continue the same random number sequence.
  123. *> Changed on exit.
  124. *> \endverbatim
  125. *>
  126. *> \param[in] SYM
  127. *> \verbatim
  128. *> SYM is CHARACTER*1
  129. *> If SYM='S' or 'H', generated matrix is symmetric.
  130. *> If SYM='N', generated matrix is nonsymmetric.
  131. *> Not modified.
  132. *> \endverbatim
  133. *>
  134. *> \param[in,out] D
  135. *> \verbatim
  136. *> D is DOUBLE PRECISION array, dimension (min(M,N))
  137. *> On entry this array specifies the diagonal entries
  138. *> of the diagonal of A. D may either be specified
  139. *> on entry, or set according to MODE and COND as described
  140. *> below. May be changed on exit if MODE is nonzero.
  141. *> \endverbatim
  142. *>
  143. *> \param[in] MODE
  144. *> \verbatim
  145. *> MODE is INTEGER
  146. *> On entry describes how D is to be used:
  147. *> MODE = 0 means use D as input
  148. *> MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
  149. *> MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
  150. *> MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
  151. *> MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
  152. *> MODE = 5 sets D to random numbers in the range
  153. *> ( 1/COND , 1 ) such that their logarithms
  154. *> are uniformly distributed.
  155. *> MODE = 6 set D to random numbers from same distribution
  156. *> as the rest of the matrix.
  157. *> MODE < 0 has the same meaning as ABS(MODE), except that
  158. *> the order of the elements of D is reversed.
  159. *> Thus if MODE is positive, D has entries ranging from
  160. *> 1 to 1/COND, if negative, from 1/COND to 1,
  161. *> Not modified.
  162. *> \endverbatim
  163. *>
  164. *> \param[in] COND
  165. *> \verbatim
  166. *> COND is DOUBLE PRECISION
  167. *> On entry, used as described under MODE above.
  168. *> If used, it must be >= 1. Not modified.
  169. *> \endverbatim
  170. *>
  171. *> \param[in] DMAX
  172. *> \verbatim
  173. *> DMAX is DOUBLE PRECISION
  174. *> If MODE neither -6, 0 nor 6, the diagonal is scaled by
  175. *> DMAX / max(abs(D(i))), so that maximum absolute entry
  176. *> of diagonal is abs(DMAX). If DMAX is negative (or zero),
  177. *> diagonal will be scaled by a negative number (or zero).
  178. *> \endverbatim
  179. *>
  180. *> \param[in] RSIGN
  181. *> \verbatim
  182. *> RSIGN is CHARACTER*1
  183. *> If MODE neither -6, 0 nor 6, specifies sign of diagonal
  184. *> as follows:
  185. *> 'T' => diagonal entries are multiplied by 1 or -1
  186. *> with probability .5
  187. *> 'F' => diagonal unchanged
  188. *> Not modified.
  189. *> \endverbatim
  190. *>
  191. *> \param[in] GRADE
  192. *> \verbatim
  193. *> GRADE is CHARACTER*1
  194. *> Specifies grading of matrix as follows:
  195. *> 'N' => no grading
  196. *> 'L' => matrix premultiplied by diag( DL )
  197. *> (only if matrix nonsymmetric)
  198. *> 'R' => matrix postmultiplied by diag( DR )
  199. *> (only if matrix nonsymmetric)
  200. *> 'B' => matrix premultiplied by diag( DL ) and
  201. *> postmultiplied by diag( DR )
  202. *> (only if matrix nonsymmetric)
  203. *> 'S' or 'H' => matrix premultiplied by diag( DL ) and
  204. *> postmultiplied by diag( DL )
  205. *> ('S' for symmetric, or 'H' for Hermitian)
  206. *> 'E' => matrix premultiplied by diag( DL ) and
  207. *> postmultiplied by inv( diag( DL ) )
  208. *> ( 'E' for eigenvalue invariance)
  209. *> (only if matrix nonsymmetric)
  210. *> Note: if GRADE='E', then M must equal N.
  211. *> Not modified.
  212. *> \endverbatim
  213. *>
  214. *> \param[in,out] DL
  215. *> \verbatim
  216. *> DL is DOUBLE PRECISION array, dimension (M)
  217. *> If MODEL=0, then on entry this array specifies the diagonal
  218. *> entries of a diagonal matrix used as described under GRADE
  219. *> above. If MODEL is not zero, then DL will be set according
  220. *> to MODEL and CONDL, analogous to the way D is set according
  221. *> to MODE and COND (except there is no DMAX parameter for DL).
  222. *> If GRADE='E', then DL cannot have zero entries.
  223. *> Not referenced if GRADE = 'N' or 'R'. Changed on exit.
  224. *> \endverbatim
  225. *>
  226. *> \param[in] MODEL
  227. *> \verbatim
  228. *> MODEL is INTEGER
  229. *> This specifies how the diagonal array DL is to be computed,
  230. *> just as MODE specifies how D is to be computed.
  231. *> Not modified.
  232. *> \endverbatim
  233. *>
  234. *> \param[in] CONDL
  235. *> \verbatim
  236. *> CONDL is DOUBLE PRECISION
  237. *> When MODEL is not zero, this specifies the condition number
  238. *> of the computed DL. Not modified.
  239. *> \endverbatim
  240. *>
  241. *> \param[in,out] DR
  242. *> \verbatim
  243. *> DR is DOUBLE PRECISION array, dimension (N)
  244. *> If MODER=0, then on entry this array specifies the diagonal
  245. *> entries of a diagonal matrix used as described under GRADE
  246. *> above. If MODER is not zero, then DR will be set according
  247. *> to MODER and CONDR, analogous to the way D is set according
  248. *> to MODE and COND (except there is no DMAX parameter for DR).
  249. *> Not referenced if GRADE = 'N', 'L', 'H', 'S' or 'E'.
  250. *> Changed on exit.
  251. *> \endverbatim
  252. *>
  253. *> \param[in] MODER
  254. *> \verbatim
  255. *> MODER is INTEGER
  256. *> This specifies how the diagonal array DR is to be computed,
  257. *> just as MODE specifies how D is to be computed.
  258. *> Not modified.
  259. *> \endverbatim
  260. *>
  261. *> \param[in] CONDR
  262. *> \verbatim
  263. *> CONDR is DOUBLE PRECISION
  264. *> When MODER is not zero, this specifies the condition number
  265. *> of the computed DR. Not modified.
  266. *> \endverbatim
  267. *>
  268. *> \param[in] PIVTNG
  269. *> \verbatim
  270. *> PIVTNG is CHARACTER*1
  271. *> On entry specifies pivoting permutations as follows:
  272. *> 'N' or ' ' => none.
  273. *> 'L' => left or row pivoting (matrix must be nonsymmetric).
  274. *> 'R' => right or column pivoting (matrix must be
  275. *> nonsymmetric).
  276. *> 'B' or 'F' => both or full pivoting, i.e., on both sides.
  277. *> In this case, M must equal N
  278. *>
  279. *> If two calls to DLATMR both have full bandwidth (KL = M-1
  280. *> and KU = N-1), and differ only in the PIVTNG and PACK
  281. *> parameters, then the matrices generated will differ only
  282. *> in the order of the rows and/or columns, and otherwise
  283. *> contain the same data. This consistency cannot be
  284. *> maintained with less than full bandwidth.
  285. *> \endverbatim
  286. *>
  287. *> \param[in] IPIVOT
  288. *> \verbatim
  289. *> IPIVOT is INTEGER array, dimension (N or M)
  290. *> This array specifies the permutation used. After the
  291. *> basic matrix is generated, the rows, columns, or both
  292. *> are permuted. If, say, row pivoting is selected, DLATMR
  293. *> starts with the *last* row and interchanges the M-th and
  294. *> IPIVOT(M)-th rows, then moves to the next-to-last row,
  295. *> interchanging the (M-1)-th and the IPIVOT(M-1)-th rows,
  296. *> and so on. In terms of "2-cycles", the permutation is
  297. *> (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M))
  298. *> where the rightmost cycle is applied first. This is the
  299. *> *inverse* of the effect of pivoting in LINPACK. The idea
  300. *> is that factoring (with pivoting) an identity matrix
  301. *> which has been inverse-pivoted in this way should
  302. *> result in a pivot vector identical to IPIVOT.
  303. *> Not referenced if PIVTNG = 'N'. Not modified.
  304. *> \endverbatim
  305. *>
  306. *> \param[in] KL
  307. *> \verbatim
  308. *> KL is INTEGER
  309. *> On entry specifies the lower bandwidth of the matrix. For
  310. *> example, KL=0 implies upper triangular, KL=1 implies upper
  311. *> Hessenberg, and KL at least M-1 implies the matrix is not
  312. *> banded. Must equal KU if matrix is symmetric.
  313. *> Not modified.
  314. *> \endverbatim
  315. *>
  316. *> \param[in] KU
  317. *> \verbatim
  318. *> KU is INTEGER
  319. *> On entry specifies the upper bandwidth of the matrix. For
  320. *> example, KU=0 implies lower triangular, KU=1 implies lower
  321. *> Hessenberg, and KU at least N-1 implies the matrix is not
  322. *> banded. Must equal KL if matrix is symmetric.
  323. *> Not modified.
  324. *> \endverbatim
  325. *>
  326. *> \param[in] SPARSE
  327. *> \verbatim
  328. *> SPARSE is DOUBLE PRECISION
  329. *> On entry specifies the sparsity of the matrix if a sparse
  330. *> matrix is to be generated. SPARSE should lie between
  331. *> 0 and 1. To generate a sparse matrix, for each matrix entry
  332. *> a uniform ( 0, 1 ) random number x is generated and
  333. *> compared to SPARSE; if x is larger the matrix entry
  334. *> is unchanged and if x is smaller the entry is set
  335. *> to zero. Thus on the average a fraction SPARSE of the
  336. *> entries will be set to zero.
  337. *> Not modified.
  338. *> \endverbatim
  339. *>
  340. *> \param[in] ANORM
  341. *> \verbatim
  342. *> ANORM is DOUBLE PRECISION
  343. *> On entry specifies maximum entry of output matrix
  344. *> (output matrix will by multiplied by a constant so that
  345. *> its largest absolute entry equal ANORM)
  346. *> if ANORM is nonnegative. If ANORM is negative no scaling
  347. *> is done. Not modified.
  348. *> \endverbatim
  349. *>
  350. *> \param[in] PACK
  351. *> \verbatim
  352. *> PACK is CHARACTER*1
  353. *> On entry specifies packing of matrix as follows:
  354. *> 'N' => no packing
  355. *> 'U' => zero out all subdiagonal entries (if symmetric)
  356. *> 'L' => zero out all superdiagonal entries (if symmetric)
  357. *> 'C' => store the upper triangle columnwise
  358. *> (only if matrix symmetric or square upper triangular)
  359. *> 'R' => store the lower triangle columnwise
  360. *> (only if matrix symmetric or square lower triangular)
  361. *> (same as upper half rowwise if symmetric)
  362. *> 'B' => store the lower triangle in band storage scheme
  363. *> (only if matrix symmetric)
  364. *> 'Q' => store the upper triangle in band storage scheme
  365. *> (only if matrix symmetric)
  366. *> 'Z' => store the entire matrix in band storage scheme
  367. *> (pivoting can be provided for by using this
  368. *> option to store A in the trailing rows of
  369. *> the allocated storage)
  370. *>
  371. *> Using these options, the various LAPACK packed and banded
  372. *> storage schemes can be obtained:
  373. *> GB - use 'Z'
  374. *> PB, SB or TB - use 'B' or 'Q'
  375. *> PP, SP or TP - use 'C' or 'R'
  376. *>
  377. *> If two calls to DLATMR differ only in the PACK parameter,
  378. *> they will generate mathematically equivalent matrices.
  379. *> Not modified.
  380. *> \endverbatim
  381. *>
  382. *> \param[out] A
  383. *> \verbatim
  384. *> A is DOUBLE PRECISION array, dimension (LDA,N)
  385. *> On exit A is the desired test matrix. Only those
  386. *> entries of A which are significant on output
  387. *> will be referenced (even if A is in packed or band
  388. *> storage format). The 'unoccupied corners' of A in
  389. *> band format will be zeroed out.
  390. *> \endverbatim
  391. *>
  392. *> \param[in] LDA
  393. *> \verbatim
  394. *> LDA is INTEGER
  395. *> on entry LDA specifies the first dimension of A as
  396. *> declared in the calling program.
  397. *> If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ).
  398. *> If PACK='C' or 'R', LDA must be at least 1.
  399. *> If PACK='B', or 'Q', LDA must be MIN ( KU+1, N )
  400. *> If PACK='Z', LDA must be at least KUU+KLL+1, where
  401. *> KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, M-1 )
  402. *> Not modified.
  403. *> \endverbatim
  404. *>
  405. *> \param[out] IWORK
  406. *> \verbatim
  407. *> IWORK is INTEGER array, dimension ( N or M)
  408. *> Workspace. Not referenced if PIVTNG = 'N'. Changed on exit.
  409. *> \endverbatim
  410. *>
  411. *> \param[out] INFO
  412. *> \verbatim
  413. *> INFO is INTEGER
  414. *> Error parameter on exit:
  415. *> 0 => normal return
  416. *> -1 => M negative or unequal to N and SYM='S' or 'H'
  417. *> -2 => N negative
  418. *> -3 => DIST illegal string
  419. *> -5 => SYM illegal string
  420. *> -7 => MODE not in range -6 to 6
  421. *> -8 => COND less than 1.0, and MODE neither -6, 0 nor 6
  422. *> -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string
  423. *> -11 => GRADE illegal string, or GRADE='E' and
  424. *> M not equal to N, or GRADE='L', 'R', 'B' or 'E' and
  425. *> SYM = 'S' or 'H'
  426. *> -12 => GRADE = 'E' and DL contains zero
  427. *> -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H',
  428. *> 'S' or 'E'
  429. *> -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E',
  430. *> and MODEL neither -6, 0 nor 6
  431. *> -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B'
  432. *> -17 => CONDR less than 1.0, GRADE='R' or 'B', and
  433. *> MODER neither -6, 0 nor 6
  434. *> -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and
  435. *> M not equal to N, or PIVTNG='L' or 'R' and SYM='S'
  436. *> or 'H'
  437. *> -19 => IPIVOT contains out of range number and
  438. *> PIVTNG not equal to 'N'
  439. *> -20 => KL negative
  440. *> -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL
  441. *> -22 => SPARSE not in range 0. to 1.
  442. *> -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q'
  443. *> and SYM='N', or PACK='C' and SYM='N' and either KL
  444. *> not equal to 0 or N not equal to M, or PACK='R' and
  445. *> SYM='N', and either KU not equal to 0 or N not equal
  446. *> to M
  447. *> -26 => LDA too small
  448. *> 1 => Error return from DLATM1 (computing D)
  449. *> 2 => Cannot scale diagonal to DMAX (max. entry is 0)
  450. *> 3 => Error return from DLATM1 (computing DL)
  451. *> 4 => Error return from DLATM1 (computing DR)
  452. *> 5 => ANORM is positive, but matrix constructed prior to
  453. *> attempting to scale it to have norm ANORM, is zero
  454. *> \endverbatim
  455. *
  456. * Authors:
  457. * ========
  458. *
  459. *> \author Univ. of Tennessee
  460. *> \author Univ. of California Berkeley
  461. *> \author Univ. of Colorado Denver
  462. *> \author NAG Ltd.
  463. *
  464. *> \date December 2016
  465. *
  466. *> \ingroup double_matgen
  467. *
  468. * =====================================================================
  469. SUBROUTINE DLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
  470. $ RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER,
  471. $ CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM,
  472. $ PACK, A, LDA, IWORK, INFO )
  473. *
  474. * -- LAPACK computational routine (version 3.7.0) --
  475. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  476. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  477. * December 2016
  478. *
  479. * .. Scalar Arguments ..
  480. CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM
  481. INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N
  482. DOUBLE PRECISION ANORM, COND, CONDL, CONDR, DMAX, SPARSE
  483. * ..
  484. * .. Array Arguments ..
  485. INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * )
  486. DOUBLE PRECISION A( LDA, * ), D( * ), DL( * ), DR( * )
  487. * ..
  488. *
  489. * =====================================================================
  490. *
  491. * .. Parameters ..
  492. DOUBLE PRECISION ZERO
  493. PARAMETER ( ZERO = 0.0D0 )
  494. DOUBLE PRECISION ONE
  495. PARAMETER ( ONE = 1.0D0 )
  496. * ..
  497. * .. Local Scalars ..
  498. LOGICAL BADPVT, DZERO, FULBND
  499. INTEGER I, IDIST, IGRADE, IISUB, IPACK, IPVTNG, IRSIGN,
  500. $ ISUB, ISYM, J, JJSUB, JSUB, K, KLL, KUU, MNMIN,
  501. $ MNSUB, MXSUB, NPVTS
  502. DOUBLE PRECISION ALPHA, ONORM, TEMP
  503. * ..
  504. * .. Local Arrays ..
  505. DOUBLE PRECISION TEMPA( 1 )
  506. * ..
  507. * .. External Functions ..
  508. LOGICAL LSAME
  509. DOUBLE PRECISION DLANGB, DLANGE, DLANSB, DLANSP, DLANSY, DLATM2,
  510. $ DLATM3
  511. EXTERNAL LSAME, DLANGB, DLANGE, DLANSB, DLANSP, DLANSY,
  512. $ DLATM2, DLATM3
  513. * ..
  514. * .. External Subroutines ..
  515. EXTERNAL DLATM1, DSCAL, XERBLA
  516. * ..
  517. * .. Intrinsic Functions ..
  518. INTRINSIC ABS, MAX, MIN, MOD
  519. * ..
  520. * .. Executable Statements ..
  521. *
  522. * 1) Decode and Test the input parameters.
  523. * Initialize flags & seed.
  524. *
  525. INFO = 0
  526. *
  527. * Quick return if possible
  528. *
  529. IF( M.EQ.0 .OR. N.EQ.0 )
  530. $ RETURN
  531. *
  532. * Decode DIST
  533. *
  534. IF( LSAME( DIST, 'U' ) ) THEN
  535. IDIST = 1
  536. ELSE IF( LSAME( DIST, 'S' ) ) THEN
  537. IDIST = 2
  538. ELSE IF( LSAME( DIST, 'N' ) ) THEN
  539. IDIST = 3
  540. ELSE
  541. IDIST = -1
  542. END IF
  543. *
  544. * Decode SYM
  545. *
  546. IF( LSAME( SYM, 'S' ) ) THEN
  547. ISYM = 0
  548. ELSE IF( LSAME( SYM, 'N' ) ) THEN
  549. ISYM = 1
  550. ELSE IF( LSAME( SYM, 'H' ) ) THEN
  551. ISYM = 0
  552. ELSE
  553. ISYM = -1
  554. END IF
  555. *
  556. * Decode RSIGN
  557. *
  558. IF( LSAME( RSIGN, 'F' ) ) THEN
  559. IRSIGN = 0
  560. ELSE IF( LSAME( RSIGN, 'T' ) ) THEN
  561. IRSIGN = 1
  562. ELSE
  563. IRSIGN = -1
  564. END IF
  565. *
  566. * Decode PIVTNG
  567. *
  568. IF( LSAME( PIVTNG, 'N' ) ) THEN
  569. IPVTNG = 0
  570. ELSE IF( LSAME( PIVTNG, ' ' ) ) THEN
  571. IPVTNG = 0
  572. ELSE IF( LSAME( PIVTNG, 'L' ) ) THEN
  573. IPVTNG = 1
  574. NPVTS = M
  575. ELSE IF( LSAME( PIVTNG, 'R' ) ) THEN
  576. IPVTNG = 2
  577. NPVTS = N
  578. ELSE IF( LSAME( PIVTNG, 'B' ) ) THEN
  579. IPVTNG = 3
  580. NPVTS = MIN( N, M )
  581. ELSE IF( LSAME( PIVTNG, 'F' ) ) THEN
  582. IPVTNG = 3
  583. NPVTS = MIN( N, M )
  584. ELSE
  585. IPVTNG = -1
  586. END IF
  587. *
  588. * Decode GRADE
  589. *
  590. IF( LSAME( GRADE, 'N' ) ) THEN
  591. IGRADE = 0
  592. ELSE IF( LSAME( GRADE, 'L' ) ) THEN
  593. IGRADE = 1
  594. ELSE IF( LSAME( GRADE, 'R' ) ) THEN
  595. IGRADE = 2
  596. ELSE IF( LSAME( GRADE, 'B' ) ) THEN
  597. IGRADE = 3
  598. ELSE IF( LSAME( GRADE, 'E' ) ) THEN
  599. IGRADE = 4
  600. ELSE IF( LSAME( GRADE, 'H' ) .OR. LSAME( GRADE, 'S' ) ) THEN
  601. IGRADE = 5
  602. ELSE
  603. IGRADE = -1
  604. END IF
  605. *
  606. * Decode PACK
  607. *
  608. IF( LSAME( PACK, 'N' ) ) THEN
  609. IPACK = 0
  610. ELSE IF( LSAME( PACK, 'U' ) ) THEN
  611. IPACK = 1
  612. ELSE IF( LSAME( PACK, 'L' ) ) THEN
  613. IPACK = 2
  614. ELSE IF( LSAME( PACK, 'C' ) ) THEN
  615. IPACK = 3
  616. ELSE IF( LSAME( PACK, 'R' ) ) THEN
  617. IPACK = 4
  618. ELSE IF( LSAME( PACK, 'B' ) ) THEN
  619. IPACK = 5
  620. ELSE IF( LSAME( PACK, 'Q' ) ) THEN
  621. IPACK = 6
  622. ELSE IF( LSAME( PACK, 'Z' ) ) THEN
  623. IPACK = 7
  624. ELSE
  625. IPACK = -1
  626. END IF
  627. *
  628. * Set certain internal parameters
  629. *
  630. MNMIN = MIN( M, N )
  631. KLL = MIN( KL, M-1 )
  632. KUU = MIN( KU, N-1 )
  633. *
  634. * If inv(DL) is used, check to see if DL has a zero entry.
  635. *
  636. DZERO = .FALSE.
  637. IF( IGRADE.EQ.4 .AND. MODEL.EQ.0 ) THEN
  638. DO 10 I = 1, M
  639. IF( DL( I ).EQ.ZERO )
  640. $ DZERO = .TRUE.
  641. 10 CONTINUE
  642. END IF
  643. *
  644. * Check values in IPIVOT
  645. *
  646. BADPVT = .FALSE.
  647. IF( IPVTNG.GT.0 ) THEN
  648. DO 20 J = 1, NPVTS
  649. IF( IPIVOT( J ).LE.0 .OR. IPIVOT( J ).GT.NPVTS )
  650. $ BADPVT = .TRUE.
  651. 20 CONTINUE
  652. END IF
  653. *
  654. * Set INFO if an error
  655. *
  656. IF( M.LT.0 ) THEN
  657. INFO = -1
  658. ELSE IF( M.NE.N .AND. ISYM.EQ.0 ) THEN
  659. INFO = -1
  660. ELSE IF( N.LT.0 ) THEN
  661. INFO = -2
  662. ELSE IF( IDIST.EQ.-1 ) THEN
  663. INFO = -3
  664. ELSE IF( ISYM.EQ.-1 ) THEN
  665. INFO = -5
  666. ELSE IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN
  667. INFO = -7
  668. ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
  669. $ COND.LT.ONE ) THEN
  670. INFO = -8
  671. ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
  672. $ IRSIGN.EQ.-1 ) THEN
  673. INFO = -10
  674. ELSE IF( IGRADE.EQ.-1 .OR. ( IGRADE.EQ.4 .AND. M.NE.N ) .OR.
  675. $ ( ( IGRADE.GE.1 .AND. IGRADE.LE.4 ) .AND. ISYM.EQ.0 ) )
  676. $ THEN
  677. INFO = -11
  678. ELSE IF( IGRADE.EQ.4 .AND. DZERO ) THEN
  679. INFO = -12
  680. ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR.
  681. $ IGRADE.EQ.5 ) .AND. ( MODEL.LT.-6 .OR. MODEL.GT.6 ) )
  682. $ THEN
  683. INFO = -13
  684. ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR.
  685. $ IGRADE.EQ.5 ) .AND. ( MODEL.NE.-6 .AND. MODEL.NE.0 .AND.
  686. $ MODEL.NE.6 ) .AND. CONDL.LT.ONE ) THEN
  687. INFO = -14
  688. ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND.
  689. $ ( MODER.LT.-6 .OR. MODER.GT.6 ) ) THEN
  690. INFO = -16
  691. ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND.
  692. $ ( MODER.NE.-6 .AND. MODER.NE.0 .AND. MODER.NE.6 ) .AND.
  693. $ CONDR.LT.ONE ) THEN
  694. INFO = -17
  695. ELSE IF( IPVTNG.EQ.-1 .OR. ( IPVTNG.EQ.3 .AND. M.NE.N ) .OR.
  696. $ ( ( IPVTNG.EQ.1 .OR. IPVTNG.EQ.2 ) .AND. ISYM.EQ.0 ) )
  697. $ THEN
  698. INFO = -18
  699. ELSE IF( IPVTNG.NE.0 .AND. BADPVT ) THEN
  700. INFO = -19
  701. ELSE IF( KL.LT.0 ) THEN
  702. INFO = -20
  703. ELSE IF( KU.LT.0 .OR. ( ISYM.EQ.0 .AND. KL.NE.KU ) ) THEN
  704. INFO = -21
  705. ELSE IF( SPARSE.LT.ZERO .OR. SPARSE.GT.ONE ) THEN
  706. INFO = -22
  707. ELSE IF( IPACK.EQ.-1 .OR. ( ( IPACK.EQ.1 .OR. IPACK.EQ.2 .OR.
  708. $ IPACK.EQ.5 .OR. IPACK.EQ.6 ) .AND. ISYM.EQ.1 ) .OR.
  709. $ ( IPACK.EQ.3 .AND. ISYM.EQ.1 .AND. ( KL.NE.0 .OR. M.NE.
  710. $ N ) ) .OR. ( IPACK.EQ.4 .AND. ISYM.EQ.1 .AND. ( KU.NE.
  711. $ 0 .OR. M.NE.N ) ) ) THEN
  712. INFO = -24
  713. ELSE IF( ( ( IPACK.EQ.0 .OR. IPACK.EQ.1 .OR. IPACK.EQ.2 ) .AND.
  714. $ LDA.LT.MAX( 1, M ) ) .OR. ( ( IPACK.EQ.3 .OR. IPACK.EQ.
  715. $ 4 ) .AND. LDA.LT.1 ) .OR. ( ( IPACK.EQ.5 .OR. IPACK.EQ.
  716. $ 6 ) .AND. LDA.LT.KUU+1 ) .OR.
  717. $ ( IPACK.EQ.7 .AND. LDA.LT.KLL+KUU+1 ) ) THEN
  718. INFO = -26
  719. END IF
  720. *
  721. IF( INFO.NE.0 ) THEN
  722. CALL XERBLA( 'DLATMR', -INFO )
  723. RETURN
  724. END IF
  725. *
  726. * Decide if we can pivot consistently
  727. *
  728. FULBND = .FALSE.
  729. IF( KUU.EQ.N-1 .AND. KLL.EQ.M-1 )
  730. $ FULBND = .TRUE.
  731. *
  732. * Initialize random number generator
  733. *
  734. DO 30 I = 1, 4
  735. ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 )
  736. 30 CONTINUE
  737. *
  738. ISEED( 4 ) = 2*( ISEED( 4 ) / 2 ) + 1
  739. *
  740. * 2) Set up D, DL, and DR, if indicated.
  741. *
  742. * Compute D according to COND and MODE
  743. *
  744. CALL DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, INFO )
  745. IF( INFO.NE.0 ) THEN
  746. INFO = 1
  747. RETURN
  748. END IF
  749. IF( MODE.NE.0 .AND. MODE.NE.-6 .AND. MODE.NE.6 ) THEN
  750. *
  751. * Scale by DMAX
  752. *
  753. TEMP = ABS( D( 1 ) )
  754. DO 40 I = 2, MNMIN
  755. TEMP = MAX( TEMP, ABS( D( I ) ) )
  756. 40 CONTINUE
  757. IF( TEMP.EQ.ZERO .AND. DMAX.NE.ZERO ) THEN
  758. INFO = 2
  759. RETURN
  760. END IF
  761. IF( TEMP.NE.ZERO ) THEN
  762. ALPHA = DMAX / TEMP
  763. ELSE
  764. ALPHA = ONE
  765. END IF
  766. DO 50 I = 1, MNMIN
  767. D( I ) = ALPHA*D( I )
  768. 50 CONTINUE
  769. *
  770. END IF
  771. *
  772. * Compute DL if grading set
  773. *
  774. IF( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. IGRADE.EQ.
  775. $ 5 ) THEN
  776. CALL DLATM1( MODEL, CONDL, 0, IDIST, ISEED, DL, M, INFO )
  777. IF( INFO.NE.0 ) THEN
  778. INFO = 3
  779. RETURN
  780. END IF
  781. END IF
  782. *
  783. * Compute DR if grading set
  784. *
  785. IF( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) THEN
  786. CALL DLATM1( MODER, CONDR, 0, IDIST, ISEED, DR, N, INFO )
  787. IF( INFO.NE.0 ) THEN
  788. INFO = 4
  789. RETURN
  790. END IF
  791. END IF
  792. *
  793. * 3) Generate IWORK if pivoting
  794. *
  795. IF( IPVTNG.GT.0 ) THEN
  796. DO 60 I = 1, NPVTS
  797. IWORK( I ) = I
  798. 60 CONTINUE
  799. IF( FULBND ) THEN
  800. DO 70 I = 1, NPVTS
  801. K = IPIVOT( I )
  802. J = IWORK( I )
  803. IWORK( I ) = IWORK( K )
  804. IWORK( K ) = J
  805. 70 CONTINUE
  806. ELSE
  807. DO 80 I = NPVTS, 1, -1
  808. K = IPIVOT( I )
  809. J = IWORK( I )
  810. IWORK( I ) = IWORK( K )
  811. IWORK( K ) = J
  812. 80 CONTINUE
  813. END IF
  814. END IF
  815. *
  816. * 4) Generate matrices for each kind of PACKing
  817. * Always sweep matrix columnwise (if symmetric, upper
  818. * half only) so that matrix generated does not depend
  819. * on PACK
  820. *
  821. IF( FULBND ) THEN
  822. *
  823. * Use DLATM3 so matrices generated with differing PIVOTing only
  824. * differ only in the order of their rows and/or columns.
  825. *
  826. IF( IPACK.EQ.0 ) THEN
  827. IF( ISYM.EQ.0 ) THEN
  828. DO 100 J = 1, N
  829. DO 90 I = 1, J
  830. TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
  831. $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
  832. $ IWORK, SPARSE )
  833. A( ISUB, JSUB ) = TEMP
  834. A( JSUB, ISUB ) = TEMP
  835. 90 CONTINUE
  836. 100 CONTINUE
  837. ELSE IF( ISYM.EQ.1 ) THEN
  838. DO 120 J = 1, N
  839. DO 110 I = 1, M
  840. TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
  841. $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
  842. $ IWORK, SPARSE )
  843. A( ISUB, JSUB ) = TEMP
  844. 110 CONTINUE
  845. 120 CONTINUE
  846. END IF
  847. *
  848. ELSE IF( IPACK.EQ.1 ) THEN
  849. *
  850. DO 140 J = 1, N
  851. DO 130 I = 1, J
  852. TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
  853. $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
  854. $ SPARSE )
  855. MNSUB = MIN( ISUB, JSUB )
  856. MXSUB = MAX( ISUB, JSUB )
  857. A( MNSUB, MXSUB ) = TEMP
  858. IF( MNSUB.NE.MXSUB )
  859. $ A( MXSUB, MNSUB ) = ZERO
  860. 130 CONTINUE
  861. 140 CONTINUE
  862. *
  863. ELSE IF( IPACK.EQ.2 ) THEN
  864. *
  865. DO 160 J = 1, N
  866. DO 150 I = 1, J
  867. TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
  868. $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
  869. $ SPARSE )
  870. MNSUB = MIN( ISUB, JSUB )
  871. MXSUB = MAX( ISUB, JSUB )
  872. A( MXSUB, MNSUB ) = TEMP
  873. IF( MNSUB.NE.MXSUB )
  874. $ A( MNSUB, MXSUB ) = ZERO
  875. 150 CONTINUE
  876. 160 CONTINUE
  877. *
  878. ELSE IF( IPACK.EQ.3 ) THEN
  879. *
  880. DO 180 J = 1, N
  881. DO 170 I = 1, J
  882. TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
  883. $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
  884. $ SPARSE )
  885. *
  886. * Compute K = location of (ISUB,JSUB) entry in packed
  887. * array
  888. *
  889. MNSUB = MIN( ISUB, JSUB )
  890. MXSUB = MAX( ISUB, JSUB )
  891. K = MXSUB*( MXSUB-1 ) / 2 + MNSUB
  892. *
  893. * Convert K to (IISUB,JJSUB) location
  894. *
  895. JJSUB = ( K-1 ) / LDA + 1
  896. IISUB = K - LDA*( JJSUB-1 )
  897. *
  898. A( IISUB, JJSUB ) = TEMP
  899. 170 CONTINUE
  900. 180 CONTINUE
  901. *
  902. ELSE IF( IPACK.EQ.4 ) THEN
  903. *
  904. DO 200 J = 1, N
  905. DO 190 I = 1, J
  906. TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
  907. $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
  908. $ SPARSE )
  909. *
  910. * Compute K = location of (I,J) entry in packed array
  911. *
  912. MNSUB = MIN( ISUB, JSUB )
  913. MXSUB = MAX( ISUB, JSUB )
  914. IF( MNSUB.EQ.1 ) THEN
  915. K = MXSUB
  916. ELSE
  917. K = N*( N+1 ) / 2 - ( N-MNSUB+1 )*( N-MNSUB+2 ) /
  918. $ 2 + MXSUB - MNSUB + 1
  919. END IF
  920. *
  921. * Convert K to (IISUB,JJSUB) location
  922. *
  923. JJSUB = ( K-1 ) / LDA + 1
  924. IISUB = K - LDA*( JJSUB-1 )
  925. *
  926. A( IISUB, JJSUB ) = TEMP
  927. 190 CONTINUE
  928. 200 CONTINUE
  929. *
  930. ELSE IF( IPACK.EQ.5 ) THEN
  931. *
  932. DO 220 J = 1, N
  933. DO 210 I = J - KUU, J
  934. IF( I.LT.1 ) THEN
  935. A( J-I+1, I+N ) = ZERO
  936. ELSE
  937. TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
  938. $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
  939. $ IWORK, SPARSE )
  940. MNSUB = MIN( ISUB, JSUB )
  941. MXSUB = MAX( ISUB, JSUB )
  942. A( MXSUB-MNSUB+1, MNSUB ) = TEMP
  943. END IF
  944. 210 CONTINUE
  945. 220 CONTINUE
  946. *
  947. ELSE IF( IPACK.EQ.6 ) THEN
  948. *
  949. DO 240 J = 1, N
  950. DO 230 I = J - KUU, J
  951. TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
  952. $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
  953. $ SPARSE )
  954. MNSUB = MIN( ISUB, JSUB )
  955. MXSUB = MAX( ISUB, JSUB )
  956. A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP
  957. 230 CONTINUE
  958. 240 CONTINUE
  959. *
  960. ELSE IF( IPACK.EQ.7 ) THEN
  961. *
  962. IF( ISYM.EQ.0 ) THEN
  963. DO 260 J = 1, N
  964. DO 250 I = J - KUU, J
  965. TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
  966. $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
  967. $ IWORK, SPARSE )
  968. MNSUB = MIN( ISUB, JSUB )
  969. MXSUB = MAX( ISUB, JSUB )
  970. A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP
  971. IF( I.LT.1 )
  972. $ A( J-I+1+KUU, I+N ) = ZERO
  973. IF( I.GE.1 .AND. MNSUB.NE.MXSUB )
  974. $ A( MXSUB-MNSUB+1+KUU, MNSUB ) = TEMP
  975. 250 CONTINUE
  976. 260 CONTINUE
  977. ELSE IF( ISYM.EQ.1 ) THEN
  978. DO 280 J = 1, N
  979. DO 270 I = J - KUU, J + KLL
  980. TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
  981. $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
  982. $ IWORK, SPARSE )
  983. A( ISUB-JSUB+KUU+1, JSUB ) = TEMP
  984. 270 CONTINUE
  985. 280 CONTINUE
  986. END IF
  987. *
  988. END IF
  989. *
  990. ELSE
  991. *
  992. * Use DLATM2
  993. *
  994. IF( IPACK.EQ.0 ) THEN
  995. IF( ISYM.EQ.0 ) THEN
  996. DO 300 J = 1, N
  997. DO 290 I = 1, J
  998. A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST,
  999. $ ISEED, D, IGRADE, DL, DR, IPVTNG,
  1000. $ IWORK, SPARSE )
  1001. A( J, I ) = A( I, J )
  1002. 290 CONTINUE
  1003. 300 CONTINUE
  1004. ELSE IF( ISYM.EQ.1 ) THEN
  1005. DO 320 J = 1, N
  1006. DO 310 I = 1, M
  1007. A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST,
  1008. $ ISEED, D, IGRADE, DL, DR, IPVTNG,
  1009. $ IWORK, SPARSE )
  1010. 310 CONTINUE
  1011. 320 CONTINUE
  1012. END IF
  1013. *
  1014. ELSE IF( IPACK.EQ.1 ) THEN
  1015. *
  1016. DO 340 J = 1, N
  1017. DO 330 I = 1, J
  1018. A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST, ISEED,
  1019. $ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
  1020. IF( I.NE.J )
  1021. $ A( J, I ) = ZERO
  1022. 330 CONTINUE
  1023. 340 CONTINUE
  1024. *
  1025. ELSE IF( IPACK.EQ.2 ) THEN
  1026. *
  1027. DO 360 J = 1, N
  1028. DO 350 I = 1, J
  1029. A( J, I ) = DLATM2( M, N, I, J, KL, KU, IDIST, ISEED,
  1030. $ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
  1031. IF( I.NE.J )
  1032. $ A( I, J ) = ZERO
  1033. 350 CONTINUE
  1034. 360 CONTINUE
  1035. *
  1036. ELSE IF( IPACK.EQ.3 ) THEN
  1037. *
  1038. ISUB = 0
  1039. JSUB = 1
  1040. DO 380 J = 1, N
  1041. DO 370 I = 1, J
  1042. ISUB = ISUB + 1
  1043. IF( ISUB.GT.LDA ) THEN
  1044. ISUB = 1
  1045. JSUB = JSUB + 1
  1046. END IF
  1047. A( ISUB, JSUB ) = DLATM2( M, N, I, J, KL, KU, IDIST,
  1048. $ ISEED, D, IGRADE, DL, DR, IPVTNG,
  1049. $ IWORK, SPARSE )
  1050. 370 CONTINUE
  1051. 380 CONTINUE
  1052. *
  1053. ELSE IF( IPACK.EQ.4 ) THEN
  1054. *
  1055. IF( ISYM.EQ.0 ) THEN
  1056. DO 400 J = 1, N
  1057. DO 390 I = 1, J
  1058. *
  1059. * Compute K = location of (I,J) entry in packed array
  1060. *
  1061. IF( I.EQ.1 ) THEN
  1062. K = J
  1063. ELSE
  1064. K = N*( N+1 ) / 2 - ( N-I+1 )*( N-I+2 ) / 2 +
  1065. $ J - I + 1
  1066. END IF
  1067. *
  1068. * Convert K to (ISUB,JSUB) location
  1069. *
  1070. JSUB = ( K-1 ) / LDA + 1
  1071. ISUB = K - LDA*( JSUB-1 )
  1072. *
  1073. A( ISUB, JSUB ) = DLATM2( M, N, I, J, KL, KU,
  1074. $ IDIST, ISEED, D, IGRADE, DL, DR,
  1075. $ IPVTNG, IWORK, SPARSE )
  1076. 390 CONTINUE
  1077. 400 CONTINUE
  1078. ELSE
  1079. ISUB = 0
  1080. JSUB = 1
  1081. DO 420 J = 1, N
  1082. DO 410 I = J, M
  1083. ISUB = ISUB + 1
  1084. IF( ISUB.GT.LDA ) THEN
  1085. ISUB = 1
  1086. JSUB = JSUB + 1
  1087. END IF
  1088. A( ISUB, JSUB ) = DLATM2( M, N, I, J, KL, KU,
  1089. $ IDIST, ISEED, D, IGRADE, DL, DR,
  1090. $ IPVTNG, IWORK, SPARSE )
  1091. 410 CONTINUE
  1092. 420 CONTINUE
  1093. END IF
  1094. *
  1095. ELSE IF( IPACK.EQ.5 ) THEN
  1096. *
  1097. DO 440 J = 1, N
  1098. DO 430 I = J - KUU, J
  1099. IF( I.LT.1 ) THEN
  1100. A( J-I+1, I+N ) = ZERO
  1101. ELSE
  1102. A( J-I+1, I ) = DLATM2( M, N, I, J, KL, KU, IDIST,
  1103. $ ISEED, D, IGRADE, DL, DR, IPVTNG,
  1104. $ IWORK, SPARSE )
  1105. END IF
  1106. 430 CONTINUE
  1107. 440 CONTINUE
  1108. *
  1109. ELSE IF( IPACK.EQ.6 ) THEN
  1110. *
  1111. DO 460 J = 1, N
  1112. DO 450 I = J - KUU, J
  1113. A( I-J+KUU+1, J ) = DLATM2( M, N, I, J, KL, KU, IDIST,
  1114. $ ISEED, D, IGRADE, DL, DR, IPVTNG,
  1115. $ IWORK, SPARSE )
  1116. 450 CONTINUE
  1117. 460 CONTINUE
  1118. *
  1119. ELSE IF( IPACK.EQ.7 ) THEN
  1120. *
  1121. IF( ISYM.EQ.0 ) THEN
  1122. DO 480 J = 1, N
  1123. DO 470 I = J - KUU, J
  1124. A( I-J+KUU+1, J ) = DLATM2( M, N, I, J, KL, KU,
  1125. $ IDIST, ISEED, D, IGRADE, DL,
  1126. $ DR, IPVTNG, IWORK, SPARSE )
  1127. IF( I.LT.1 )
  1128. $ A( J-I+1+KUU, I+N ) = ZERO
  1129. IF( I.GE.1 .AND. I.NE.J )
  1130. $ A( J-I+1+KUU, I ) = A( I-J+KUU+1, J )
  1131. 470 CONTINUE
  1132. 480 CONTINUE
  1133. ELSE IF( ISYM.EQ.1 ) THEN
  1134. DO 500 J = 1, N
  1135. DO 490 I = J - KUU, J + KLL
  1136. A( I-J+KUU+1, J ) = DLATM2( M, N, I, J, KL, KU,
  1137. $ IDIST, ISEED, D, IGRADE, DL,
  1138. $ DR, IPVTNG, IWORK, SPARSE )
  1139. 490 CONTINUE
  1140. 500 CONTINUE
  1141. END IF
  1142. *
  1143. END IF
  1144. *
  1145. END IF
  1146. *
  1147. * 5) Scaling the norm
  1148. *
  1149. IF( IPACK.EQ.0 ) THEN
  1150. ONORM = DLANGE( 'M', M, N, A, LDA, TEMPA )
  1151. ELSE IF( IPACK.EQ.1 ) THEN
  1152. ONORM = DLANSY( 'M', 'U', N, A, LDA, TEMPA )
  1153. ELSE IF( IPACK.EQ.2 ) THEN
  1154. ONORM = DLANSY( 'M', 'L', N, A, LDA, TEMPA )
  1155. ELSE IF( IPACK.EQ.3 ) THEN
  1156. ONORM = DLANSP( 'M', 'U', N, A, TEMPA )
  1157. ELSE IF( IPACK.EQ.4 ) THEN
  1158. ONORM = DLANSP( 'M', 'L', N, A, TEMPA )
  1159. ELSE IF( IPACK.EQ.5 ) THEN
  1160. ONORM = DLANSB( 'M', 'L', N, KLL, A, LDA, TEMPA )
  1161. ELSE IF( IPACK.EQ.6 ) THEN
  1162. ONORM = DLANSB( 'M', 'U', N, KUU, A, LDA, TEMPA )
  1163. ELSE IF( IPACK.EQ.7 ) THEN
  1164. ONORM = DLANGB( 'M', N, KLL, KUU, A, LDA, TEMPA )
  1165. END IF
  1166. *
  1167. IF( ANORM.GE.ZERO ) THEN
  1168. *
  1169. IF( ANORM.GT.ZERO .AND. ONORM.EQ.ZERO ) THEN
  1170. *
  1171. * Desired scaling impossible
  1172. *
  1173. INFO = 5
  1174. RETURN
  1175. *
  1176. ELSE IF( ( ANORM.GT.ONE .AND. ONORM.LT.ONE ) .OR.
  1177. $ ( ANORM.LT.ONE .AND. ONORM.GT.ONE ) ) THEN
  1178. *
  1179. * Scale carefully to avoid over / underflow
  1180. *
  1181. IF( IPACK.LE.2 ) THEN
  1182. DO 510 J = 1, N
  1183. CALL DSCAL( M, ONE / ONORM, A( 1, J ), 1 )
  1184. CALL DSCAL( M, ANORM, A( 1, J ), 1 )
  1185. 510 CONTINUE
  1186. *
  1187. ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN
  1188. *
  1189. CALL DSCAL( N*( N+1 ) / 2, ONE / ONORM, A, 1 )
  1190. CALL DSCAL( N*( N+1 ) / 2, ANORM, A, 1 )
  1191. *
  1192. ELSE IF( IPACK.GE.5 ) THEN
  1193. *
  1194. DO 520 J = 1, N
  1195. CALL DSCAL( KLL+KUU+1, ONE / ONORM, A( 1, J ), 1 )
  1196. CALL DSCAL( KLL+KUU+1, ANORM, A( 1, J ), 1 )
  1197. 520 CONTINUE
  1198. *
  1199. END IF
  1200. *
  1201. ELSE
  1202. *
  1203. * Scale straightforwardly
  1204. *
  1205. IF( IPACK.LE.2 ) THEN
  1206. DO 530 J = 1, N
  1207. CALL DSCAL( M, ANORM / ONORM, A( 1, J ), 1 )
  1208. 530 CONTINUE
  1209. *
  1210. ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN
  1211. *
  1212. CALL DSCAL( N*( N+1 ) / 2, ANORM / ONORM, A, 1 )
  1213. *
  1214. ELSE IF( IPACK.GE.5 ) THEN
  1215. *
  1216. DO 540 J = 1, N
  1217. CALL DSCAL( KLL+KUU+1, ANORM / ONORM, A( 1, J ), 1 )
  1218. 540 CONTINUE
  1219. END IF
  1220. *
  1221. END IF
  1222. *
  1223. END IF
  1224. *
  1225. * End of DLATMR
  1226. *
  1227. END