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 )
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 )
LOGICAL function lsame(CA, CB)
LSAME
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
COMPLEX *16 function zlarnd(IDIST, ISEED)
ZLARND
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine zgerc(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERC
DOUBLE PRECISION function zlange(NORM, M, N, A, LDA, WORK)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zlacgv(N, X, INCX)
ZLACGV conjugates a complex vector.
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
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 zlatme(N, DIST, ISEED, D, MODE, COND, DMAX, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
ZLATME
subroutine zlarnv(IDIST, ISEED, N, X)
ZLARNV 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 zlarfg(N, ALPHA, X, INCX, TAU)
ZLARFG generates an elementary reflector (Householder matrix).
subroutine zlatm1(MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO)
ZLATM1
subroutine zlarge(N, A, LDA, ISEED, WORK, INFO)
ZLARGE
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL
subroutine dlatm1(MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO)
DLATM1