138
139
140
141
142
143
144 CHARACTER DIAG, TRANS, UPLO
145 INTEGER IMAT, INFO, LDA, N
146
147
148 INTEGER ISEED( 4 )
149 REAL RWORK( * )
150 COMPLEX A( LDA, * ), B( * ), WORK( * )
151
152
153
154
155
156 REAL ONE, TWO, ZERO
157 parameter( one = 1.0e+0, two = 2.0e+0, zero = 0.0e+0 )
158
159
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
170 LOGICAL LSAME
171 INTEGER ICAMAX
172 REAL SLAMCH, SLARND
173 COMPLEX CLARND
175
176
179
180
181 INTRINSIC abs, cmplx, conjg, max, real, sqrt
182
183
184
185 path( 1: 1 ) = 'Complex precision'
186 path( 2: 3 ) = 'TR'
187 unfl =
slamch(
'Safe minimum' )
189 smlnum = unfl
190 bignum = ( one-ulp ) / smlnum
191 IF( ( imat.GE.7 .AND. imat.LE.10 ) .OR. imat.EQ.18 ) THEN
192 diag = 'U'
193 ELSE
194 diag = 'N'
195 END IF
196 info = 0
197
198
199
200 IF( n.LE.0 )
201 $ RETURN
202
203
204
205 upper =
lsame( uplo,
'U' )
206 IF( upper ) THEN
207 CALL clatb4( path, imat, n, n,
TYPE, KL, KU, ANORM, MODE,
208 $ CNDNUM, DIST )
209 ELSE
210 CALL clatb4( path, -imat, n, n,
TYPE, KL, KU, ANORM, MODE,
211 $ CNDNUM, DIST )
212 END IF
213
214
215
216 IF( imat.LE.6 ) THEN
217 CALL clatms( n, n, dist, iseed,
TYPE, RWORK, MODE, CNDNUM,
218 $ ANORM, KL, KU, 'No packing', A, LDA, WORK, INFO )
219
220
221
222
223
224
225 ELSE IF( imat.EQ.7 ) THEN
226 IF( upper ) THEN
227 DO 20 j = 1, n
228 DO 10 i = 1, j - 1
229 a( i, j ) = zero
230 10 CONTINUE
231 a( j, j ) = j
232 20 CONTINUE
233 ELSE
234 DO 40 j = 1, n
235 a( j, j ) = j
236 DO 30 i = j + 1, n
237 a( i, j ) = zero
238 30 CONTINUE
239 40 CONTINUE
240 END IF
241
242
243
244
245
246
247
248 ELSE IF( imat.LE.10 ) THEN
249 IF( upper ) THEN
250 DO 60 j = 1, n
251 DO 50 i = 1, j - 1
252 a( i, j ) = zero
253 50 CONTINUE
254 a( j, j ) = j
255 60 CONTINUE
256 ELSE
257 DO 80 j = 1, n
258 a( j, j ) = j
259 DO 70 i = j + 1, n
260 a( i, j ) = zero
261 70 CONTINUE
262 80 CONTINUE
263 END IF
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323 star1 = 0.25*
clarnd( 5, iseed )
324 sfac = 0.5
325 plus1 = sfac*
clarnd( 5, iseed )
326 DO 90 j = 1, n, 2
327 plus2 = star1 / plus1
328 work( j ) = plus1
329 work( n+j ) = star1
330 IF( j+1.LE.n ) THEN
331 work( j+1 ) = plus2
332 work( n+j+1 ) = zero
333 plus1 = star1 / plus2
335 IF( rexp.LT.zero ) THEN
336 star1 = -sfac**( one-rexp )*
clarnd( 5, iseed )
337 ELSE
338 star1 = sfac**( one+rexp )*
clarnd( 5, iseed )
339 END IF
340 END IF
341 90 CONTINUE
342
343 x = sqrt( cndnum ) - 1 / sqrt( cndnum )
344 IF( n.GT.2 ) THEN
345 y = sqrt( 2. / ( n-2 ) )*x
346 ELSE
347 y = zero
348 END IF
349 z = x*x
350
351 IF( upper ) THEN
352 IF( n.GT.3 ) THEN
353 CALL ccopy( n-3, work, 1, a( 2, 3 ), lda+1 )
354 IF( n.GT.4 )
355 $
CALL ccopy( n-4, work( n+1 ), 1, a( 2, 4 ), lda+1 )
356 END IF
357 DO 100 j = 2, n - 1
358 a( 1, j ) = y
359 a( j, n ) = y
360 100 CONTINUE
361 a( 1, n ) = z
362 ELSE
363 IF( n.GT.3 ) THEN
364 CALL ccopy( n-3, work, 1, a( 3, 2 ), lda+1 )
365 IF( n.GT.4 )
366 $
CALL ccopy( n-4, work( n+1 ), 1, a( 4, 2 ), lda+1 )
367 END IF
368 DO 110 j = 2, n - 1
369 a( j, 1 ) = y
370 a( n, j ) = y
371 110 CONTINUE
372 a( n, 1 ) = z
373 END IF
374
375
376
377 IF( upper ) THEN
378 DO 120 j = 1, n - 1
379 ra = a( j, j+1 )
380 rb = 2.0
381 CALL crotg( ra, rb, c, s )
382
383
384
385 IF( n.GT.j+1 )
386 $
CALL crot( n-j-1, a( j, j+2 ), lda, a( j+1, j+2 ),
387 $ lda, c, s )
388
389
390
391 IF( j.GT.1 )
392 $
CALL crot( j-1, a( 1, j+1 ), 1, a( 1, j ), 1, -c, -s )
393
394
395
396 a( j, j+1 ) = -a( j, j+1 )
397 120 CONTINUE
398 ELSE
399 DO 130 j = 1, n - 1
400 ra = a( j+1, j )
401 rb = 2.0
402 CALL crotg( ra, rb, c, s )
403 s = conjg( s )
404
405
406
407 IF( n.GT.j+1 )
408 $
CALL crot( n-j-1, a( j+2, j+1 ), 1, a( j+2, j ), 1, c,
409 $ -s )
410
411
412
413 IF( j.GT.1 )
414 $
CALL crot( j-1, a( j, 1 ), lda, a( j+1, 1 ), lda, -c,
415 $ s )
416
417
418
419 a( j+1, j ) = -a( j+1, j )
420 130 CONTINUE
421 END IF
422
423
424
425
426
427 ELSE IF( imat.EQ.11 ) THEN
428
429
430
431
432
433 IF( upper ) THEN
434 DO 140 j = 1, n
435 CALL clarnv( 4, iseed, j-1, a( 1, j ) )
436 a( j, j ) =
clarnd( 5, iseed )*two
437 140 CONTINUE
438 ELSE
439 DO 150 j = 1, n
440 IF( j.LT.n )
441 $
CALL clarnv( 4, iseed, n-j, a( j+1, j ) )
442 a( j, j ) =
clarnd( 5, iseed )*two
443 150 CONTINUE
444 END IF
445
446
447
448 CALL clarnv( 2, iseed, n, b )
450 bnorm = abs( b( iy ) )
451 bscal = bignum / max( one, bnorm )
452 CALL csscal( n, bscal, b, 1 )
453
454 ELSE IF( imat.EQ.12 ) THEN
455
456
457
458
459
460 CALL clarnv( 2, iseed, n, b )
461 tscal = one / max( one, real( n-1 ) )
462 IF( upper ) THEN
463 DO 160 j = 1, n
464 CALL clarnv( 4, iseed, j-1, a( 1, j ) )
465 CALL csscal( j-1, tscal, a( 1, j ), 1 )
466 a( j, j ) =
clarnd( 5, iseed )
467 160 CONTINUE
468 a( n, n ) = smlnum*a( n, n )
469 ELSE
470 DO 170 j = 1, n
471 IF( j.LT.n ) THEN
472 CALL clarnv( 4, iseed, n-j, a( j+1, j ) )
473 CALL csscal( n-j, tscal, a( j+1, j ), 1 )
474 END IF
475 a( j, j ) =
clarnd( 5, iseed )
476 170 CONTINUE
477 a( 1, 1 ) = smlnum*a( 1, 1 )
478 END IF
479
480 ELSE IF( imat.EQ.13 ) THEN
481
482
483
484
485
486 CALL clarnv( 2, iseed, n, b )
487 IF( upper ) THEN
488 DO 180 j = 1, n
489 CALL clarnv( 4, iseed, j-1, a( 1, j ) )
490 a( j, j ) =
clarnd( 5, iseed )
491 180 CONTINUE
492 a( n, n ) = smlnum*a( n, n )
493 ELSE
494 DO 190 j = 1, n
495 IF( j.LT.n )
496 $
CALL clarnv( 4, iseed, n-j, a( j+1, j ) )
497 a( j, j ) =
clarnd( 5, iseed )
498 190 CONTINUE
499 a( 1, 1 ) = smlnum*a( 1, 1 )
500 END IF
501
502 ELSE IF( imat.EQ.14 ) THEN
503
504
505
506
507
508 IF( upper ) THEN
509 jcount = 1
510 DO 210 j = n, 1, -1
511 DO 200 i = 1, j - 1
512 a( i, j ) = zero
513 200 CONTINUE
514 IF( jcount.LE.2 ) THEN
515 a( j, j ) = smlnum*
clarnd( 5, iseed )
516 ELSE
517 a( j, j ) =
clarnd( 5, iseed )
518 END IF
519 jcount = jcount + 1
520 IF( jcount.GT.4 )
521 $ jcount = 1
522 210 CONTINUE
523 ELSE
524 jcount = 1
525 DO 230 j = 1, n
526 DO 220 i = j + 1, n
527 a( i, j ) = zero
528 220 CONTINUE
529 IF( jcount.LE.2 ) THEN
530 a( j, j ) = smlnum*
clarnd( 5, iseed )
531 ELSE
532 a( j, j ) =
clarnd( 5, iseed )
533 END IF
534 jcount = jcount + 1
535 IF( jcount.GT.4 )
536 $ jcount = 1
537 230 CONTINUE
538 END IF
539
540
541
542 IF( upper ) THEN
543 b( 1 ) = zero
544 DO 240 i = n, 2, -2
545 b( i ) = zero
546 b( i-1 ) = smlnum*
clarnd( 5, iseed )
547 240 CONTINUE
548 ELSE
549 b( n ) = zero
550 DO 250 i = 1, n - 1, 2
551 b( i ) = zero
552 b( i+1 ) = smlnum*
clarnd( 5, iseed )
553 250 CONTINUE
554 END IF
555
556 ELSE IF( imat.EQ.15 ) THEN
557
558
559
560
561
562 texp = one / max( one, real( n-1 ) )
563 tscal = smlnum**texp
564 CALL clarnv( 4, iseed, n, b )
565 IF( upper ) THEN
566 DO 270 j = 1, n
567 DO 260 i = 1, j - 2
568 a( i, j ) = 0.
569 260 CONTINUE
570 IF( j.GT.1 )
571 $ a( j-1, j ) = cmplx( -one, -one )
572 a( j, j ) = tscal*
clarnd( 5, iseed )
573 270 CONTINUE
574 b( n ) = cmplx( one, one )
575 ELSE
576 DO 290 j = 1, n
577 DO 280 i = j + 2, n
578 a( i, j ) = 0.
579 280 CONTINUE
580 IF( j.LT.n )
581 $ a( j+1, j ) = cmplx( -one, -one )
582 a( j, j ) = tscal*
clarnd( 5, iseed )
583 290 CONTINUE
584 b( 1 ) = cmplx( one, one )
585 END IF
586
587 ELSE IF( imat.EQ.16 ) THEN
588
589
590
591 iy = n / 2 + 1
592 IF( upper ) THEN
593 DO 300 j = 1, n
594 CALL clarnv( 4, iseed, j-1, a( 1, j ) )
595 IF( j.NE.iy ) THEN
596 a( j, j ) =
clarnd( 5, iseed )*two
597 ELSE
598 a( j, j ) = zero
599 END IF
600 300 CONTINUE
601 ELSE
602 DO 310 j = 1, n
603 IF( j.LT.n )
604 $
CALL clarnv( 4, iseed, n-j, a( j+1, j ) )
605 IF( j.NE.iy ) THEN
606 a( j, j ) =
clarnd( 5, iseed )*two
607 ELSE
608 a( j, j ) = zero
609 END IF
610 310 CONTINUE
611 END IF
612 CALL clarnv( 2, iseed, n, b )
613 CALL csscal( n, two, b, 1 )
614
615 ELSE IF( imat.EQ.17 ) THEN
616
617
618
619
620
621
622 tscal = unfl / ulp
623 tscal = ( one-ulp ) / tscal
624 DO 330 j = 1, n
625 DO 320 i = 1, n
626 a( i, j ) = 0.
627 320 CONTINUE
628 330 CONTINUE
629 texp = one
630 IF( upper ) THEN
631 DO 340 j = n, 2, -2
632 a( 1, j ) = -tscal / real( n+1 )
633 a( j, j ) = one
634 b( j ) = texp*( one-ulp )
635 a( 1, j-1 ) = -( tscal / real( n+1 ) ) / real( n+2 )
636 a( j-1, j-1 ) = one
637 b( j-1 ) = texp*real( n*n+n-1 )
638 texp = texp*2.
639 340 CONTINUE
640 b( 1 ) = ( real( n+1 ) / real( n+2 ) )*tscal
641 ELSE
642 DO 350 j = 1, n - 1, 2
643 a( n, j ) = -tscal / real( n+1 )
644 a( j, j ) = one
645 b( j ) = texp*( one-ulp )
646 a( n, j+1 ) = -( tscal / real( n+1 ) ) / real( n+2 )
647 a( j+1, j+1 ) = one
648 b( j+1 ) = texp*real( n*n+n-1 )
649 texp = texp*2.
650 350 CONTINUE
651 b( n ) = ( real( n+1 ) / real( n+2 ) )*tscal
652 END IF
653
654 ELSE IF( imat.EQ.18 ) THEN
655
656
657
658
659
660 IF( upper ) THEN
661 DO 360 j = 1, n
662 CALL clarnv( 4, iseed, j-1, a( 1, j ) )
663 a( j, j ) = zero
664 360 CONTINUE
665 ELSE
666 DO 370 j = 1, n
667 IF( j.LT.n )
668 $
CALL clarnv( 4, iseed, n-j, a( j+1, j ) )
669 a( j, j ) = zero
670 370 CONTINUE
671 END IF
672
673
674
675 CALL clarnv( 2, iseed, n, b )
677 bnorm = abs( b( iy ) )
678 bscal = bignum / max( one, bnorm )
679 CALL csscal( n, bscal, b, 1 )
680
681 ELSE IF( imat.EQ.19 ) THEN
682
683
684
685
686
687
688 tleft = bignum / max( one, real( n-1 ) )
689 tscal = bignum*( real( n-1 ) / max( one, real( n ) ) )
690 IF( upper ) THEN
691 DO 390 j = 1, n
692 CALL clarnv( 5, iseed, j, a( 1, j ) )
693 CALL slarnv( 1, iseed, j, rwork )
694 DO 380 i = 1, j
695 a( i, j ) = a( i, j )*( tleft+rwork( i )*tscal )
696 380 CONTINUE
697 390 CONTINUE
698 ELSE
699 DO 410 j = 1, n
700 CALL clarnv( 5, iseed, n-j+1, a( j, j ) )
701 CALL slarnv( 1, iseed, n-j+1, rwork )
702 DO 400 i = j, n
703 a( i, j ) = a( i, j )*( tleft+rwork( i-j+1 )*tscal )
704 400 CONTINUE
705 410 CONTINUE
706 END IF
707 CALL clarnv( 2, iseed, n, b )
708 CALL csscal( n, two, b, 1 )
709 END IF
710
711
712
713 IF( .NOT.
lsame( trans,
'N' ) )
THEN
714 IF( upper ) THEN
715 DO 420 j = 1, n / 2
716 CALL cswap( n-2*j+1, a( j, j ), lda, a( j+1, n-j+1 ),
717 $ -1 )
718 420 CONTINUE
719 ELSE
720 DO 430 j = 1, n / 2
721 CALL cswap( n-2*j+1, a( j, j ), 1, a( n-j+1, j+1 ),
722 $ -lda )
723 430 CONTINUE
724 END IF
725 END IF
726
727 RETURN
728
729
730
complex function clarnd(idist, iseed)
CLARND
subroutine clatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
CLATB4
subroutine clatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
CLATMS
subroutine ccopy(n, cx, incx, cy, incy)
CCOPY
integer function icamax(n, cx, incx)
ICAMAX
real function slamch(cmach)
SLAMCH
subroutine slarnv(idist, iseed, n, x)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine clarnv(idist, iseed, n, x)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
logical function lsame(ca, cb)
LSAME
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.
subroutine crotg(a, b, c, s)
CROTG generates a Givens rotation with real cosine and complex sine.
subroutine csscal(n, sa, cx, incx)
CSSCAL
subroutine cswap(n, cx, incx, cy, incy)
CSWAP
real function slarnd(idist, iseed)
SLARND