1 SUBROUTINE zlatms( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
2 $ kl, ku, pack, a, lda, work, info )
9 CHARACTER dist, pack, sym
10 INTEGER info, kl, ku, lda, m, mode, n
11 DOUBLE PRECISION cond, dmax
15 DOUBLE PRECISION d( * )
16 COMPLEX*16 a( lda, * ), work( * )
264 DOUBLE PRECISION zero
265 parameter( zero = 0.0d+0 )
267 parameter( one = 1.0d+0 )
269 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
270 DOUBLE PRECISION twopi
271 parameter( twopi = 6.2831853071795864769252867663d+0 )
274 LOGICAL givens, ilextr, iltemp, topdwn, zsym
275 INTEGER i, ic, icol, idist, iendch, iinfo, il, ilda,
276 $ ioffg, ioffst, ipack, ipackg, ir, ir1, ir2,
277 $ irow, irsign, iskew, isym, isympk, j, jc, jch,
278 $ jkl, jku, jr, k, llb, minlda, mnmin, mr, nc,
280 DOUBLE PRECISION alpha, angle, realc, temp
281 COMPLEX*16 c, ct, ctemp, dummy, extra, s, st
294 INTRINSIC abs, cos, dble, dcmplx, dconjg,
max,
min, mod,
306 IF( m.EQ.0 .OR. n.EQ.0 )
311 IF( lsame( dist,
'U' ) )
THEN
313 ELSE IF( lsame( dist,
'S' ) )
THEN
315 ELSE IF( lsame( dist,
'N' ) )
THEN
323 IF( lsame( sym,
'N' ) )
THEN
327 ELSE IF( lsame( sym,
'P' ) )
THEN
331 ELSE IF( lsame( sym,
'S' ) )
THEN
335 ELSE IF( lsame( sym,
'H' ) )
THEN
346 IF( lsame( pack,
'N' ) )
THEN
348 ELSE IF( lsame( pack,
'U' ) )
THEN
351 ELSE IF( lsame( pack,
'L' ) )
THEN
354 ELSE IF( lsame( pack,
'C' ) )
THEN
357 ELSE IF( lsame( pack,
'R' ) )
THEN
360 ELSE IF( lsame( pack,
'B' ) )
THEN
363 ELSE IF( lsame( pack,
'Q' ) )
THEN
366 ELSE IF( lsame( pack,
'Z' ) )
THEN
380 IF( ipack.EQ.5 .OR. ipack.EQ.6 )
THEN
382 ELSE IF( ipack.EQ.7 )
THEN
383 minlda = llb + uub + 1
393 IF( dble( llb+uub ).LT.0.3d0*dble(
max( 1, mr+nc ) ) )
399 IF( lda.LT.m .AND. lda.GE.minlda )
406 ELSE IF( m.NE.n .AND. isym.NE.1 )
THEN
408 ELSE IF( n.LT.0 )
THEN
410 ELSE IF( idist.EQ.-1 )
THEN
412 ELSE IF( isym.EQ.-1 )
THEN
414 ELSE IF( abs( mode ).GT.6 )
THEN
416 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
419 ELSE IF( kl.LT.0 )
THEN
421 ELSE IF( ku.LT.0 .OR. ( isym.NE.1 .AND. kl.NE.ku ) )
THEN
423 ELSE IF( ipack.EQ.-1 .OR. ( isympk.EQ.1 .AND. isym.EQ.1 ) .OR.
424 $ ( isympk.EQ.2 .AND. isym.EQ.1 .AND. kl.GT.0 ) .OR.
425 $ ( isympk.EQ.3 .AND. isym.EQ.1 .AND. ku.GT.0 ) .OR.
426 $ ( isympk.NE.0 .AND. m.NE.n ) )
THEN
428 ELSE IF( lda.LT.
max( 1, minlda ) )
THEN
433 CALL
xerbla(
'ZLATMS', -info )
440 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
443 IF( mod( iseed( 4 ), 2 ).NE.1 )
444 $ iseed( 4 ) = iseed( 4 ) + 1
450 CALL
dlatm1( mode, cond, irsign, idist, iseed, d, mnmin, iinfo )
451 IF( iinfo.NE.0 )
THEN
459 IF( abs( d( 1 ) ).LE.abs( d( mnmin ) ) )
THEN
465 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
471 temp =
max( temp, abs( d( i ) ) )
474 IF( temp.GT.zero )
THEN
481 CALL dscal( mnmin, alpha, d, 1 )
485 CALL
zlaset(
'Full', lda, n, czero, czero, a, lda )
496 IF( ipack.GT.4 )
THEN
499 IF( ipack.GT.5 )
THEN
519 IF( llb.EQ.0 .AND. uub.EQ.0 )
THEN
521 a( ( 1-iskew )*j+ioffst, j ) = dcmplx( d( j ) )
524 IF( ipack.LE.2 .OR. ipack.GE.5 )
527 ELSE IF( givens )
THEN
536 IF( ipack.GT.4 )
THEN
543 a( ( 1-iskew )*j+ioffst, j ) = dcmplx( d( j ) )
555 DO 60 jr = 1,
min( m+jku, n ) + jkl - 1
557 angle = twopi*
dlarnd( 1, iseed )
558 c = cos( angle )*
zlarnd( 5, iseed )
559 s = sin( angle )*
zlarnd( 5, iseed )
560 icol =
max( 1, jr-jkl )
562 il =
min( n, jr+jku ) + 1 - icol
563 CALL
zlarot( .true., jr.GT.jkl, .false., il, c,
564 $ s, a( jr-iskew*icol+ioffst, icol ),
565 $ ilda, extra, dummy )
572 DO 50 jch = jr - jkl, 1, -jkl - jku
574 CALL
zlartg( a( ir+1-iskew*( ic+1 )+ioffst,
575 $ ic+1 ), extra, realc, s, dummy )
576 dummy =
zlarnd( 5, iseed )
577 c = dconjg( realc*dummy )
578 s = dconjg( -s*dummy )
580 irow =
max( 1, jch-jku )
584 CALL
zlarot( .false., iltemp, .true., il, c, s,
585 $ a( irow-iskew*ic+ioffst, ic ),
586 $ ilda, ctemp, extra )
588 CALL
zlartg( a( irow+1-iskew*( ic+1 )+ioffst,
589 $ ic+1 ), ctemp, realc, s, dummy )
590 dummy =
zlarnd( 5, iseed )
591 c = dconjg( realc*dummy )
592 s = dconjg( -s*dummy )
594 icol =
max( 1, jch-jku-jkl )
597 CALL
zlarot( .true., jch.GT.jku+jkl, .true.,
598 $ il, c, s, a( irow-iskew*icol+
599 $ ioffst, icol ), ilda, extra,
613 DO 90 jc = 1,
min( n+jkl, m ) + jku - 1
615 angle = twopi*
dlarnd( 1, iseed )
616 c = cos( angle )*
zlarnd( 5, iseed )
617 s = sin( angle )*
zlarnd( 5, iseed )
618 irow =
max( 1, jc-jku )
620 il =
min( m, jc+jkl ) + 1 - irow
621 CALL
zlarot( .false., jc.GT.jku, .false., il, c,
622 $ s, a( irow-iskew*jc+ioffst, jc ),
623 $ ilda, extra, dummy )
630 DO 80 jch = jc - jku, 1, -jkl - jku
632 CALL
zlartg( a( ir+1-iskew*( ic+1 )+ioffst,
633 $ ic+1 ), extra, realc, s, dummy )
634 dummy =
zlarnd( 5, iseed )
635 c = dconjg( realc*dummy )
636 s = dconjg( -s*dummy )
638 icol =
max( 1, jch-jkl )
642 CALL
zlarot( .true., iltemp, .true., il, c, s,
643 $ a( ir-iskew*icol+ioffst, icol ),
644 $ ilda, ctemp, extra )
646 CALL
zlartg( a( ir+1-iskew*( icol+1 )+ioffst,
647 $ icol+1 ), ctemp, realc, s,
649 dummy =
zlarnd( 5, iseed )
650 c = dconjg( realc*dummy )
651 s = dconjg( -s*dummy )
652 irow =
max( 1, jch-jkl-jku )
655 CALL
zlarot( .false., jch.GT.jkl+jku, .true.,
656 $ il, c, s, a( irow-iskew*icol+
657 $ ioffst, icol ), ilda, extra,
678 iendch =
min( m, n+jkl ) - 1
679 DO 120 jc =
min( m+jku, n ) - 1, 1 - jkl, -1
681 angle = twopi*
dlarnd( 1, iseed )
682 c = cos( angle )*
zlarnd( 5, iseed )
683 s = sin( angle )*
zlarnd( 5, iseed )
684 irow =
max( 1, jc-jku+1 )
686 il =
min( m, jc+jkl+1 ) + 1 - irow
687 CALL
zlarot( .false., .false., jc+jkl.LT.m, il,
688 $ c, s, a( irow-iskew*jc+ioffst,
689 $ jc ), ilda, dummy, extra )
695 DO 110 jch = jc + jkl, iendch, jkl + jku
698 CALL
zlartg( a( jch-iskew*ic+ioffst, ic ),
699 $ extra, realc, s, dummy )
700 dummy =
zlarnd( 5, iseed )
705 icol =
min( n-1, jch+jku )
706 iltemp = jch + jku.LT.n
708 CALL
zlarot( .true., ilextr, iltemp, icol+2-ic,
709 $ c, s, a( jch-iskew*ic+ioffst, ic ),
710 $ ilda, extra, ctemp )
712 CALL
zlartg( a( jch-iskew*icol+ioffst,
713 $ icol ), ctemp, realc, s, dummy )
714 dummy =
zlarnd( 5, iseed )
717 il =
min( iendch, jch+jkl+jku ) + 2 - jch
719 CALL
zlarot( .false., .true.,
720 $ jch+jkl+jku.LE.iendch, il, c, s,
721 $ a( jch-iskew*icol+ioffst,
722 $ icol ), ilda, ctemp, extra )
737 iendch =
min( n, m+jku ) - 1
738 DO 150 jr =
min( n+jkl, m ) - 1, 1 - jku, -1
740 angle = twopi*
dlarnd( 1, iseed )
741 c = cos( angle )*
zlarnd( 5, iseed )
742 s = sin( angle )*
zlarnd( 5, iseed )
743 icol =
max( 1, jr-jkl+1 )
745 il =
min( n, jr+jku+1 ) + 1 - icol
746 CALL
zlarot( .true., .false., jr+jku.LT.n, il,
747 $ c, s, a( jr-iskew*icol+ioffst,
748 $ icol ), ilda, dummy, extra )
754 DO 140 jch = jr + jku, iendch, jkl + jku
757 CALL
zlartg( a( ir-iskew*jch+ioffst, jch ),
758 $ extra, realc, s, dummy )
759 dummy =
zlarnd( 5, iseed )
764 irow =
min( m-1, jch+jkl )
765 iltemp = jch + jkl.LT.m
767 CALL
zlarot( .false., ilextr, iltemp, irow+2-ir,
768 $ c, s, a( ir-iskew*jch+ioffst,
769 $ jch ), ilda, extra, ctemp )
771 CALL
zlartg( a( irow-iskew*jch+ioffst, jch ),
772 $ ctemp, realc, s, dummy )
773 dummy =
zlarnd( 5, iseed )
776 il =
min( iendch, jch+jkl+jku ) + 2 - jch
778 CALL
zlarot( .true., .true.,
779 $ jch+jkl+jku.LE.iendch, il, c, s,
780 $ a( irow-iskew*jch+ioffst, jch ),
781 $ ilda, ctemp, extra )
802 IF( ipack.GE.5 )
THEN
810 a( ( 1-iskew )*j+ioffg, j ) = dcmplx( d( j ) )
815 irow =
max( 1, jc-k )
816 il =
min( jc+1, k+2 )
818 ctemp = a( jc-iskew*( jc+1 )+ioffg, jc+1 )
819 angle = twopi*
dlarnd( 1, iseed )
820 c = cos( angle )*
zlarnd( 5, iseed )
821 s = sin( angle )*
zlarnd( 5, iseed )
826 ctemp = dconjg( ctemp )
830 CALL
zlarot( .false., jc.GT.k, .true., il, c, s,
831 $ a( irow-iskew*jc+ioffg, jc ), ilda,
833 CALL
zlarot( .true., .true., .false.,
834 $
min( k, n-jc )+1, ct, st,
835 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
841 DO 180 jch = jc - k, 1, -k
842 CALL
zlartg( a( jch+1-iskew*( icol+1 )+ioffg,
843 $ icol+1 ), extra, realc, s, dummy )
844 dummy =
zlarnd( 5, iseed )
845 c = dconjg( realc*dummy )
846 s = dconjg( -s*dummy )
847 ctemp = a( jch-iskew*( jch+1 )+ioffg, jch+1 )
852 ctemp = dconjg( ctemp )
856 CALL
zlarot( .true., .true., .true., k+2, c, s,
857 $ a( ( 1-iskew )*jch+ioffg, jch ),
858 $ ilda, ctemp, extra )
859 irow =
max( 1, jch-k )
860 il =
min( jch+1, k+2 )
862 CALL
zlarot( .false., jch.GT.k, .true., il, ct,
863 $ st, a( irow-iskew*jch+ioffg, jch ),
864 $ ilda, extra, ctemp )
873 IF( ipack.NE.ipackg .AND. ipack.NE.3 )
THEN
875 irow = ioffst - iskew*jc
877 DO 210 jr = jc,
min( n, jc+uub )
878 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
881 DO 220 jr = jc,
min( n, jc+uub )
882 a( jr+irow, jc ) = dconjg( a( jc-iskew*jr+
887 IF( ipack.EQ.5 )
THEN
888 DO 250 jc = n - uub + 1, n
889 DO 240 jr = n + 2 - jc, uub + 1
894 IF( ipackg.EQ.6 )
THEN
904 IF( ipack.GE.5 )
THEN
913 a( ( 1-iskew )*j+ioffg, j ) = dcmplx( d( j ) )
917 DO 280 jc = n - 1, 1, -1
918 il =
min( n+1-jc, k+2 )
920 ctemp = a( 1+( 1-iskew )*jc+ioffg, jc )
921 angle = twopi*
dlarnd( 1, iseed )
922 c = cos( angle )*
zlarnd( 5, iseed )
923 s = sin( angle )*
zlarnd( 5, iseed )
928 ctemp = dconjg( ctemp )
932 CALL
zlarot( .false., .true., n-jc.GT.k, il, c, s,
933 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
935 icol =
max( 1, jc-k+1 )
936 CALL
zlarot( .true., .false., .true., jc+2-icol,
937 $ ct, st, a( jc-iskew*icol+ioffg,
938 $ icol ), ilda, dummy, ctemp )
943 DO 270 jch = jc + k, n - 1, k
944 CALL
zlartg( a( jch-iskew*icol+ioffg, icol ),
945 $ extra, realc, s, dummy )
946 dummy =
zlarnd( 5, iseed )
949 ctemp = a( 1+( 1-iskew )*jch+ioffg, jch )
954 ctemp = dconjg( ctemp )
958 CALL
zlarot( .true., .true., .true., k+2, c, s,
959 $ a( jch-iskew*icol+ioffg, icol ),
960 $ ilda, extra, ctemp )
961 il =
min( n+1-jch, k+2 )
963 CALL
zlarot( .false., .true., n-jch.GT.k, il,
964 $ ct, st, a( ( 1-iskew )*jch+ioffg,
965 $ jch ), ilda, ctemp, extra )
974 IF( ipack.NE.ipackg .AND. ipack.NE.4 )
THEN
976 irow = ioffst - iskew*jc
978 DO 300 jr = jc,
max( 1, jc-uub ), -1
979 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
982 DO 310 jr = jc,
max( 1, jc-uub ), -1
983 a( jr+irow, jc ) = dconjg( a( jc-iskew*jr+
988 IF( ipack.EQ.6 )
THEN
990 DO 330 jr = 1, uub + 1 - jc
995 IF( ipackg.EQ.5 )
THEN
1005 IF( .NOT.zsym )
THEN
1007 irow = ioffst + ( 1-iskew )*jc
1008 a( irow, jc ) = dcmplx( dble( a( irow, jc ) ) )
1023 IF( isym.EQ.1 )
THEN
1027 CALL
zlagge( mr, nc, llb, uub, d, a, lda, iseed, work,
1035 CALL
zlagsy( m, llb, d, a, lda, iseed, work, iinfo )
1037 CALL zlaghe( m, llb, d, a, lda, iseed, work, iinfo )
1041 IF( iinfo.NE.0 )
THEN
1049 IF( ipack.NE.ipackg )
THEN
1050 IF( ipack.EQ.1 )
THEN
1060 ELSE IF( ipack.EQ.2 )
THEN
1070 ELSE IF( ipack.EQ.3 )
THEN
1079 IF( irow.GT.lda )
THEN
1083 a( irow, icol ) = a( i, j )
1087 ELSE IF( ipack.EQ.4 )
THEN
1096 IF( irow.GT.lda )
THEN
1100 a( irow, icol ) = a( i, j )
1104 ELSE IF( ipack.GE.5 )
THEN
1116 DO 440 i =
min( j+llb, m ), 1, -1
1117 a( i-j+uub+1, j ) = a( i, j )
1121 DO 470 j = uub + 2, n
1122 DO 460 i = j - uub,
min( j+llb, m )
1123 a( i-j+uub+1, j ) = a( i, j )
1133 IF( ipack.EQ.3 .OR. ipack.EQ.4 )
THEN
1135 DO 480 jr = irow + 1, lda
1141 ELSE IF( ipack.GE.5 )
THEN
1152 DO 500 jr = 1, uub + 1 - jc
1155 DO 510 jr =
max( 1,
min( ir1, ir2-jc ) ), lda