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