329 SUBROUTINE slatme( N, DIST, ISEED, D, MODE, COND, DMAX, EI,
331 $ upper, sim, ds, modes, conds, kl, ku, anorm,
341 CHARACTER dist, rsign, sim, upper
342 INTEGER info, kl, ku, lda, mode, modes, n
343 REAL anorm, cond, conds, dmax
348 REAL a( lda, * ), d( * ), ds( * ), work( * )
355 parameter( zero = 0.0e0 )
357 parameter( one = 1.0e0 )
359 parameter( half = 1.0e0 / 2.0e0 )
362 LOGICAL badei, bads, useei
363 INTEGER i, ic, icols, idist, iinfo, ir, irows, irsign,
364 $ isim, iupper,
j, jc, jcr, jr
365 REAL alpha, tau, temp, xnorms
380 INTRINSIC abs, max, mod
396 IF(
lsame( dist,
'U' ) )
THEN
398 ELSE IF(
lsame( dist,
'S' ) )
THEN
400 ELSE IF(
lsame( dist,
'N' ) )
THEN
410 IF(
lsame( ei( 1 ),
' ' ) .OR. mode.NE.0 )
THEN
413 IF(
lsame( ei( 1 ),
'R' ) )
THEN
415 IF(
lsame( ei(
j ),
'I' ) )
THEN
416 IF(
lsame( ei(
j-1 ),
'I' ) )
419 IF( .NOT.
lsame( ei(
j ),
'R' ) )
430 IF(
lsame( rsign,
'T' ) )
THEN
432 ELSE IF(
lsame( rsign,
'F' ) )
THEN
440 IF(
lsame( upper,
'T' ) )
THEN
442 ELSE IF(
lsame( upper,
'F' ) )
THEN
450 IF(
lsame( sim,
'T' ) )
THEN
452 ELSE IF(
lsame( sim,
'F' ) )
THEN
461 IF( modes.EQ.0 .AND. isim.EQ.1 )
THEN
463 IF( ds(
j ).EQ.zero )
472 ELSE IF( idist.EQ.-1 )
THEN
474 ELSE IF( abs( mode ).GT.6 )
THEN
476 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
479 ELSE IF( badei )
THEN
481 ELSE IF( irsign.EQ.-1 )
THEN
483 ELSE IF( iupper.EQ.-1 )
THEN
485 ELSE IF( isim.EQ.-1 )
THEN
489 ELSE IF( isim.EQ.1 .AND. abs( modes ).GT.5 )
THEN
491 ELSE IF( isim.EQ.1 .AND. modes.NE.0 .AND. conds.LT.one )
THEN
493 ELSE IF( kl.LT.1 )
THEN
495 ELSE IF( ku.LT.1 .OR. ( ku.LT.n-1 .AND. kl.LT.n-1 ) )
THEN
497 ELSE IF( lda.LT.max( 1, n ) )
THEN
502 CALL
xerbla(
'SLATME', -info )
509 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
512 IF( mod( iseed( 4 ), 2 ).NE.1 )
513 $ iseed( 4 ) = iseed( 4 ) + 1
519 CALL
slatm1( mode, cond, irsign, idist, iseed, d, n, iinfo )
520 IF( iinfo.NE.0 )
THEN
524 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
530 temp = max( temp, abs( d( i ) ) )
533 IF( temp.GT.zero )
THEN
535 ELSE IF( dmax.NE.zero )
THEN
542 CALL
sscal( n, alpha, d, 1 )
546 CALL
slaset(
'Full', n, n, zero, zero, a, lda )
547 CALL
scopy( n, d, 1, a, lda+1 )
554 IF(
lsame( ei(
j ),
'I' ) )
THEN
555 a(
j-1,
j ) = a(
j,
j )
556 a(
j,
j-1 ) = -a(
j,
j )
557 a(
j,
j ) = a(
j-1,
j-1 )
562 ELSE IF( abs( mode ).EQ.5 )
THEN
565 IF(
slaran( iseed ).GT.half )
THEN
566 a(
j-1,
j ) = a(
j,
j )
567 a(
j,
j-1 ) = -a(
j,
j )
568 a(
j,
j ) = a(
j-1,
j-1 )
576 IF( iupper.NE.0 )
THEN
578 IF( a( jc-1, jc ).NE.zero )
THEN
583 CALL
slarnv( idist, iseed, jr, a( 1, jc ) )
599 CALL
slatm1( modes, conds, 0, 0, iseed, ds, n, iinfo )
600 IF( iinfo.NE.0 )
THEN
607 CALL
slarge( n, a, lda, iseed, work, iinfo )
608 IF( iinfo.NE.0 )
THEN
616 CALL
sscal( n, ds(
j ), a(
j, 1 ), lda )
617 IF( ds(
j ).NE.zero )
THEN
618 CALL
sscal( n, one / ds(
j ), a( 1,
j ), 1 )
627 CALL
slarge( n, a, lda, iseed, work, iinfo )
628 IF( iinfo.NE.0 )
THEN
640 DO 90 jcr = kl + 1, n - 1
645 CALL
scopy( irows, a( jcr, ic ), 1, work, 1 )
647 CALL
slarfg( irows, xnorms, work( 2 ), 1, tau )
650 CALL
sgemv(
'T', irows, icols, one, a( jcr, ic+1 ), lda,
651 $ work, 1, zero, work( irows+1 ), 1 )
652 CALL
sger( irows, icols, -tau, work, 1, work( irows+1 ), 1,
653 $ a( jcr, ic+1 ), lda )
655 CALL
sgemv(
'N', n, irows, one, a( 1, jcr ), lda, work, 1,
656 $ zero, work( irows+1 ), 1 )
657 CALL
sger( n, irows, -tau, work( irows+1 ), 1, work, 1,
660 a( jcr, ic ) = xnorms
661 CALL
slaset(
'Full', irows-1, 1, zero, zero, a( jcr+1, ic ),
664 ELSE IF( ku.LT.n-1 )
THEN
668 DO 100 jcr = ku + 1, n - 1
673 CALL
scopy( icols, a( ir, jcr ), lda, work, 1 )
675 CALL
slarfg( icols, xnorms, work( 2 ), 1, tau )
678 CALL
sgemv(
'N', irows, icols, one, a( ir+1, jcr ), lda,
679 $ work, 1, zero, work( icols+1 ), 1 )
680 CALL
sger( irows, icols, -tau, work( icols+1 ), 1, work, 1,
681 $ a( ir+1, jcr ), lda )
683 CALL
sgemv(
'C', icols, n, one, a( jcr, 1 ), lda, work, 1,
684 $ zero, work( icols+1 ), 1 )
685 CALL
sger( icols, n, -tau, work, 1, work( icols+1 ), 1,
688 a( ir, jcr ) = xnorms
689 CALL
slaset(
'Full', 1, icols-1, zero, zero, a( ir, jcr+1 ),
696 IF( anorm.GE.zero )
THEN
697 temp =
slange(
'M', n, n, a, lda, tempa )
698 IF( temp.GT.zero )
THEN
701 CALL
sscal( n, alpha, a( 1,
j ), 1 )
real function slaran(ISEED)
SLARAN
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine slatm1(MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO)
SLATM1
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
logical function lsame(CA, CB)
LSAME
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
SGEMV
subroutine slarge(N, A, LDA, ISEED, WORK, INFO)
SLARGE
subroutine slarfg(N, ALPHA, X, INCX, TAU)
SLARFG generates an elementary reflector (Householder matrix).
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine sger(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
SGER
subroutine slatme(N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
SLATME
subroutine sscal(N, SA, SX, INCX)
SSCAL