147 CHARACTER diag, trans, uplo
148 INTEGER imat, info, lda, n
152 DOUBLE PRECISION rwork( * )
153 COMPLEX*16 a( lda, * ), b( * ), work( * )
159 DOUBLE PRECISION one, two, zero
160 parameter ( one = 1.0d+0, two = 2.0d+0, zero = 0.0d+0 )
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,
170 COMPLEX*16 plus1, plus2, ra, rb, s, star1
184 INTRINSIC abs, dble, dcmplx, dconjg, max, sqrt
188 path( 1: 1 ) =
'Zomplex precision'
190 unfl =
dlamch(
'Safe minimum' )
193 bignum = ( one-ulp ) / smlnum
194 CALL dlabad( smlnum, bignum )
195 IF( ( imat.GE.7 .AND. imat.LE.10 ) .OR. imat.EQ.18 )
THEN
209 upper =
lsame( uplo,
'U' )
211 CALL zlatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
214 CALL zlatb4( path, -imat, n, n,
TYPE, kl, ku, anorm, mode,
221 CALL zlatms( n, n, dist, iseed,
TYPE, rwork, mode, cndnum,
222 $ anorm, kl, ku,
'No packing', a, lda, work, info )
229 ELSE IF( imat.EQ.7 )
THEN
252 ELSE IF( imat.LE.10 )
THEN
327 star1 = 0.25d0*
zlarnd( 5, iseed )
329 plus1 = sfac*
zlarnd( 5, iseed )
331 plus2 = star1 / plus1
337 plus1 = star1 / plus2
339 IF( rexp.LT.zero )
THEN
340 star1 = -sfac**( one-rexp )*
zlarnd( 5, iseed )
342 star1 = sfac**( one+rexp )*
zlarnd( 5, iseed )
347 x = sqrt( cndnum ) - 1 / sqrt( cndnum )
349 y = sqrt( 2.d0 / ( n-2 ) )*x
357 CALL zcopy( n-3, work, 1, a( 2, 3 ), lda+1 )
359 $
CALL zcopy( n-4, work( n+1 ), 1, a( 2, 4 ), lda+1 )
368 CALL zcopy( n-3, work, 1, a( 3, 2 ), lda+1 )
370 $
CALL zcopy( n-4, work( n+1 ), 1, a( 4, 2 ), lda+1 )
385 CALL zrotg( ra, rb, c, s )
390 $
CALL zrot( n-j-1, a( j, j+2 ), lda, a( j+1, j+2 ),
396 $
CALL zrot( j-1, a( 1, j+1 ), 1, a( 1, j ), 1, -c, -s )
400 a( j, j+1 ) = -a( j, j+1 )
406 CALL zrotg( ra, rb, c, s )
412 $
CALL zrot( n-j-1, a( j+2, j+1 ), 1, a( j+2, j ), 1, c,
418 $
CALL zrot( j-1, a( j, 1 ), lda, a( j+1, 1 ), lda, -c,
423 a( j+1, j ) = -a( j+1, j )
431 ELSE IF( imat.EQ.11 )
THEN
439 CALL zlarnv( 4, iseed, j-1, a( 1, j ) )
440 a( j, j ) =
zlarnd( 5, iseed )*two
445 $
CALL zlarnv( 4, iseed, n-j, a( j+1, j ) )
446 a( j, j ) =
zlarnd( 5, iseed )*two
452 CALL zlarnv( 2, iseed, n, b )
454 bnorm = abs( b( iy ) )
455 bscal = bignum / max( one, bnorm )
456 CALL zdscal( n, bscal, b, 1 )
458 ELSE IF( imat.EQ.12 )
THEN
464 CALL zlarnv( 2, iseed, n, b )
465 tscal = one / max( one, dble( n-1 ) )
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 )
472 a( n, n ) = smlnum*a( n, n )
476 CALL zlarnv( 4, iseed, n-j, a( j+1, j ) )
477 CALL zdscal( n-j, tscal, a( j+1, j ), 1 )
479 a( j, j ) =
zlarnd( 5, iseed )
481 a( 1, 1 ) = smlnum*a( 1, 1 )
484 ELSE IF( imat.EQ.13 )
THEN
490 CALL zlarnv( 2, iseed, n, b )
493 CALL zlarnv( 4, iseed, j-1, a( 1, j ) )
494 a( j, j ) =
zlarnd( 5, iseed )
496 a( n, n ) = smlnum*a( n, n )
500 $
CALL zlarnv( 4, iseed, n-j, a( j+1, j ) )
501 a( j, j ) =
zlarnd( 5, iseed )
503 a( 1, 1 ) = smlnum*a( 1, 1 )
506 ELSE IF( imat.EQ.14 )
THEN
518 IF( jcount.LE.2 )
THEN
519 a( j, j ) = smlnum*
zlarnd( 5, iseed )
521 a( j, j ) =
zlarnd( 5, iseed )
533 IF( jcount.LE.2 )
THEN
534 a( j, j ) = smlnum*
zlarnd( 5, iseed )
536 a( j, j ) =
zlarnd( 5, iseed )
550 b( i-1 ) = smlnum*
zlarnd( 5, iseed )
554 DO 250 i = 1, n - 1, 2
556 b( i+1 ) = smlnum*
zlarnd( 5, iseed )
560 ELSE IF( imat.EQ.15 )
THEN
566 texp = one / max( one, dble( n-1 ) )
568 CALL zlarnv( 4, iseed, n, b )
575 $ a( j-1, j ) = dcmplx( -one, -one )
576 a( j, j ) = tscal*
zlarnd( 5, iseed )
578 b( n ) = dcmplx( one, one )
585 $ a( j+1, j ) = dcmplx( -one, -one )
586 a( j, j ) = tscal*
zlarnd( 5, iseed )
588 b( 1 ) = dcmplx( one, one )
591 ELSE IF( imat.EQ.16 )
THEN
598 CALL zlarnv( 4, iseed, j-1, a( 1, j ) )
600 a( j, j ) =
zlarnd( 5, iseed )*two
608 $
CALL zlarnv( 4, iseed, n-j, a( j+1, j ) )
610 a( j, j ) =
zlarnd( 5, iseed )*two
616 CALL zlarnv( 2, iseed, n, b )
617 CALL zdscal( n, two, b, 1 )
619 ELSE IF( imat.EQ.17 )
THEN
627 tscal = ( one-ulp ) / tscal
636 a( 1, j ) = -tscal / dble( n+1 )
638 b( j ) = texp*( one-ulp )
639 a( 1, j-1 ) = -( tscal / dble( n+1 ) ) / dble( n+2 )
641 b( j-1 ) = texp*dble( n*n+n-1 )
644 b( 1 ) = ( dble( n+1 ) / dble( n+2 ) )*tscal
646 DO 350 j = 1, n - 1, 2
647 a( n, j ) = -tscal / dble( n+1 )
649 b( j ) = texp*( one-ulp )
650 a( n, j+1 ) = -( tscal / dble( n+1 ) ) / dble( n+2 )
652 b( j+1 ) = texp*dble( n*n+n-1 )
655 b( n ) = ( dble( n+1 ) / dble( n+2 ) )*tscal
658 ELSE IF( imat.EQ.18 )
THEN
666 CALL zlarnv( 4, iseed, j-1, a( 1, j ) )
672 $
CALL zlarnv( 4, iseed, n-j, a( j+1, j ) )
679 CALL zlarnv( 2, iseed, n, b )
681 bnorm = abs( b( iy ) )
682 bscal = bignum / max( one, bnorm )
683 CALL zdscal( n, bscal, b, 1 )
685 ELSE IF( imat.EQ.19 )
THEN
692 tleft = bignum / max( one, dble( n-1 ) )
693 tscal = bignum*( dble( n-1 ) / max( one, dble( n ) ) )
696 CALL zlarnv( 5, iseed, j, a( 1, j ) )
697 CALL dlarnv( 1, iseed, j, rwork )
699 a( i, j ) = a( i, j )*( tleft+rwork( i )*tscal )
704 CALL zlarnv( 5, iseed, n-j+1, a( j, j ) )
705 CALL dlarnv( 1, iseed, n-j+1, rwork )
707 a( i, j ) = a( i, j )*( tleft+rwork( i-j+1 )*tscal )
711 CALL zlarnv( 2, iseed, n, b )
712 CALL zdscal( n, two, b, 1 )
717 IF( .NOT.
lsame( trans,
'N' ) )
THEN
720 CALL zswap( n-2*j+1, a( j, j ), lda, a( j+1, n-j+1 ),
725 CALL zswap( n-2*j+1, a( j, j ), 1, a( n-j+1, j+1 ),
subroutine zlarnv(IDIST, ISEED, N, X)
ZLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
double precision function dlamch(CMACH)
DLAMCH
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine zlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
ZLATB4
double precision function dlarnd(IDIST, ISEED)
DLARND
integer function izamax(N, ZX, INCX)
IZAMAX
subroutine zrotg(CA, CB, C, S)
ZROTG
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
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...
subroutine dlarnv(IDIST, ISEED, N, X)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
logical function lsame(CA, CB)
LSAME
complex *16 function zlarnd(IDIST, ISEED)
ZLARND