133 SUBROUTINE dlattr( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B,
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 ) )
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
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
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 ) )
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 ) )
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 ) )
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 )
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 ),
LOGICAL function lsame(CA, CB)
LSAME
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine drotg(DA, DB, C, S)
DROTG
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dlattr(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, WORK, INFO)
DLATTR
subroutine dlarnv(IDIST, ISEED, N, X)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
subroutine dlabad(SMALL, LARGE)
DLABAD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine dscal(N, DA, DX, INCX)
DSCAL
DOUBLE PRECISION function dlarnd(IDIST, ISEED)
DLARND
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine dswap(N, DX, INCX, DY, INCY)
DSWAP
INTEGER function idamax(N, DX, INCX)
IDAMAX