141
142
143
144
145
146
147 CHARACTER DIAG, TRANS, UPLO
148 INTEGER IMAT, INFO, KD, LDAB, N
149
150
151 INTEGER ISEED( 4 )
152 DOUBLE PRECISION RWORK( * )
153 COMPLEX*16 AB( LDAB, * ), B( * ), WORK( * )
154
155
156
157
158
159 DOUBLE PRECISION ONE, TWO, ZERO
160 parameter( one = 1.0d+0, two = 2.0d+0, zero = 0.0d+0 )
161
162
163 LOGICAL UPPER
164 CHARACTER DIST, PACKIT, TYPE
165 CHARACTER*3 PATH
166 INTEGER I, IOFF, IY, J, JCOUNT, KL, KU, LENJ, MODE
167 DOUBLE PRECISION ANORM, BIGNUM, BNORM, BSCAL, CNDNUM, REXP,
168 $ SFAC, SMLNUM, TEXP, TLEFT, TNORM, TSCAL, ULP,
169 $ UNFL
170 COMPLEX*16 PLUS1, PLUS2, STAR1
171
172
173 LOGICAL LSAME
174 INTEGER IZAMAX
175 DOUBLE PRECISION DLAMCH, DLARND
176 COMPLEX*16 ZLARND
178
179
182
183
184 INTRINSIC abs, dble, dcmplx, max, min, sqrt
185
186
187
188 path( 1: 1 ) = 'Zomplex precision'
189 path( 2: 3 ) = 'TB'
190 unfl =
dlamch(
'Safe minimum' )
192 smlnum = unfl
193 bignum = ( one-ulp ) / smlnum
194 CALL dlabad( smlnum, bignum )
195 IF( ( imat.GE.6 .AND. imat.LE.9 ) .OR. imat.EQ.17 ) THEN
196 diag = 'U'
197 ELSE
198 diag = 'N'
199 END IF
200 info = 0
201
202
203
204 IF( n.LE.0 )
205 $ RETURN
206
207
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 ku = kd
214 ioff = 1 + max( 0, kd-n+1 )
215 kl = 0
216 packit = 'Q'
217 ELSE
218 CALL zlatb4( path, -imat, n, n,
TYPE, KL, KU, ANORM, MODE,
219 $ CNDNUM, DIST )
220 kl = kd
221 ioff = 1
222 ku = 0
223 packit = 'B'
224 END IF
225
226
227
228 IF( imat.LE.5 ) THEN
229 CALL zlatms( n, n, dist, iseed,
TYPE, RWORK, MODE, CNDNUM,
230 $ ANORM, KL, KU, PACKIT, AB( IOFF, 1 ), LDAB, WORK,
231 $ INFO )
232
233
234
235
236
237
238 ELSE IF( imat.EQ.6 ) THEN
239 IF( upper ) THEN
240 DO 20 j = 1, n
241 DO 10 i = max( 1, kd+2-j ), kd
242 ab( i, j ) = zero
243 10 CONTINUE
244 ab( kd+1, j ) = j
245 20 CONTINUE
246 ELSE
247 DO 40 j = 1, n
248 ab( 1, j ) = j
249 DO 30 i = 2, min( kd+1, n-j+1 )
250 ab( i, j ) = zero
251 30 CONTINUE
252 40 CONTINUE
253 END IF
254
255
256
257
258
259
260 ELSE IF( imat.LE.9 ) THEN
261 tnorm = sqrt( cndnum )
262
263
264
265 IF( upper ) THEN
266 DO 60 j = 1, n
267 DO 50 i = max( 1, kd+2-j ), kd
268 ab( i, j ) = zero
269 50 CONTINUE
270 ab( kd+1, j ) = dble( j )
271 60 CONTINUE
272 ELSE
273 DO 80 j = 1, n
274 DO 70 i = 2, min( kd+1, n-j+1 )
275 ab( i, j ) = zero
276 70 CONTINUE
277 ab( 1, j ) = dble( j )
278 80 CONTINUE
279 END IF
280
281
282
283
284 IF( kd.EQ.1 ) THEN
285 IF( upper ) THEN
286 ab( 1, 2 ) = tnorm*
zlarnd( 5, iseed )
287 lenj = ( n-3 ) / 2
288 CALL zlarnv( 2, iseed, lenj, work )
289 DO 90 j = 1, lenj
290 ab( 1, 2*( j+1 ) ) = tnorm*work( j )
291 90 CONTINUE
292 ELSE
293 ab( 2, 1 ) = tnorm*
zlarnd( 5, iseed )
294 lenj = ( n-3 ) / 2
295 CALL zlarnv( 2, iseed, lenj, work )
296 DO 100 j = 1, lenj
297 ab( 2, 2*j+1 ) = tnorm*work( j )
298 100 CONTINUE
299 END IF
300 ELSE IF( kd.GT.1 ) THEN
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318 star1 = tnorm*
zlarnd( 5, iseed )
319 sfac = sqrt( tnorm )
320 plus1 = sfac*
zlarnd( 5, iseed )
321 DO 110 j = 1, n, 2
322 plus2 = star1 / plus1
323 work( j ) = plus1
324 work( n+j ) = star1
325 IF( j+1.LE.n ) THEN
326 work( j+1 ) = plus2
327 work( n+j+1 ) = zero
328 plus1 = star1 / plus2
329
330
331
332
334 IF( rexp.LT.zero ) THEN
335 star1 = -sfac**( one-rexp )*
zlarnd( 5, iseed )
336 ELSE
337 star1 = sfac**( one+rexp )*
zlarnd( 5, iseed )
338 END IF
339 END IF
340 110 CONTINUE
341
342
343
344 IF( upper ) THEN
345 CALL zcopy( n-1, work, 1, ab( kd, 2 ), ldab )
346 CALL zcopy( n-2, work( n+1 ), 1, ab( kd-1, 3 ), ldab )
347 ELSE
348 CALL zcopy( n-1, work, 1, ab( 2, 1 ), ldab )
349 CALL zcopy( n-2, work( n+1 ), 1, ab( 3, 1 ), ldab )
350 END IF
351 END IF
352
353
354
355
356
357 ELSE IF( imat.EQ.10 ) THEN
358
359
360
361
362
363 IF( upper ) THEN
364 DO 120 j = 1, n
365 lenj = min( j-1, kd )
366 CALL zlarnv( 4, iseed, lenj, ab( kd+1-lenj, j ) )
367 ab( kd+1, j ) =
zlarnd( 5, iseed )*two
368 120 CONTINUE
369 ELSE
370 DO 130 j = 1, n
371 lenj = min( n-j, kd )
372 IF( lenj.GT.0 )
373 $
CALL zlarnv( 4, iseed, lenj, ab( 2, j ) )
374 ab( 1, j ) =
zlarnd( 5, iseed )*two
375 130 CONTINUE
376 END IF
377
378
379
380 CALL zlarnv( 2, iseed, n, b )
382 bnorm = abs( b( iy ) )
383 bscal = bignum / max( one, bnorm )
384 CALL zdscal( n, bscal, b, 1 )
385
386 ELSE IF( imat.EQ.11 ) THEN
387
388
389
390
391
392 CALL zlarnv( 2, iseed, n, b )
393 tscal = one / dble( kd+1 )
394 IF( upper ) THEN
395 DO 140 j = 1, n
396 lenj = min( j-1, kd )
397 IF( lenj.GT.0 ) THEN
398 CALL zlarnv( 4, iseed, lenj, ab( kd+2-lenj, j ) )
399 CALL zdscal( lenj, tscal, ab( kd+2-lenj, j ), 1 )
400 END IF
401 ab( kd+1, j ) =
zlarnd( 5, iseed )
402 140 CONTINUE
403 ab( kd+1, n ) = smlnum*ab( kd+1, n )
404 ELSE
405 DO 150 j = 1, n
406 lenj = min( n-j, kd )
407 IF( lenj.GT.0 ) THEN
408 CALL zlarnv( 4, iseed, lenj, ab( 2, j ) )
409 CALL zdscal( lenj, tscal, ab( 2, j ), 1 )
410 END IF
411 ab( 1, j ) =
zlarnd( 5, iseed )
412 150 CONTINUE
413 ab( 1, 1 ) = smlnum*ab( 1, 1 )
414 END IF
415
416 ELSE IF( imat.EQ.12 ) THEN
417
418
419
420
421
422 CALL zlarnv( 2, iseed, n, b )
423 IF( upper ) THEN
424 DO 160 j = 1, n
425 lenj = min( j-1, kd )
426 IF( lenj.GT.0 )
427 $
CALL zlarnv( 4, iseed, lenj, ab( kd+2-lenj, j ) )
428 ab( kd+1, j ) =
zlarnd( 5, iseed )
429 160 CONTINUE
430 ab( kd+1, n ) = smlnum*ab( kd+1, n )
431 ELSE
432 DO 170 j = 1, n
433 lenj = min( n-j, kd )
434 IF( lenj.GT.0 )
435 $
CALL zlarnv( 4, iseed, lenj, ab( 2, j ) )
436 ab( 1, j ) =
zlarnd( 5, iseed )
437 170 CONTINUE
438 ab( 1, 1 ) = smlnum*ab( 1, 1 )
439 END IF
440
441 ELSE IF( imat.EQ.13 ) THEN
442
443
444
445
446
447 IF( upper ) THEN
448 jcount = 1
449 DO 190 j = n, 1, -1
450 DO 180 i = max( 1, kd+1-( j-1 ) ), kd
451 ab( i, j ) = zero
452 180 CONTINUE
453 IF( jcount.LE.2 ) THEN
454 ab( kd+1, j ) = smlnum*
zlarnd( 5, iseed )
455 ELSE
456 ab( kd+1, j ) =
zlarnd( 5, iseed )
457 END IF
458 jcount = jcount + 1
459 IF( jcount.GT.4 )
460 $ jcount = 1
461 190 CONTINUE
462 ELSE
463 jcount = 1
464 DO 210 j = 1, n
465 DO 200 i = 2, min( n-j+1, kd+1 )
466 ab( i, j ) = zero
467 200 CONTINUE
468 IF( jcount.LE.2 ) THEN
469 ab( 1, j ) = smlnum*
zlarnd( 5, iseed )
470 ELSE
471 ab( 1, j ) =
zlarnd( 5, iseed )
472 END IF
473 jcount = jcount + 1
474 IF( jcount.GT.4 )
475 $ jcount = 1
476 210 CONTINUE
477 END IF
478
479
480
481 IF( upper ) THEN
482 b( 1 ) = zero
483 DO 220 i = n, 2, -2
484 b( i ) = zero
485 b( i-1 ) = smlnum*
zlarnd( 5, iseed )
486 220 CONTINUE
487 ELSE
488 b( n ) = zero
489 DO 230 i = 1, n - 1, 2
490 b( i ) = zero
491 b( i+1 ) = smlnum*
zlarnd( 5, iseed )
492 230 CONTINUE
493 END IF
494
495 ELSE IF( imat.EQ.14 ) THEN
496
497
498
499
500
501 texp = one / dble( kd+1 )
502 tscal = smlnum**texp
503 CALL zlarnv( 4, iseed, n, b )
504 IF( upper ) THEN
505 DO 250 j = 1, n
506 DO 240 i = max( 1, kd+2-j ), kd
507 ab( i, j ) = zero
508 240 CONTINUE
509 IF( j.GT.1 .AND. kd.GT.0 )
510 $ ab( kd, j ) = dcmplx( -one, -one )
511 ab( kd+1, j ) = tscal*
zlarnd( 5, iseed )
512 250 CONTINUE
513 b( n ) = dcmplx( one, one )
514 ELSE
515 DO 270 j = 1, n
516 DO 260 i = 3, min( n-j+1, kd+1 )
517 ab( i, j ) = zero
518 260 CONTINUE
519 IF( j.LT.n .AND. kd.GT.0 )
520 $ ab( 2, j ) = dcmplx( -one, -one )
521 ab( 1, j ) = tscal*
zlarnd( 5, iseed )
522 270 CONTINUE
523 b( 1 ) = dcmplx( one, one )
524 END IF
525
526 ELSE IF( imat.EQ.15 ) THEN
527
528
529
530 iy = n / 2 + 1
531 IF( upper ) THEN
532 DO 280 j = 1, n
533 lenj = min( j, kd+1 )
534 CALL zlarnv( 4, iseed, lenj, ab( kd+2-lenj, j ) )
535 IF( j.NE.iy ) THEN
536 ab( kd+1, j ) =
zlarnd( 5, iseed )*two
537 ELSE
538 ab( kd+1, j ) = zero
539 END IF
540 280 CONTINUE
541 ELSE
542 DO 290 j = 1, n
543 lenj = min( n-j+1, kd+1 )
544 CALL zlarnv( 4, iseed, lenj, ab( 1, j ) )
545 IF( j.NE.iy ) THEN
546 ab( 1, j ) =
zlarnd( 5, iseed )*two
547 ELSE
548 ab( 1, j ) = zero
549 END IF
550 290 CONTINUE
551 END IF
552 CALL zlarnv( 2, iseed, n, b )
553 CALL zdscal( n, two, b, 1 )
554
555 ELSE IF( imat.EQ.16 ) THEN
556
557
558
559
560
561
562 tscal = unfl / ulp
563 tscal = ( one-ulp ) / tscal
564 DO 310 j = 1, n
565 DO 300 i = 1, kd + 1
566 ab( i, j ) = zero
567 300 CONTINUE
568 310 CONTINUE
569 texp = one
570 IF( kd.GT.0 ) THEN
571 IF( upper ) THEN
572 DO 330 j = n, 1, -kd
573 DO 320 i = j, max( 1, j-kd+1 ), -2
574 ab( 1+( j-i ), i ) = -tscal / dble( kd+2 )
575 ab( kd+1, i ) = one
576 b( i ) = texp*( one-ulp )
577 IF( i.GT.max( 1, j-kd+1 ) ) THEN
578 ab( 2+( j-i ), i-1 ) = -( tscal / dble( kd+2 ) )
579 $ / dble( kd+3 )
580 ab( kd+1, i-1 ) = one
581 b( i-1 ) = texp*dble( ( kd+1 )*( kd+1 )+kd )
582 END IF
583 texp = texp*two
584 320 CONTINUE
585 b( max( 1, j-kd+1 ) ) = ( dble( kd+2 ) /
586 $ dble( kd+3 ) )*tscal
587 330 CONTINUE
588 ELSE
589 DO 350 j = 1, n, kd
590 texp = one
591 lenj = min( kd+1, n-j+1 )
592 DO 340 i = j, min( n, j+kd-1 ), 2
593 ab( lenj-( i-j ), j ) = -tscal / dble( kd+2 )
594 ab( 1, j ) = one
595 b( j ) = texp*( one-ulp )
596 IF( i.LT.min( n, j+kd-1 ) ) THEN
597 ab( lenj-( i-j+1 ), i+1 ) = -( tscal /
598 $ dble( kd+2 ) ) / dble( kd+3 )
599 ab( 1, i+1 ) = one
600 b( i+1 ) = texp*dble( ( kd+1 )*( kd+1 )+kd )
601 END IF
602 texp = texp*two
603 340 CONTINUE
604 b( min( n, j+kd-1 ) ) = ( dble( kd+2 ) /
605 $ dble( kd+3 ) )*tscal
606 350 CONTINUE
607 END IF
608 END IF
609
610 ELSE IF( imat.EQ.17 ) THEN
611
612
613
614
615
616 IF( upper ) THEN
617 DO 360 j = 1, n
618 lenj = min( j-1, kd )
619 CALL zlarnv( 4, iseed, lenj, ab( kd+1-lenj, j ) )
620 ab( kd+1, j ) = dble( j )
621 360 CONTINUE
622 ELSE
623 DO 370 j = 1, n
624 lenj = min( n-j, kd )
625 IF( lenj.GT.0 )
626 $
CALL zlarnv( 4, iseed, lenj, ab( 2, j ) )
627 ab( 1, j ) = dble( j )
628 370 CONTINUE
629 END IF
630
631
632
633 CALL zlarnv( 2, iseed, n, b )
635 bnorm = abs( b( iy ) )
636 bscal = bignum / max( one, bnorm )
637 CALL zdscal( n, bscal, b, 1 )
638
639 ELSE IF( imat.EQ.18 ) THEN
640
641
642
643
644
645
646 tleft = bignum / dble( kd+1 )
647 tscal = bignum*( dble( kd+1 ) / dble( kd+2 ) )
648 IF( upper ) THEN
649 DO 390 j = 1, n
650 lenj = min( j, kd+1 )
651 CALL zlarnv( 5, iseed, lenj, ab( kd+2-lenj, j ) )
652 CALL dlarnv( 1, iseed, lenj, rwork( kd+2-lenj ) )
653 DO 380 i = kd + 2 - lenj, kd + 1
654 ab( i, j ) = ab( i, j )*( tleft+rwork( i )*tscal )
655 380 CONTINUE
656 390 CONTINUE
657 ELSE
658 DO 410 j = 1, n
659 lenj = min( n-j+1, kd+1 )
660 CALL zlarnv( 5, iseed, lenj, ab( 1, j ) )
661 CALL dlarnv( 1, iseed, lenj, rwork )
662 DO 400 i = 1, lenj
663 ab( i, j ) = ab( i, j )*( tleft+rwork( i )*tscal )
664 400 CONTINUE
665 410 CONTINUE
666 END IF
667 CALL zlarnv( 2, iseed, n, b )
668 CALL zdscal( n, two, b, 1 )
669 END IF
670
671
672
673 IF( .NOT.
lsame( trans,
'N' ) )
THEN
674 IF( upper ) THEN
675 DO 420 j = 1, n / 2
676 lenj = min( n-2*j+1, kd+1 )
677 CALL zswap( lenj, ab( kd+1, j ), ldab-1,
678 $ ab( kd+2-lenj, n-j+1 ), -1 )
679 420 CONTINUE
680 ELSE
681 DO 430 j = 1, n / 2
682 lenj = min( n-2*j+1, kd+1 )
683 CALL zswap( lenj, ab( 1, j ), 1, ab( lenj, n-j+2-lenj ),
684 $ -ldab+1 )
685 430 CONTINUE
686 END IF
687 END IF
688
689 RETURN
690
691
692
double precision function dlamch(CMACH)
DLAMCH
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dlarnv(IDIST, ISEED, N, X)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
integer function izamax(N, ZX, INCX)
IZAMAX
logical function lsame(CA, CB)
LSAME
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine zlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
ZLATB4
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
complex *16 function zlarnd(IDIST, ISEED)
ZLARND
subroutine zlarnv(IDIST, ISEED, N, X)
ZLARNV returns a vector of random numbers from a uniform or normal distribution.
double precision function dlarnd(IDIST, ISEED)
DLARND