142 CHARACTER diag, trans, uplo
143 INTEGER imat, info, lda, n
147 DOUBLE PRECISION a( lda, * ), b( * ), work( * )
153 DOUBLE PRECISION one, two, zero
154 parameter ( one = 1.0d+0, two = 2.0d+0, zero = 0.0d+0 )
160 INTEGER i, iy, j, jcount, kl, ku, mode
161 DOUBLE PRECISION anorm, bignum, bnorm, bscal, c, cndnum, plus1,
162 $ plus2, ra, rb, rexp, s, sfac, smlnum, star1,
163 $ texp, tleft, tscal, ulp, unfl, x, y, z
176 INTRINSIC abs, dble, max, sign, sqrt
180 path( 1: 1 ) =
'Double precision'
182 unfl =
dlamch(
'Safe minimum' )
185 bignum = ( one-ulp ) / smlnum
186 CALL dlabad( smlnum, bignum )
187 IF( ( imat.GE.7 .AND. imat.LE.10 ) .OR. imat.EQ.18 )
THEN
201 upper =
lsame( uplo,
'U' )
203 CALL dlatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
206 CALL dlatb4( path, -imat, n, n,
TYPE, kl, ku, anorm, mode,
213 CALL dlatms( n, n, dist, iseed,
TYPE, b, mode, cndnum, anorm,
214 $ kl, ku,
'No packing', a, lda, work, info )
221 ELSE IF( imat.EQ.7 )
THEN
244 ELSE IF( imat.LE.10 )
THEN
323 plus2 = star1 / plus1
329 plus1 = star1 / plus2
331 star1 = star1*( sfac**rexp )
332 IF( rexp.LT.zero )
THEN
333 star1 = -sfac**( one-rexp )
335 star1 = sfac**( one+rexp )
340 x = sqrt( cndnum ) - 1 / sqrt( cndnum )
342 y = sqrt( 2.d0 / ( n-2 ) )*x
350 CALL dcopy( n-3, work, 1, a( 2, 3 ), lda+1 )
352 $
CALL dcopy( n-4, work( n+1 ), 1, a( 2, 4 ), lda+1 )
361 CALL dcopy( n-3, work, 1, a( 3, 2 ), lda+1 )
363 $
CALL dcopy( n-4, work( n+1 ), 1, a( 4, 2 ), lda+1 )
378 CALL drotg( ra, rb, c, s )
383 $
CALL drot( n-j-1, a( j, j+2 ), lda, a( j+1, j+2 ),
389 $
CALL drot( j-1, a( 1, j+1 ), 1, a( 1, j ), 1, -c, -s )
393 a( j, j+1 ) = -a( j, j+1 )
399 CALL drotg( ra, rb, c, s )
404 $
CALL drot( n-j-1, a( j+2, j+1 ), 1, a( j+2, j ), 1, c,
410 $
CALL drot( j-1, a( j, 1 ), lda, a( j+1, 1 ), lda, -c,
415 a( j+1, j ) = -a( j+1, j )
423 ELSE IF( imat.EQ.11 )
THEN
431 CALL dlarnv( 2, iseed, j, a( 1, j ) )
432 a( j, j ) = sign( two, a( j, j ) )
436 CALL dlarnv( 2, iseed, n-j+1, a( j, j ) )
437 a( j, j ) = sign( two, a( j, j ) )
443 CALL dlarnv( 2, iseed, n, b )
445 bnorm = abs( b( iy ) )
446 bscal = bignum / max( one, bnorm )
447 CALL dscal( n, bscal, b, 1 )
449 ELSE IF( imat.EQ.12 )
THEN
455 CALL dlarnv( 2, iseed, n, b )
456 tscal = one / max( one, dble( n-1 ) )
459 CALL dlarnv( 2, iseed, j, a( 1, j ) )
460 CALL dscal( j-1, tscal, a( 1, j ), 1 )
461 a( j, j ) = sign( one, a( j, j ) )
463 a( n, n ) = smlnum*a( n, n )
466 CALL dlarnv( 2, iseed, n-j+1, a( j, j ) )
468 $
CALL dscal( n-j, tscal, a( j+1, j ), 1 )
469 a( j, j ) = sign( one, a( j, j ) )
471 a( 1, 1 ) = smlnum*a( 1, 1 )
474 ELSE IF( imat.EQ.13 )
THEN
480 CALL dlarnv( 2, iseed, n, b )
483 CALL dlarnv( 2, iseed, j, a( 1, j ) )
484 a( j, j ) = sign( one, a( j, j ) )
486 a( n, n ) = smlnum*a( n, n )
489 CALL dlarnv( 2, iseed, n-j+1, a( j, j ) )
490 a( j, j ) = sign( one, a( j, j ) )
492 a( 1, 1 ) = smlnum*a( 1, 1 )
495 ELSE IF( imat.EQ.14 )
THEN
507 IF( jcount.LE.2 )
THEN
522 IF( jcount.LE.2 )
THEN
543 DO 250 i = 1, n - 1, 2
549 ELSE IF( imat.EQ.15 )
THEN
555 texp = one / max( one, dble( n-1 ) )
557 CALL dlarnv( 2, iseed, n, b )
580 ELSE IF( imat.EQ.16 )
THEN
587 CALL dlarnv( 2, iseed, j, a( 1, j ) )
589 a( j, j ) = sign( two, a( j, j ) )
596 CALL dlarnv( 2, iseed, n-j+1, a( j, j ) )
598 a( j, j ) = sign( two, a( j, j ) )
604 CALL dlarnv( 2, iseed, n, b )
605 CALL dscal( n, two, b, 1 )
607 ELSE IF( imat.EQ.17 )
THEN
615 tscal = ( one-ulp ) / tscal
624 a( 1, j ) = -tscal / dble( n+1 )
626 b( j ) = texp*( one-ulp )
627 a( 1, j-1 ) = -( tscal / dble( n+1 ) ) / dble( n+2 )
629 b( j-1 ) = texp*dble( n*n+n-1 )
632 b( 1 ) = ( dble( n+1 ) / dble( n+2 ) )*tscal
634 DO 350 j = 1, n - 1, 2
635 a( n, j ) = -tscal / dble( n+1 )
637 b( j ) = texp*( one-ulp )
638 a( n, j+1 ) = -( tscal / dble( n+1 ) ) / dble( n+2 )
640 b( j+1 ) = texp*dble( n*n+n-1 )
643 b( n ) = ( dble( n+1 ) / dble( n+2 ) )*tscal
646 ELSE IF( imat.EQ.18 )
THEN
654 CALL dlarnv( 2, iseed, j-1, a( 1, j ) )
660 $
CALL dlarnv( 2, iseed, n-j, a( j+1, j ) )
667 CALL dlarnv( 2, iseed, n, b )
669 bnorm = abs( b( iy ) )
670 bscal = bignum / max( one, bnorm )
671 CALL dscal( n, bscal, b, 1 )
673 ELSE IF( imat.EQ.19 )
THEN
680 tleft = bignum / max( one, dble( n-1 ) )
681 tscal = bignum*( dble( n-1 ) / max( one, dble( n ) ) )
684 CALL dlarnv( 2, iseed, j, a( 1, j ) )
686 a( i, j ) = sign( tleft, a( i, j ) ) + tscal*a( i, j )
691 CALL dlarnv( 2, iseed, n-j+1, a( j, j ) )
693 a( i, j ) = sign( tleft, a( i, j ) ) + tscal*a( i, j )
697 CALL dlarnv( 2, iseed, n, b )
698 CALL dscal( n, two, b, 1 )
703 IF( .NOT.
lsame( trans,
'N' ) )
THEN
706 CALL dswap( n-2*j+1, a( j, j ), lda, a( j+1, n-j+1 ),
711 CALL dswap( n-2*j+1, a( j, j ), 1, a( n-j+1, j+1 ),
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
integer function idamax(N, DX, INCX)
IDAMAX
double precision function dlamch(CMACH)
DLAMCH
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dswap(N, DX, INCX, DY, INCY)
DSWAP
double precision function dlarnd(IDIST, ISEED)
DLARND
subroutine drotg(DA, DB, C, S)
DROTG
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
subroutine dscal(N, DA, DX, INCX)
DSCAL
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
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