332 SUBROUTINE zlatms( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
333 $ kl, ku, pack, a, lda, work, info )
341 CHARACTER dist, pack, sym
342 INTEGER info, kl, ku, lda, m, mode, n
343 DOUBLE PRECISION cond, dmax
347 DOUBLE PRECISION d( * )
348 COMPLEX*16 a( lda, * ), work( * )
354 DOUBLE PRECISION zero
355 parameter( zero = 0.0d+0 )
357 parameter( one = 1.0d+0 )
359 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
360 DOUBLE PRECISION twopi
361 parameter( twopi = 6.2831853071795864769252867663d+0 )
364 LOGICAL givens, ilextr, iltemp, topdwn, zsym
365 INTEGER i, ic, icol, idist, iendch, iinfo, il, ilda,
366 $ ioffg, ioffst, ipack, ipackg, ir, ir1, ir2,
367 $ irow, irsign, iskew, isym, isympk,
j, jc, jch,
368 $ jkl, jku, jr, k, llb, minlda, mnmin, mr, nc,
370 DOUBLE PRECISION alpha, angle, realc, temp
371 COMPLEX*16 c, ct, ctemp, dummy, extra, s, st
384 INTRINSIC abs, cos, dble, dcmplx, dconjg, max, min, mod,
396 IF( m.EQ.0 .OR. n.EQ.0 )
401 IF(
lsame( dist,
'U' ) )
THEN
403 ELSE IF(
lsame( dist,
'S' ) )
THEN
405 ELSE IF(
lsame( dist,
'N' ) )
THEN
413 IF(
lsame( sym,
'N' ) )
THEN
417 ELSE IF(
lsame( sym,
'P' ) )
THEN
421 ELSE IF(
lsame( sym,
'S' ) )
THEN
425 ELSE IF(
lsame( sym,
'H' ) )
THEN
436 IF(
lsame( pack,
'N' ) )
THEN
438 ELSE IF(
lsame( pack,
'U' ) )
THEN
441 ELSE IF(
lsame( pack,
'L' ) )
THEN
444 ELSE IF(
lsame( pack,
'C' ) )
THEN
447 ELSE IF(
lsame( pack,
'R' ) )
THEN
450 ELSE IF(
lsame( pack,
'B' ) )
THEN
453 ELSE IF(
lsame( pack,
'Q' ) )
THEN
456 ELSE IF(
lsame( pack,
'Z' ) )
THEN
470 IF( ipack.EQ.5 .OR. ipack.EQ.6 )
THEN
472 ELSE IF( ipack.EQ.7 )
THEN
473 minlda = llb + uub + 1
483 IF( dble( llb+uub ).LT.0.3d0*dble( max( 1, mr+nc ) ) )
489 IF( lda.LT.m .AND. lda.GE.minlda )
496 ELSE IF( m.NE.n .AND. isym.NE.1 )
THEN
498 ELSE IF( n.LT.0 )
THEN
500 ELSE IF( idist.EQ.-1 )
THEN
502 ELSE IF( isym.EQ.-1 )
THEN
504 ELSE IF( abs( mode ).GT.6 )
THEN
506 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
509 ELSE IF( kl.LT.0 )
THEN
511 ELSE IF( ku.LT.0 .OR. ( isym.NE.1 .AND. kl.NE.ku ) )
THEN
513 ELSE IF( ipack.EQ.-1 .OR. ( isympk.EQ.1 .AND. isym.EQ.1 ) .OR.
514 $ ( isympk.EQ.2 .AND. isym.EQ.1 .AND. kl.GT.0 ) .OR.
515 $ ( isympk.EQ.3 .AND. isym.EQ.1 .AND. ku.GT.0 ) .OR.
516 $ ( isympk.NE.0 .AND. m.NE.n ) )
THEN
518 ELSE IF( lda.LT.max( 1, minlda ) )
THEN
523 CALL
xerbla(
'ZLATMS', -info )
530 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
533 IF( mod( iseed( 4 ), 2 ).NE.1 )
534 $ iseed( 4 ) = iseed( 4 ) + 1
540 CALL
dlatm1( mode, cond, irsign, idist, iseed, d, mnmin, iinfo )
541 IF( iinfo.NE.0 )
THEN
549 IF( abs( d( 1 ) ).LE.abs( d( mnmin ) ) )
THEN
555 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
561 temp = max( temp, abs( d( i ) ) )
564 IF( temp.GT.zero )
THEN
571 CALL
dscal( mnmin, alpha, d, 1 )
575 CALL
zlaset(
'Full', lda, n, czero, czero, a, lda )
586 IF( ipack.GT.4 )
THEN
589 IF( ipack.GT.5 )
THEN
609 IF( llb.EQ.0 .AND. uub.EQ.0 )
THEN
611 a( ( 1-iskew )*
j+ioffst,
j ) = dcmplx( d(
j ) )
614 IF( ipack.LE.2 .OR. ipack.GE.5 )
617 ELSE IF( givens )
THEN
626 IF( ipack.GT.4 )
THEN
633 a( ( 1-iskew )*
j+ioffst,
j ) = dcmplx( d(
j ) )
645 DO 60 jr = 1, min( m+jku, n ) + jkl - 1
647 angle = twopi*
dlarnd( 1, iseed )
648 c = cos( angle )*
zlarnd( 5, iseed )
649 s = sin( angle )*
zlarnd( 5, iseed )
650 icol = max( 1, jr-jkl )
652 il = min( n, jr+jku ) + 1 - icol
653 CALL
zlarot( .true., jr.GT.jkl, .false., il, c,
654 $ s, a( jr-iskew*icol+ioffst, icol ),
655 $ ilda, extra, dummy )
662 DO 50 jch = jr - jkl, 1, -jkl - jku
664 CALL
zlartg( a( ir+1-iskew*( ic+1 )+ioffst,
665 $ ic+1 ), extra, realc, s, dummy )
666 dummy =
zlarnd( 5, iseed )
667 c = dconjg( realc*dummy )
668 s = dconjg( -s*dummy )
670 irow = max( 1, jch-jku )
674 CALL
zlarot( .false., iltemp, .true., il, c, s,
675 $ a( irow-iskew*ic+ioffst, ic ),
676 $ ilda, ctemp, extra )
678 CALL
zlartg( a( irow+1-iskew*( ic+1 )+ioffst,
679 $ ic+1 ), ctemp, realc, s, dummy )
680 dummy =
zlarnd( 5, iseed )
681 c = dconjg( realc*dummy )
682 s = dconjg( -s*dummy )
684 icol = max( 1, jch-jku-jkl )
687 CALL
zlarot( .true., jch.GT.jku+jkl, .true.,
688 $ il, c, s, a( irow-iskew*icol+
689 $ ioffst, icol ), ilda, extra,
703 DO 90 jc = 1, min( n+jkl, m ) + jku - 1
705 angle = twopi*
dlarnd( 1, iseed )
706 c = cos( angle )*
zlarnd( 5, iseed )
707 s = sin( angle )*
zlarnd( 5, iseed )
708 irow = max( 1, jc-jku )
710 il = min( m, jc+jkl ) + 1 - irow
711 CALL
zlarot( .false., jc.GT.jku, .false., il, c,
712 $ s, a( irow-iskew*jc+ioffst, jc ),
713 $ ilda, extra, dummy )
720 DO 80 jch = jc - jku, 1, -jkl - jku
722 CALL
zlartg( a( ir+1-iskew*( ic+1 )+ioffst,
723 $ ic+1 ), extra, realc, s, dummy )
724 dummy =
zlarnd( 5, iseed )
725 c = dconjg( realc*dummy )
726 s = dconjg( -s*dummy )
728 icol = max( 1, jch-jkl )
732 CALL
zlarot( .true., iltemp, .true., il, c, s,
733 $ a( ir-iskew*icol+ioffst, icol ),
734 $ ilda, ctemp, extra )
736 CALL
zlartg( a( ir+1-iskew*( icol+1 )+ioffst,
737 $ icol+1 ), ctemp, realc, s,
739 dummy =
zlarnd( 5, iseed )
740 c = dconjg( realc*dummy )
741 s = dconjg( -s*dummy )
742 irow = max( 1, jch-jkl-jku )
745 CALL
zlarot( .false., jch.GT.jkl+jku, .true.,
746 $ il, c, s, a( irow-iskew*icol+
747 $ ioffst, icol ), ilda, extra,
768 iendch = min( m, n+jkl ) - 1
769 DO 120 jc = min( m+jku, n ) - 1, 1 - jkl, -1
771 angle = twopi*
dlarnd( 1, iseed )
772 c = cos( angle )*
zlarnd( 5, iseed )
773 s = sin( angle )*
zlarnd( 5, iseed )
774 irow = max( 1, jc-jku+1 )
776 il = min( m, jc+jkl+1 ) + 1 - irow
777 CALL
zlarot( .false., .false., jc+jkl.LT.m, il,
778 $ c, s, a( irow-iskew*jc+ioffst,
779 $ jc ), ilda, dummy, extra )
785 DO 110 jch = jc + jkl, iendch, jkl + jku
788 CALL
zlartg( a( jch-iskew*ic+ioffst, ic ),
789 $ extra, realc, s, dummy )
790 dummy =
zlarnd( 5, iseed )
795 icol = min( n-1, jch+jku )
796 iltemp = jch + jku.LT.n
798 CALL
zlarot( .true., ilextr, iltemp, icol+2-ic,
799 $ c, s, a( jch-iskew*ic+ioffst, ic ),
800 $ ilda, extra, ctemp )
802 CALL
zlartg( a( jch-iskew*icol+ioffst,
803 $ icol ), ctemp, realc, s, dummy )
804 dummy =
zlarnd( 5, iseed )
807 il = min( iendch, jch+jkl+jku ) + 2 - jch
809 CALL
zlarot( .false., .true.,
810 $ jch+jkl+jku.LE.iendch, il, c, s,
811 $ a( jch-iskew*icol+ioffst,
812 $ icol ), ilda, ctemp, extra )
827 iendch = min( n, m+jku ) - 1
828 DO 150 jr = min( n+jkl, m ) - 1, 1 - jku, -1
830 angle = twopi*
dlarnd( 1, iseed )
831 c = cos( angle )*
zlarnd( 5, iseed )
832 s = sin( angle )*
zlarnd( 5, iseed )
833 icol = max( 1, jr-jkl+1 )
835 il = min( n, jr+jku+1 ) + 1 - icol
836 CALL
zlarot( .true., .false., jr+jku.LT.n, il,
837 $ c, s, a( jr-iskew*icol+ioffst,
838 $ icol ), ilda, dummy, extra )
844 DO 140 jch = jr + jku, iendch, jkl + jku
847 CALL
zlartg( a( ir-iskew*jch+ioffst, jch ),
848 $ extra, realc, s, dummy )
849 dummy =
zlarnd( 5, iseed )
854 irow = min( m-1, jch+jkl )
855 iltemp = jch + jkl.LT.m
857 CALL
zlarot( .false., ilextr, iltemp, irow+2-ir,
858 $ c, s, a( ir-iskew*jch+ioffst,
859 $ jch ), ilda, extra, ctemp )
861 CALL
zlartg( a( irow-iskew*jch+ioffst, jch ),
862 $ ctemp, realc, s, dummy )
863 dummy =
zlarnd( 5, iseed )
866 il = min( iendch, jch+jkl+jku ) + 2 - jch
868 CALL
zlarot( .true., .true.,
869 $ jch+jkl+jku.LE.iendch, il, c, s,
870 $ a( irow-iskew*jch+ioffst, jch ),
871 $ ilda, ctemp, extra )
892 IF( ipack.GE.5 )
THEN
900 a( ( 1-iskew )*
j+ioffg,
j ) = dcmplx( d(
j ) )
905 irow = max( 1, jc-k )
906 il = min( jc+1, k+2 )
908 ctemp = a( jc-iskew*( jc+1 )+ioffg, jc+1 )
909 angle = twopi*
dlarnd( 1, iseed )
910 c = cos( angle )*
zlarnd( 5, iseed )
911 s = sin( angle )*
zlarnd( 5, iseed )
916 ctemp = dconjg( ctemp )
920 CALL
zlarot( .false., jc.GT.k, .true., il, c, s,
921 $ a( irow-iskew*jc+ioffg, jc ), ilda,
923 CALL
zlarot( .true., .true., .false.,
924 $ min( k, n-jc )+1, ct, st,
925 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
931 DO 180 jch = jc - k, 1, -k
932 CALL
zlartg( a( jch+1-iskew*( icol+1 )+ioffg,
933 $ icol+1 ), extra, realc, s, dummy )
934 dummy =
zlarnd( 5, iseed )
935 c = dconjg( realc*dummy )
936 s = dconjg( -s*dummy )
937 ctemp = a( jch-iskew*( jch+1 )+ioffg, jch+1 )
942 ctemp = dconjg( ctemp )
946 CALL
zlarot( .true., .true., .true., k+2, c, s,
947 $ a( ( 1-iskew )*jch+ioffg, jch ),
948 $ ilda, ctemp, extra )
949 irow = max( 1, jch-k )
950 il = min( jch+1, k+2 )
952 CALL
zlarot( .false., jch.GT.k, .true., il, ct,
953 $ st, a( irow-iskew*jch+ioffg, jch ),
954 $ ilda, extra, ctemp )
963 IF( ipack.NE.ipackg .AND. ipack.NE.3 )
THEN
965 irow = ioffst - iskew*jc
967 DO 210 jr = jc, min( n, jc+uub )
968 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
971 DO 220 jr = jc, min( n, jc+uub )
972 a( jr+irow, jc ) = dconjg( a( jc-iskew*jr+
977 IF( ipack.EQ.5 )
THEN
978 DO 250 jc = n - uub + 1, n
979 DO 240 jr = n + 2 - jc, uub + 1
984 IF( ipackg.EQ.6 )
THEN
994 IF( ipack.GE.5 )
THEN
1003 a( ( 1-iskew )*
j+ioffg,
j ) = dcmplx( d(
j ) )
1007 DO 280 jc = n - 1, 1, -1
1008 il = min( n+1-jc, k+2 )
1010 ctemp = a( 1+( 1-iskew )*jc+ioffg, jc )
1011 angle = twopi*
dlarnd( 1, iseed )
1012 c = cos( angle )*
zlarnd( 5, iseed )
1013 s = sin( angle )*
zlarnd( 5, iseed )
1018 ctemp = dconjg( ctemp )
1022 CALL
zlarot( .false., .true., n-jc.GT.k, il, c, s,
1023 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
1025 icol = max( 1, jc-k+1 )
1026 CALL
zlarot( .true., .false., .true., jc+2-icol,
1027 $ ct, st, a( jc-iskew*icol+ioffg,
1028 $ icol ), ilda, dummy, ctemp )
1033 DO 270 jch = jc + k, n - 1, k
1034 CALL
zlartg( a( jch-iskew*icol+ioffg, icol ),
1035 $ extra, realc, s, dummy )
1036 dummy =
zlarnd( 5, iseed )
1039 ctemp = a( 1+( 1-iskew )*jch+ioffg, jch )
1044 ctemp = dconjg( ctemp )
1048 CALL
zlarot( .true., .true., .true., k+2, c, s,
1049 $ a( jch-iskew*icol+ioffg, icol ),
1050 $ ilda, extra, ctemp )
1051 il = min( n+1-jch, k+2 )
1053 CALL
zlarot( .false., .true., n-jch.GT.k, il,
1054 $ ct, st, a( ( 1-iskew )*jch+ioffg,
1055 $ jch ), ilda, ctemp, extra )
1064 IF( ipack.NE.ipackg .AND. ipack.NE.4 )
THEN
1065 DO 320 jc = n, 1, -1
1066 irow = ioffst - iskew*jc
1068 DO 300 jr = jc, max( 1, jc-uub ), -1
1069 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
1072 DO 310 jr = jc, max( 1, jc-uub ), -1
1073 a( jr+irow, jc ) = dconjg( a( jc-iskew*jr+
1078 IF( ipack.EQ.6 )
THEN
1080 DO 330 jr = 1, uub + 1 - jc
1085 IF( ipackg.EQ.5 )
THEN
1095 IF( .NOT.zsym )
THEN
1097 irow = ioffst + ( 1-iskew )*jc
1098 a( irow, jc ) = dcmplx( dble( a( irow, jc ) ) )
1113 IF( isym.EQ.1 )
THEN
1117 CALL
zlagge( mr, nc, llb, uub, d, a, lda, iseed, work,
1125 CALL
zlagsy( m, llb, d, a, lda, iseed, work, iinfo )
1127 CALL
zlaghe( m, llb, d, a, lda, iseed, work, iinfo )
1131 IF( iinfo.NE.0 )
THEN
1139 IF( ipack.NE.ipackg )
THEN
1140 IF( ipack.EQ.1 )
THEN
1150 ELSE IF( ipack.EQ.2 )
THEN
1160 ELSE IF( ipack.EQ.3 )
THEN
1169 IF( irow.GT.lda )
THEN
1173 a( irow, icol ) = a( i,
j )
1177 ELSE IF( ipack.EQ.4 )
THEN
1186 IF( irow.GT.lda )
THEN
1190 a( irow, icol ) = a( i,
j )
1194 ELSE IF( ipack.GE.5 )
THEN
1206 DO 440 i = min(
j+llb, m ), 1, -1
1207 a( i-
j+uub+1,
j ) = a( i,
j )
1211 DO 470
j = uub + 2, n
1212 DO 460 i =
j - uub, min(
j+llb, m )
1213 a( i-
j+uub+1,
j ) = a( i,
j )
1223 IF( ipack.EQ.3 .OR. ipack.EQ.4 )
THEN
1225 DO 480 jr = irow + 1, lda
1231 ELSE IF( ipack.GE.5 )
THEN
1242 DO 500 jr = 1, uub + 1 - jc
1245 DO 510 jr = max( 1, min( ir1, ir2-jc ) ), lda
subroutine zlagge(M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO)
ZLAGGE
double precision function dlarnd(IDIST, ISEED)
DLARND
subroutine zlartg(F, G, CS, SN, R)
ZLARTG generates a plane rotation with real cosine and complex sine.
subroutine xerbla(SRNAME, INFO)
XERBLA
complex *16 function zlarnd(IDIST, ISEED)
ZLARND
logical function lsame(CA, CB)
LSAME
subroutine dscal(N, DA, DX, INCX)
DSCAL
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 zlagsy(N, K, D, A, LDA, ISEED, WORK, INFO)
ZLAGSY
subroutine zlarot(LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, XRIGHT)
ZLAROT
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine zlaghe(N, K, D, A, LDA, ISEED, WORK, INFO)
ZLAGHE
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
subroutine dlatm1(MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO)
DLATM1