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