330 SUBROUTINE clatms( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
331 $ KL, KU, PACK, A, LDA, WORK, INFO )
338 CHARACTER DIST, PACK, SYM
339 INTEGER INFO, KL, KU, LDA, M, MODE, N
345 COMPLEX A( LDA, * ), WORK( * )
352 parameter( zero = 0.0e+0 )
354 parameter( one = 1.0e+0 )
356 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
358 parameter( twopi = 6.28318530717958647692528676655900576839e+0 )
361 LOGICAL CSYM, GIVENS, ILEXTR, ILTEMP, TOPDWN
362 INTEGER I, IC, ICOL, IDIST, IENDCH, IINFO, IL, ILDA,
363 $ ioffg, ioffst, ipack, ipackg, ir, ir1, ir2,
364 $ irow, irsign, iskew, isym, isympk, j, jc, jch,
365 $ jkl, jku, jr, k, llb, minlda, mnmin, mr, nc,
367 REAL ALPHA, ANGLE, REALC, TEMP
368 COMPLEX C, CT, CTEMP, DUMMY, EXTRA, S, ST
374 EXTERNAL lsame, slarnd, clarnd
382 INTRINSIC abs, cmplx, conjg, cos, max, min, mod, real,
394 IF( m.EQ.0 .OR. n.EQ.0 )
399 IF( lsame( dist,
'U' ) )
THEN
401 ELSE IF( lsame( dist,
'S' ) )
THEN
403 ELSE IF( lsame( dist,
'N' ) )
THEN
411 IF( lsame( sym,
'N' ) )
THEN
415 ELSE IF( lsame( sym,
'P' ) )
THEN
419 ELSE IF( lsame( sym,
'S' ) )
THEN
423 ELSE IF( lsame( sym,
'H' ) )
THEN
434 IF( lsame( pack,
'N' ) )
THEN
436 ELSE IF( lsame( pack,
'U' ) )
THEN
439 ELSE IF( lsame( pack,
'L' ) )
THEN
442 ELSE IF( lsame( pack,
'C' ) )
THEN
445 ELSE IF( lsame( pack,
'R' ) )
THEN
448 ELSE IF( lsame( pack,
'B' ) )
THEN
451 ELSE IF( lsame( pack,
'Q' ) )
THEN
454 ELSE IF( lsame( pack,
'Z' ) )
THEN
468 IF( ipack.EQ.5 .OR. ipack.EQ.6 )
THEN
470 ELSE IF( ipack.EQ.7 )
THEN
471 minlda = llb + uub + 1
481 IF( real( llb+uub ).LT.0.3*real( max( 1, mr+nc ) ) )
487 IF( lda.LT.m .AND. lda.GE.minlda )
494 ELSE IF( m.NE.n .AND. isym.NE.1 )
THEN
496 ELSE IF( n.LT.0 )
THEN
498 ELSE IF( idist.EQ.-1 )
THEN
500 ELSE IF( isym.EQ.-1 )
THEN
502 ELSE IF( abs( mode ).GT.6 )
THEN
504 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
507 ELSE IF( kl.LT.0 )
THEN
509 ELSE IF( ku.LT.0 .OR. ( isym.NE.1 .AND. kl.NE.ku ) )
THEN
511 ELSE IF( ipack.EQ.-1 .OR. ( isympk.EQ.1 .AND. isym.EQ.1 ) .OR.
512 $ ( isympk.EQ.2 .AND. isym.EQ.1 .AND. kl.GT.0 ) .OR.
513 $ ( isympk.EQ.3 .AND. isym.EQ.1 .AND. ku.GT.0 ) .OR.
514 $ ( isympk.NE.0 .AND. m.NE.n ) )
THEN
516 ELSE IF( lda.LT.max( 1, minlda ) )
THEN
521 CALL xerbla(
'CLATMS', -info )
528 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
531 IF( mod( iseed( 4 ), 2 ).NE.1 )
532 $ iseed( 4 ) = iseed( 4 ) + 1
538 CALL slatm1( mode, cond, irsign, idist, iseed, d, mnmin,
540 IF( iinfo.NE.0 )
THEN
548 IF( abs( d( 1 ) ).LE.abs( d( mnmin ) ) )
THEN
554 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
560 temp = max( temp, abs( d( i ) ) )
563 IF( temp.GT.zero )
THEN
570 CALL sscal( mnmin, alpha, d, 1 )
574 CALL claset(
'Full', lda, n, czero, czero, a, lda )
585 IF( ipack.GT.4 )
THEN
588 IF( ipack.GT.5 )
THEN
608 IF( llb.EQ.0 .AND. uub.EQ.0 )
THEN
610 a( ( 1-iskew )*j+ioffst, j ) = cmplx( d( j ) )
613 IF( ipack.LE.2 .OR. ipack.GE.5 )
616 ELSE IF( givens )
THEN
625 IF( ipack.GT.4 )
THEN
632 a( ( 1-iskew )*j+ioffst, j ) = cmplx( d( j ) )
644 DO 60 jr = 1, min( m+jku, n ) + jkl - 1
646 angle = twopi*slarnd( 1, iseed )
647 c = cos( angle )*clarnd( 5, iseed )
648 s = sin( angle )*clarnd( 5, iseed )
649 icol = max( 1, jr-jkl )
651 il = min( n, jr+jku ) + 1 - icol
652 CALL clarot( .true., jr.GT.jkl, .false., il,
654 $ s, a( jr-iskew*icol+ioffst, icol ),
655 $ ilda, extra, dummy )
662 DO 50 jch = jr - jkl, 1, -jkl - jku
664 CALL clartg( a( ir+1-iskew*( ic+1 )+ioffst,
665 $ ic+1 ), extra, realc, s, dummy )
666 dummy = clarnd( 5, iseed )
667 c = conjg( realc*dummy )
668 s = conjg( -s*dummy )
670 irow = max( 1, jch-jku )
674 CALL clarot( .false., iltemp, .true., il, c,
676 $ a( irow-iskew*ic+ioffst, ic ),
677 $ ilda, ctemp, extra )
679 CALL clartg( a( irow+1-iskew*( ic+1 )+ioffst,
680 $ ic+1 ), ctemp, realc, s, dummy )
681 dummy = clarnd( 5, iseed )
682 c = conjg( realc*dummy )
683 s = conjg( -s*dummy )
685 icol = max( 1, jch-jku-jkl )
688 CALL clarot( .true., jch.GT.jku+jkl,
690 $ il, c, s, a( irow-iskew*icol+
691 $ ioffst, icol ), ilda, extra,
705 DO 90 jc = 1, min( n+jkl, m ) + jku - 1
707 angle = twopi*slarnd( 1, iseed )
708 c = cos( angle )*clarnd( 5, iseed )
709 s = sin( angle )*clarnd( 5, iseed )
710 irow = max( 1, jc-jku )
712 il = min( m, jc+jkl ) + 1 - irow
713 CALL clarot( .false., jc.GT.jku, .false., il,
715 $ s, a( irow-iskew*jc+ioffst, jc ),
716 $ ilda, extra, dummy )
723 DO 80 jch = jc - jku, 1, -jkl - jku
725 CALL clartg( a( ir+1-iskew*( ic+1 )+ioffst,
726 $ ic+1 ), extra, realc, s, dummy )
727 dummy = clarnd( 5, iseed )
728 c = conjg( realc*dummy )
729 s = conjg( -s*dummy )
731 icol = max( 1, jch-jkl )
735 CALL clarot( .true., iltemp, .true., il, c,
737 $ a( ir-iskew*icol+ioffst, icol ),
738 $ ilda, ctemp, extra )
740 CALL clartg( a( ir+1-iskew*( icol+1 )+ioffst,
741 $ icol+1 ), ctemp, realc, s,
743 dummy = clarnd( 5, iseed )
744 c = conjg( realc*dummy )
745 s = conjg( -s*dummy )
746 irow = max( 1, jch-jkl-jku )
749 CALL clarot( .false., jch.GT.jkl+jku,
751 $ il, c, s, a( irow-iskew*icol+
752 $ ioffst, icol ), ilda, extra,
773 iendch = min( m, n+jkl ) - 1
774 DO 120 jc = min( m+jku, n ) - 1, 1 - jkl, -1
776 angle = twopi*slarnd( 1, iseed )
777 c = cos( angle )*clarnd( 5, iseed )
778 s = sin( angle )*clarnd( 5, iseed )
779 irow = max( 1, jc-jku+1 )
781 il = min( m, jc+jkl+1 ) + 1 - irow
782 CALL clarot( .false., .false., jc+jkl.LT.m,
784 $ c, s, a( irow-iskew*jc+ioffst,
785 $ jc ), ilda, dummy, extra )
791 DO 110 jch = jc + jkl, iendch, jkl + jku
794 CALL clartg( a( jch-iskew*ic+ioffst, ic ),
795 $ extra, realc, s, dummy )
796 dummy = clarnd( 5, iseed )
801 icol = min( n-1, jch+jku )
802 iltemp = jch + jku.LT.n
804 CALL clarot( .true., ilextr, iltemp,
806 $ c, s, a( jch-iskew*ic+ioffst, ic ),
807 $ ilda, extra, ctemp )
809 CALL clartg( a( jch-iskew*icol+ioffst,
810 $ icol ), ctemp, realc, s, dummy )
811 dummy = clarnd( 5, iseed )
814 il = min( iendch, jch+jkl+jku ) + 2 - jch
816 CALL clarot( .false., .true.,
817 $ jch+jkl+jku.LE.iendch, il, c, s,
818 $ a( jch-iskew*icol+ioffst,
819 $ icol ), ilda, ctemp, extra )
834 iendch = min( n, m+jku ) - 1
835 DO 150 jr = min( n+jkl, m ) - 1, 1 - jku, -1
837 angle = twopi*slarnd( 1, iseed )
838 c = cos( angle )*clarnd( 5, iseed )
839 s = sin( angle )*clarnd( 5, iseed )
840 icol = max( 1, jr-jkl+1 )
842 il = min( n, jr+jku+1 ) + 1 - icol
843 CALL clarot( .true., .false., jr+jku.LT.n,
845 $ c, s, a( jr-iskew*icol+ioffst,
846 $ icol ), ilda, dummy, extra )
852 DO 140 jch = jr + jku, iendch, jkl + jku
855 CALL clartg( a( ir-iskew*jch+ioffst, jch ),
856 $ extra, realc, s, dummy )
857 dummy = clarnd( 5, iseed )
862 irow = min( m-1, jch+jkl )
863 iltemp = jch + jkl.LT.m
865 CALL clarot( .false., ilextr, iltemp,
867 $ c, s, a( ir-iskew*jch+ioffst,
868 $ jch ), ilda, extra, ctemp )
870 CALL clartg( a( irow-iskew*jch+ioffst, jch ),
871 $ ctemp, realc, s, dummy )
872 dummy = clarnd( 5, iseed )
875 il = min( iendch, jch+jkl+jku ) + 2 - jch
877 CALL clarot( .true., .true.,
878 $ jch+jkl+jku.LE.iendch, il, c, s,
879 $ a( irow-iskew*jch+ioffst, jch ),
880 $ ilda, ctemp, extra )
901 IF( ipack.GE.5 )
THEN
909 a( ( 1-iskew )*j+ioffg, j ) = cmplx( d( j ) )
914 irow = max( 1, jc-k )
915 il = min( jc+1, k+2 )
917 ctemp = a( jc-iskew*( jc+1 )+ioffg, jc+1 )
918 angle = twopi*slarnd( 1, iseed )
919 c = cos( angle )*clarnd( 5, iseed )
920 s = sin( angle )*clarnd( 5, iseed )
925 ctemp = conjg( ctemp )
929 CALL clarot( .false., jc.GT.k, .true., il, c, s,
930 $ a( irow-iskew*jc+ioffg, jc ), ilda,
932 CALL clarot( .true., .true., .false.,
933 $ min( k, n-jc )+1, ct, st,
934 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
940 DO 180 jch = jc - k, 1, -k
941 CALL clartg( a( jch+1-iskew*( icol+1 )+ioffg,
942 $ icol+1 ), extra, realc, s, dummy )
943 dummy = clarnd( 5, iseed )
944 c = conjg( realc*dummy )
945 s = conjg( -s*dummy )
946 ctemp = a( jch-iskew*( jch+1 )+ioffg, jch+1 )
951 ctemp = conjg( ctemp )
955 CALL clarot( .true., .true., .true., k+2, c,
957 $ a( ( 1-iskew )*jch+ioffg, jch ),
958 $ ilda, ctemp, extra )
959 irow = max( 1, jch-k )
960 il = min( jch+1, k+2 )
962 CALL clarot( .false., jch.GT.k, .true., il,
964 $ st, a( irow-iskew*jch+ioffg, jch ),
965 $ ilda, extra, ctemp )
974 IF( ipack.NE.ipackg .AND. ipack.NE.3 )
THEN
976 irow = ioffst - iskew*jc
978 DO 210 jr = jc, min( n, jc+uub )
979 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
982 DO 220 jr = jc, min( n, jc+uub )
983 a( jr+irow, jc ) = conjg( a( jc-iskew*jr+
988 IF( ipack.EQ.5 )
THEN
989 DO 250 jc = n - uub + 1, n
990 DO 240 jr = n + 2 - jc, uub + 1
995 IF( ipackg.EQ.6 )
THEN
1005 IF( ipack.GE.5 )
THEN
1014 a( ( 1-iskew )*j+ioffg, j ) = cmplx( d( j ) )
1018 DO 280 jc = n - 1, 1, -1
1019 il = min( n+1-jc, k+2 )
1021 ctemp = a( 1+( 1-iskew )*jc+ioffg, jc )
1022 angle = twopi*slarnd( 1, iseed )
1023 c = cos( angle )*clarnd( 5, iseed )
1024 s = sin( angle )*clarnd( 5, iseed )
1029 ctemp = conjg( ctemp )
1033 CALL clarot( .false., .true., n-jc.GT.k, il, c,
1035 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
1037 icol = max( 1, jc-k+1 )
1038 CALL clarot( .true., .false., .true., jc+2-icol,
1039 $ ct, st, a( jc-iskew*icol+ioffg,
1040 $ icol ), ilda, dummy, ctemp )
1045 DO 270 jch = jc + k, n - 1, k
1046 CALL clartg( a( jch-iskew*icol+ioffg, icol ),
1047 $ extra, realc, s, dummy )
1048 dummy = clarnd( 5, iseed )
1051 ctemp = a( 1+( 1-iskew )*jch+ioffg, jch )
1056 ctemp = conjg( ctemp )
1060 CALL clarot( .true., .true., .true., k+2, c,
1062 $ a( jch-iskew*icol+ioffg, icol ),
1063 $ ilda, extra, ctemp )
1064 il = min( n+1-jch, k+2 )
1066 CALL clarot( .false., .true., n-jch.GT.k, il,
1067 $ ct, st, a( ( 1-iskew )*jch+ioffg,
1068 $ jch ), ilda, ctemp, extra )
1077 IF( ipack.NE.ipackg .AND. ipack.NE.4 )
THEN
1078 DO 320 jc = n, 1, -1
1079 irow = ioffst - iskew*jc
1081 DO 300 jr = jc, max( 1, jc-uub ), -1
1082 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
1085 DO 310 jr = jc, max( 1, jc-uub ), -1
1086 a( jr+irow, jc ) = conjg( a( jc-iskew*jr+
1091 IF( ipack.EQ.6 )
THEN
1093 DO 330 jr = 1, uub + 1 - jc
1098 IF( ipackg.EQ.5 )
THEN
1108 IF( .NOT.csym )
THEN
1110 irow = ioffst + ( 1-iskew )*jc
1111 a( irow, jc ) = cmplx( real( a( irow, jc ) ) )
1126 IF( isym.EQ.1 )
THEN
1130 CALL clagge( mr, nc, llb, uub, d, a, lda, iseed, work,
1138 CALL clagsy( m, llb, d, a, lda, iseed, work, iinfo )
1140 CALL claghe( m, llb, d, a, lda, iseed, work, iinfo )
1144 IF( iinfo.NE.0 )
THEN
1152 IF( ipack.NE.ipackg )
THEN
1153 IF( ipack.EQ.1 )
THEN
1163 ELSE IF( ipack.EQ.2 )
THEN
1173 ELSE IF( ipack.EQ.3 )
THEN
1182 IF( irow.GT.lda )
THEN
1186 a( irow, icol ) = a( i, j )
1190 ELSE IF( ipack.EQ.4 )
THEN
1199 IF( irow.GT.lda )
THEN
1203 a( irow, icol ) = a( i, j )
1207 ELSE IF( ipack.GE.5 )
THEN
1219 DO 440 i = min( j+llb, m ), 1, -1
1220 a( i-j+uub+1, j ) = a( i, j )
1224 DO 470 j = uub + 2, n
1225 DO 460 i = j - uub, min( j+llb, m )
1226 a( i-j+uub+1, j ) = a( i, j )
1236 IF( ipack.EQ.3 .OR. ipack.EQ.4 )
THEN
1238 DO 480 jr = irow + 1, lda
1244 ELSE IF( ipack.GE.5 )
THEN
1255 DO 500 jr = 1, uub + 1 - jc
1258 DO 510 jr = max( 1, min( ir1, ir2-jc ) ), lda