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