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