298 SUBROUTINE zlatme( N, DIST, ISEED, D, MODE, COND, DMAX,
300 $ upper, sim, ds, modes, conds, kl, ku, anorm,
310 CHARACTER DIST, RSIGN, SIM, UPPER
311 INTEGER INFO, KL, KU, LDA, MODE, MODES, N
312 DOUBLE PRECISION ANORM, COND, CONDS
317 DOUBLE PRECISION DS( * )
318 COMPLEX*16 A( lda, * ), D( * ), WORK( * )
324 DOUBLE PRECISION ZERO
325 parameter ( zero = 0.0d+0 )
327 parameter ( one = 1.0d+0 )
329 parameter ( czero = ( 0.0d+0, 0.0d+0 ) )
331 parameter ( cone = ( 1.0d+0, 0.0d+0 ) )
335 INTEGER I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN,
336 $ isim, iupper, j, jc, jcr
337 DOUBLE PRECISION RALPHA, TEMP
338 COMPLEX*16 ALPHA, TAU, XNORMS
341 DOUBLE PRECISION TEMPA( 1 )
345 DOUBLE PRECISION ZLANGE
347 EXTERNAL lsame, zlange, zlarnd
355 INTRINSIC abs, dconjg, max, mod
371 IF( lsame( dist,
'U' ) )
THEN
373 ELSE IF( lsame( dist,
'S' ) )
THEN
375 ELSE IF( lsame( dist,
'N' ) )
THEN
377 ELSE IF( lsame( dist,
'D' ) )
THEN
385 IF( lsame( rsign,
'T' ) )
THEN
387 ELSE IF( lsame( rsign,
'F' ) )
THEN
395 IF( lsame( upper,
'T' ) )
THEN
397 ELSE IF( lsame( upper,
'F' ) )
THEN
405 IF( lsame( sim,
'T' ) )
THEN
407 ELSE IF( lsame( sim,
'F' ) )
THEN
416 IF( modes.EQ.0 .AND. isim.EQ.1 )
THEN
418 IF( ds( j ).EQ.zero )
427 ELSE IF( idist.EQ.-1 )
THEN
429 ELSE IF( abs( mode ).GT.6 )
THEN
431 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
434 ELSE IF( irsign.EQ.-1 )
THEN
436 ELSE IF( iupper.EQ.-1 )
THEN
438 ELSE IF( isim.EQ.-1 )
THEN
442 ELSE IF( isim.EQ.1 .AND. abs( modes ).GT.5 )
THEN
444 ELSE IF( isim.EQ.1 .AND. modes.NE.0 .AND. conds.LT.one )
THEN
446 ELSE IF( kl.LT.1 )
THEN
448 ELSE IF( ku.LT.1 .OR. ( ku.LT.n-1 .AND. kl.LT.n-1 ) )
THEN
450 ELSE IF( lda.LT.max( 1, n ) )
THEN
455 CALL xerbla(
'ZLATME', -info )
462 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
465 IF( mod( iseed( 4 ), 2 ).NE.1 )
466 $ iseed( 4 ) = iseed( 4 ) + 1
472 CALL zlatm1( mode, cond, irsign, idist, iseed, d, n, iinfo )
473 IF( iinfo.NE.0 )
THEN
477 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
483 temp = max( temp, abs( d( i ) ) )
486 IF( temp.GT.zero )
THEN
493 CALL zscal( n, alpha, d, 1 )
497 CALL zlaset(
'Full', n, n, czero, czero, a, lda )
498 CALL zcopy( n, d, 1, a, lda+1 )
502 IF( iupper.NE.0 )
THEN
504 CALL zlarnv( idist, iseed, jc-1, a( 1, jc ) )
520 CALL dlatm1( modes, conds, 0, 0, iseed, ds, n, iinfo )
521 IF( iinfo.NE.0 )
THEN
528 CALL zlarge( n, a, lda, iseed, work, iinfo )
529 IF( iinfo.NE.0 )
THEN
537 CALL zdscal( n, ds( j ), a( j, 1 ), lda )
538 IF( ds( j ).NE.zero )
THEN
539 CALL zdscal( n, one / ds( j ), a( 1, j ), 1 )
548 CALL zlarge( n, a, lda, iseed, work, iinfo )
549 IF( iinfo.NE.0 )
THEN
561 DO 60 jcr = kl + 1, n - 1
566 CALL zcopy( irows, a( jcr, ic ), 1, work, 1 )
568 CALL zlarfg( irows, xnorms, work( 2 ), 1, tau )
571 alpha = zlarnd( 5, iseed )
573 CALL zgemv(
'C', irows, icols, cone, a( jcr, ic+1 ), lda,
574 $ work, 1, czero, work( irows+1 ), 1 )
575 CALL zgerc( irows, icols, -tau, work, 1, work( irows+1 ), 1,
576 $ a( jcr, ic+1 ), lda )
578 CALL zgemv(
'N', n, irows, cone, a( 1, jcr ), lda, work, 1,
579 $ czero, work( irows+1 ), 1 )
580 CALL zgerc( n, irows, -dconjg( tau ), work( irows+1 ), 1,
581 $ work, 1, a( 1, jcr ), lda )
583 a( jcr, ic ) = xnorms
584 CALL zlaset(
'Full', irows-1, 1, czero, czero,
585 $ a( jcr+1, ic ), lda )
587 CALL zscal( icols+1, alpha, a( jcr, ic ), lda )
588 CALL zscal( n, dconjg( alpha ), a( 1, jcr ), 1 )
590 ELSE IF( ku.LT.n-1 )
THEN
594 DO 70 jcr = ku + 1, n - 1
599 CALL zcopy( icols, a( ir, jcr ), lda, work, 1 )
601 CALL zlarfg( icols, xnorms, work( 2 ), 1, tau )
604 CALL zlacgv( icols-1, work( 2 ), 1 )
605 alpha = zlarnd( 5, iseed )
607 CALL zgemv(
'N', irows, icols, cone, a( ir+1, jcr ), lda,
608 $ work, 1, czero, work( icols+1 ), 1 )
609 CALL zgerc( irows, icols, -tau, work( icols+1 ), 1, work, 1,
610 $ a( ir+1, jcr ), lda )
612 CALL zgemv(
'C', icols, n, cone, a( jcr, 1 ), lda, work, 1,
613 $ czero, work( icols+1 ), 1 )
614 CALL zgerc( icols, n, -dconjg( tau ), work, 1,
615 $ work( icols+1 ), 1, a( jcr, 1 ), lda )
617 a( ir, jcr ) = xnorms
618 CALL zlaset(
'Full', 1, icols-1, czero, czero,
619 $ a( ir, jcr+1 ), lda )
621 CALL zscal( irows+1, alpha, a( ir, jcr ), 1 )
622 CALL zscal( n, dconjg( alpha ), a( jcr, 1 ), lda )
628 IF( anorm.GE.zero )
THEN
629 temp = zlange(
'M', n, n, a, lda, tempa )
630 IF( temp.GT.zero )
THEN
631 ralpha = anorm / temp
633 CALL zdscal( n, ralpha, a( 1, j ), 1 )
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine dlatm1(MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO)
DLATM1
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
subroutine zlarge(N, A, LDA, ISEED, WORK, INFO)
ZLARGE
subroutine zgerc(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERC
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine zlacgv(N, X, INCX)
ZLACGV conjugates a complex vector.
subroutine zlatme(N, DIST, ISEED, D, MODE, COND, DMAX, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
ZLATME
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine zlarnv(IDIST, ISEED, N, X)
ZLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine zlatm1(MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO)
ZLATM1
subroutine zlarfg(N, ALPHA, X, INCX, TAU)
ZLARFG generates an elementary reflector (Householder matrix).
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL