327 SUBROUTINE dlatme( N, DIST, ISEED, D, MODE, COND, DMAX, EI,
329 $ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM,
338 CHARACTER DIST, RSIGN, SIM, UPPER
339 INTEGER INFO, KL, KU, LDA, MODE, MODES, N
340 DOUBLE PRECISION ANORM, COND, CONDS, DMAX
345 DOUBLE PRECISION A( LDA, * ), D( * ), DS( * ), WORK( * )
351 DOUBLE PRECISION ZERO
352 PARAMETER ( ZERO = 0.0d0 )
354 PARAMETER ( ONE = 1.0d0 )
355 DOUBLE PRECISION HALF
356 parameter( half = 1.0d0 / 2.0d0 )
359 LOGICAL BADEI, BADS, USEEI
360 INTEGER I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN,
361 $ ISIM, IUPPER, J, JC, JCR, JR
362 DOUBLE PRECISION ALPHA, TAU, TEMP, XNORMS
365 DOUBLE PRECISION TEMPA( 1 )
369 DOUBLE PRECISION DLANGE, DLARAN
370 EXTERNAL LSAME, DLANGE, DLARAN
377 INTRINSIC abs, max, mod
393 IF( lsame( dist,
'U' ) )
THEN
395 ELSE IF( lsame( dist,
'S' ) )
THEN
397 ELSE IF( lsame( dist,
'N' ) )
THEN
407 IF( lsame( ei( 1 ),
' ' ) .OR. mode.NE.0 )
THEN
410 IF( lsame( ei( 1 ),
'R' ) )
THEN
412 IF( lsame( ei( j ),
'I' ) )
THEN
413 IF( lsame( ei( j-1 ),
'I' ) )
416 IF( .NOT.lsame( ei( j ),
'R' ) )
427 IF( lsame( rsign,
'T' ) )
THEN
429 ELSE IF( lsame( rsign,
'F' ) )
THEN
437 IF( lsame( upper,
'T' ) )
THEN
439 ELSE IF( lsame( upper,
'F' ) )
THEN
447 IF( lsame( sim,
'T' ) )
THEN
449 ELSE IF( lsame( sim,
'F' ) )
THEN
458 IF( modes.EQ.0 .AND. isim.EQ.1 )
THEN
460 IF( ds( j ).EQ.zero )
469 ELSE IF( idist.EQ.-1 )
THEN
471 ELSE IF( abs( mode ).GT.6 )
THEN
473 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
476 ELSE IF( badei )
THEN
478 ELSE IF( irsign.EQ.-1 )
THEN
480 ELSE IF( iupper.EQ.-1 )
THEN
482 ELSE IF( isim.EQ.-1 )
THEN
486 ELSE IF( isim.EQ.1 .AND. abs( modes ).GT.5 )
THEN
488 ELSE IF( isim.EQ.1 .AND. modes.NE.0 .AND. conds.LT.one )
THEN
490 ELSE IF( kl.LT.1 )
THEN
492 ELSE IF( ku.LT.1 .OR. ( ku.LT.n-1 .AND. kl.LT.n-1 ) )
THEN
494 ELSE IF( lda.LT.max( 1, n ) )
THEN
499 CALL xerbla(
'DLATME', -info )
506 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
509 IF( mod( iseed( 4 ), 2 ).NE.1 )
510 $ iseed( 4 ) = iseed( 4 ) + 1
516 CALL dlatm1( mode, cond, irsign, idist, iseed, d, n, iinfo )
517 IF( iinfo.NE.0 )
THEN
521 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
527 temp = max( temp, abs( d( i ) ) )
530 IF( temp.GT.zero )
THEN
532 ELSE IF( dmax.NE.zero )
THEN
539 CALL dscal( n, alpha, d, 1 )
543 CALL dlaset(
'Full', n, n, zero, zero, a, lda )
544 CALL dcopy( n, d, 1, a, lda+1 )
551 IF( lsame( ei( j ),
'I' ) )
THEN
552 a( j-1, j ) = a( j, j )
553 a( j, j-1 ) = -a( j, j )
554 a( j, j ) = a( j-1, j-1 )
559 ELSE IF( abs( mode ).EQ.5 )
THEN
562 IF( dlaran( iseed ).GT.half )
THEN
563 a( j-1, j ) = a( j, j )
564 a( j, j-1 ) = -a( j, j )
565 a( j, j ) = a( j-1, j-1 )
573 IF( iupper.NE.0 )
THEN
575 IF( a( jc-1, jc ).NE.zero )
THEN
580 CALL dlarnv( idist, iseed, jr, a( 1, jc ) )
596 CALL dlatm1( modes, conds, 0, 0, iseed, ds, n, iinfo )
597 IF( iinfo.NE.0 )
THEN
604 CALL dlarge( n, a, lda, iseed, work, iinfo )
605 IF( iinfo.NE.0 )
THEN
613 CALL dscal( n, ds( j ), a( j, 1 ), lda )
614 IF( ds( j ).NE.zero )
THEN
615 CALL dscal( n, one / ds( j ), a( 1, j ), 1 )
624 CALL dlarge( n, a, lda, iseed, work, iinfo )
625 IF( iinfo.NE.0 )
THEN
637 DO 90 jcr = kl + 1, n - 1
642 CALL dcopy( irows, a( jcr, ic ), 1, work, 1 )
644 CALL dlarfg( irows, xnorms, work( 2 ), 1, tau )
647 CALL dgemv(
'T', irows, icols, one, a( jcr, ic+1 ), lda,
648 $ work, 1, zero, work( irows+1 ), 1 )
649 CALL dger( irows, icols, -tau, work, 1, work( irows+1 ), 1,
650 $ a( jcr, ic+1 ), lda )
652 CALL dgemv(
'N', n, irows, one, a( 1, jcr ), lda, work, 1,
653 $ zero, work( irows+1 ), 1 )
654 CALL dger( n, irows, -tau, work( irows+1 ), 1, work, 1,
657 a( jcr, ic ) = xnorms
658 CALL dlaset(
'Full', irows-1, 1, zero, zero, a( jcr+1, ic ),
661 ELSE IF( ku.LT.n-1 )
THEN
665 DO 100 jcr = ku + 1, n - 1
670 CALL dcopy( icols, a( ir, jcr ), lda, work, 1 )
672 CALL dlarfg( icols, xnorms, work( 2 ), 1, tau )
675 CALL dgemv(
'N', irows, icols, one, a( ir+1, jcr ), lda,
676 $ work, 1, zero, work( icols+1 ), 1 )
677 CALL dger( irows, icols, -tau, work( icols+1 ), 1, work, 1,
678 $ a( ir+1, jcr ), lda )
680 CALL dgemv(
'C', icols, n, one, a( jcr, 1 ), lda, work, 1,
681 $ zero, work( icols+1 ), 1 )
682 CALL dger( icols, n, -tau, work, 1, work( icols+1 ), 1,
685 a( ir, jcr ) = xnorms
686 CALL dlaset(
'Full', 1, icols-1, zero, zero, a( ir, jcr+1 ),
693 IF( anorm.GE.zero )
THEN
694 temp = dlange(
'M', n, n, a, lda, tempa )
695 IF( temp.GT.zero )
THEN
698 CALL dscal( n, alpha, a( 1, j ), 1 )
subroutine dlarnv(IDIST, ISEED, N, X)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dscal(N, DA, DX, INCX)
DSCAL
subroutine dger(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
DGER
subroutine dgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
DGEMV
subroutine dlatm1(MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO)
DLATM1
subroutine dlatme(N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
DLATME
subroutine dlarge(N, A, LDA, ISEED, WORK, INFO)
DLARGE
subroutine dlarfg(N, ALPHA, X, INCX, TAU)
DLARFG generates an elementary reflector (Householder matrix).