469 SUBROUTINE slatmr( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
470 $ rsign, grade, dl, model, condl, dr, moder,
471 $ condr, pivtng, ipivot, kl, ku, sparse, anorm,
472 $ pack, a, lda, iwork, info )
480 CHARACTER dist, grade, pack, pivtng, rsign, sym
481 INTEGER info, kl, ku, lda, m, mode, model, moder, n
482 REAL anorm, cond, condl, condr, dmax, sparse
485 INTEGER ipivot( * ), iseed( 4 ), iwork( * )
486 REAL a( lda, * ), d( * ), dl( * ), dr( * )
493 parameter( zero = 0.0e0 )
495 parameter( one = 1.0e0 )
498 LOGICAL badpvt, dzero, fulbnd
499 INTEGER i, idist, igrade, iisub, ipack, ipvtng, irsign,
500 $ isub, isym, j, jjsub, jsub, k, kll, kuu, mnmin,
501 $ mnsub, mxsub, npvts
502 REAL alpha, onorm, temp
518 INTRINSIC abs, max, min, mod
529 IF( m.EQ.0 .OR. n.EQ.0 )
534 IF(
lsame( dist,
'U' ) )
THEN
536 ELSE IF(
lsame( dist,
'S' ) )
THEN
538 ELSE IF(
lsame( dist,
'N' ) )
THEN
546 IF(
lsame( sym,
'S' ) )
THEN
548 ELSE IF(
lsame( sym,
'N' ) )
THEN
550 ELSE IF(
lsame( sym,
'H' ) )
THEN
558 IF(
lsame( rsign,
'F' ) )
THEN
560 ELSE IF(
lsame( rsign,
'T' ) )
THEN
568 IF(
lsame( pivtng,
'N' ) )
THEN
570 ELSE IF(
lsame( pivtng,
' ' ) )
THEN
572 ELSE IF(
lsame( pivtng,
'L' ) )
THEN
575 ELSE IF(
lsame( pivtng,
'R' ) )
THEN
578 ELSE IF(
lsame( pivtng,
'B' ) )
THEN
581 ELSE IF(
lsame( pivtng,
'F' ) )
THEN
590 IF(
lsame( grade,
'N' ) )
THEN
592 ELSE IF(
lsame( grade,
'L' ) )
THEN
594 ELSE IF(
lsame( grade,
'R' ) )
THEN
596 ELSE IF(
lsame( grade,
'B' ) )
THEN
598 ELSE IF(
lsame( grade,
'E' ) )
THEN
600 ELSE IF(
lsame( grade,
'H' ) .OR.
lsame( grade,
'S' ) )
THEN
608 IF(
lsame( pack,
'N' ) )
THEN
610 ELSE IF(
lsame( pack,
'U' ) )
THEN
612 ELSE IF(
lsame( pack,
'L' ) )
THEN
614 ELSE IF(
lsame( pack,
'C' ) )
THEN
616 ELSE IF(
lsame( pack,
'R' ) )
THEN
618 ELSE IF(
lsame( pack,
'B' ) )
THEN
620 ELSE IF(
lsame( pack,
'Q' ) )
THEN
622 ELSE IF(
lsame( pack,
'Z' ) )
THEN
637 IF( igrade.EQ.4 .AND. model.EQ.0 )
THEN
639 IF( dl( i ).EQ.zero )
647 IF( ipvtng.GT.0 )
THEN
649 IF( ipivot( j ).LE.0 .OR. ipivot( j ).GT.npvts )
658 ELSE IF( m.NE.n .AND. isym.EQ.0 )
THEN
660 ELSE IF( n.LT.0 )
THEN
662 ELSE IF( idist.EQ.-1 )
THEN
664 ELSE IF( isym.EQ.-1 )
THEN
666 ELSE IF( mode.LT.-6 .OR. mode.GT.6 )
THEN
668 ELSE IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
671 ELSE IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
672 $ irsign.EQ.-1 )
THEN
674 ELSE IF( igrade.EQ.-1 .OR. ( igrade.EQ.4 .AND. m.NE.n ) .OR.
675 $ ( ( igrade.GE.1 .AND. igrade.LE.4 ) .AND. isym.EQ.0 ) )
678 ELSE IF( igrade.EQ.4 .AND. dzero )
THEN
680 ELSE IF( ( igrade.EQ.1 .OR. igrade.EQ.3 .OR. igrade.EQ.4 .OR.
681 $ igrade.EQ.5 ) .AND. ( model.LT.-6 .OR. model.GT.6 ) )
684 ELSE IF( ( igrade.EQ.1 .OR. igrade.EQ.3 .OR. igrade.EQ.4 .OR.
685 $ igrade.EQ.5 ) .AND. ( model.NE.-6 .AND. model.NE.0 .AND.
686 $ model.NE.6 ) .AND. condl.LT.one )
THEN
688 ELSE IF( ( igrade.EQ.2 .OR. igrade.EQ.3 ) .AND.
689 $ ( moder.LT.-6 .OR. moder.GT.6 ) )
THEN
691 ELSE IF( ( igrade.EQ.2 .OR. igrade.EQ.3 ) .AND.
692 $ ( moder.NE.-6 .AND. moder.NE.0 .AND. moder.NE.6 ) .AND.
693 $ condr.LT.one )
THEN
695 ELSE IF( ipvtng.EQ.-1 .OR. ( ipvtng.EQ.3 .AND. m.NE.n ) .OR.
696 $ ( ( ipvtng.EQ.1 .OR. ipvtng.EQ.2 ) .AND. isym.EQ.0 ) )
699 ELSE IF( ipvtng.NE.0 .AND. badpvt )
THEN
701 ELSE IF( kl.LT.0 )
THEN
703 ELSE IF( ku.LT.0 .OR. ( isym.EQ.0 .AND. kl.NE.ku ) )
THEN
705 ELSE IF( sparse.LT.zero .OR. sparse.GT.one )
THEN
707 ELSE IF( ipack.EQ.-1 .OR. ( ( ipack.EQ.1 .OR. ipack.EQ.2 .OR.
708 $ ipack.EQ.5 .OR. ipack.EQ.6 ) .AND. isym.EQ.1 ) .OR.
709 $ ( ipack.EQ.3 .AND. isym.EQ.1 .AND. ( kl.NE.0 .OR. m.NE.
710 $ n ) ) .OR. ( ipack.EQ.4 .AND. isym.EQ.1 .AND. ( ku.NE.
711 $ 0 .OR. m.NE.n ) ) )
THEN
713 ELSE IF( ( ( ipack.EQ.0 .OR. ipack.EQ.1 .OR. ipack.EQ.2 ) .AND.
714 $ lda.LT.max( 1, m ) ) .OR. ( ( ipack.EQ.3 .OR. ipack.EQ.
715 $ 4 ) .AND. lda.LT.1 ) .OR. ( ( ipack.EQ.5 .OR. ipack.EQ.
716 $ 6 ) .AND. lda.LT.kuu+1 ) .OR.
717 $ ( ipack.EQ.7 .AND. lda.LT.kll+kuu+1 ) )
THEN
722 CALL
xerbla(
'SLATMR', -info )
729 IF( kuu.EQ.n-1 .AND. kll.EQ.m-1 )
735 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
738 iseed( 4 ) = 2*( iseed( 4 ) / 2 ) + 1
744 CALL
slatm1( mode, cond, irsign, idist, iseed, d, mnmin, info )
749 IF( mode.NE.0 .AND. mode.NE.-6 .AND. mode.NE.6 )
THEN
755 temp = max( temp, abs( d( i ) ) )
757 IF( temp.EQ.zero .AND. dmax.NE.zero )
THEN
761 IF( temp.NE.zero )
THEN
767 d( i ) = alpha*d( i )
774 IF( igrade.EQ.1 .OR. igrade.EQ.3 .OR. igrade.EQ.4 .OR. igrade.EQ.
776 CALL
slatm1( model, condl, 0, idist, iseed, dl, m, info )
785 IF( igrade.EQ.2 .OR. igrade.EQ.3 )
THEN
786 CALL
slatm1( moder, condr, 0, idist, iseed, dr, n, info )
795 IF( ipvtng.GT.0 )
THEN
803 iwork( i ) = iwork( k )
807 DO 80 i = npvts, 1, -1
810 iwork( i ) = iwork( k )
826 IF( ipack.EQ.0 )
THEN
830 temp =
slatm3( m, n, i, j, isub, jsub, kl, ku,
831 $ idist, iseed, d, igrade, dl, dr, ipvtng,
833 a( isub, jsub ) = temp
834 a( jsub, isub ) = temp
837 ELSE IF( isym.EQ.1 )
THEN
840 temp =
slatm3( m, n, i, j, isub, jsub, kl, ku,
841 $ idist, iseed, d, igrade, dl, dr, ipvtng,
843 a( isub, jsub ) = temp
848 ELSE IF( ipack.EQ.1 )
THEN
852 temp =
slatm3( m, n, i, j, isub, jsub, kl, ku, idist,
853 $ iseed, d, igrade, dl, dr, ipvtng, iwork,
855 mnsub = min( isub, jsub )
856 mxsub = max( isub, jsub )
857 a( mnsub, mxsub ) = temp
859 $ a( mxsub, mnsub ) = zero
863 ELSE IF( ipack.EQ.2 )
THEN
867 temp =
slatm3( m, n, i, j, isub, jsub, kl, ku, idist,
868 $ iseed, d, igrade, dl, dr, ipvtng, iwork,
870 mnsub = min( isub, jsub )
871 mxsub = max( isub, jsub )
872 a( mxsub, mnsub ) = temp
874 $ a( mnsub, mxsub ) = zero
878 ELSE IF( ipack.EQ.3 )
THEN
882 temp =
slatm3( m, n, i, j, isub, jsub, kl, ku, idist,
883 $ iseed, d, igrade, dl, dr, ipvtng, iwork,
889 mnsub = min( isub, jsub )
890 mxsub = max( isub, jsub )
891 k = mxsub*( mxsub-1 ) / 2 + mnsub
895 jjsub = ( k-1 ) / lda + 1
896 iisub = k - lda*( jjsub-1 )
898 a( iisub, jjsub ) = temp
902 ELSE IF( ipack.EQ.4 )
THEN
906 temp =
slatm3( m, n, i, j, isub, jsub, kl, ku, idist,
907 $ iseed, d, igrade, dl, dr, ipvtng, iwork,
912 mnsub = min( isub, jsub )
913 mxsub = max( isub, jsub )
914 IF( mnsub.EQ.1 )
THEN
917 k = n*( n+1 ) / 2 - ( n-mnsub+1 )*( n-mnsub+2 ) /
918 $ 2 + mxsub - mnsub + 1
923 jjsub = ( k-1 ) / lda + 1
924 iisub = k - lda*( jjsub-1 )
926 a( iisub, jjsub ) = temp
930 ELSE IF( ipack.EQ.5 )
THEN
933 DO 210 i = j - kuu, j
935 a( j-i+1, i+n ) = zero
937 temp =
slatm3( m, n, i, j, isub, jsub, kl, ku,
938 $ idist, iseed, d, igrade, dl, dr, ipvtng,
940 mnsub = min( isub, jsub )
941 mxsub = max( isub, jsub )
942 a( mxsub-mnsub+1, mnsub ) = temp
947 ELSE IF( ipack.EQ.6 )
THEN
950 DO 230 i = j - kuu, j
951 temp =
slatm3( m, n, i, j, isub, jsub, kl, ku, idist,
952 $ iseed, d, igrade, dl, dr, ipvtng, iwork,
954 mnsub = min( isub, jsub )
955 mxsub = max( isub, jsub )
956 a( mnsub-mxsub+kuu+1, mxsub ) = temp
960 ELSE IF( ipack.EQ.7 )
THEN
964 DO 250 i = j - kuu, j
965 temp =
slatm3( m, n, i, j, isub, jsub, kl, ku,
966 $ idist, iseed, d, igrade, dl, dr, ipvtng,
968 mnsub = min( isub, jsub )
969 mxsub = max( isub, jsub )
970 a( mnsub-mxsub+kuu+1, mxsub ) = temp
972 $ a( j-i+1+kuu, i+n ) = zero
973 IF( i.GE.1 .AND. mnsub.NE.mxsub )
974 $ a( mxsub-mnsub+1+kuu, mnsub ) = temp
977 ELSE IF( isym.EQ.1 )
THEN
979 DO 270 i = j - kuu, j + kll
980 temp =
slatm3( m, n, i, j, isub, jsub, kl, ku,
981 $ idist, iseed, d, igrade, dl, dr, ipvtng,
983 a( isub-jsub+kuu+1, jsub ) = temp
994 IF( ipack.EQ.0 )
THEN
998 a( i, j ) =
slatm2( m, n, i, j, kl, ku, idist,
999 $ iseed, d, igrade, dl, dr, ipvtng,
1001 a( j, i ) = a( i, j )
1004 ELSE IF( isym.EQ.1 )
THEN
1007 a( i, j ) =
slatm2( m, n, i, j, kl, ku, idist,
1008 $ iseed, d, igrade, dl, dr, ipvtng,
1014 ELSE IF( ipack.EQ.1 )
THEN
1018 a( i, j ) =
slatm2( m, n, i, j, kl, ku, idist, iseed,
1019 $ d, igrade, dl, dr, ipvtng, iwork, sparse )
1025 ELSE IF( ipack.EQ.2 )
THEN
1029 a( j, i ) =
slatm2( m, n, i, j, kl, ku, idist, iseed,
1030 $ d, igrade, dl, dr, ipvtng, iwork, sparse )
1036 ELSE IF( ipack.EQ.3 )
THEN
1043 IF( isub.GT.lda )
THEN
1047 a( isub, jsub ) =
slatm2( m, n, i, j, kl, ku, idist,
1048 $ iseed, d, igrade, dl, dr, ipvtng,
1053 ELSE IF( ipack.EQ.4 )
THEN
1055 IF( isym.EQ.0 )
THEN
1064 k = n*( n+1 ) / 2 - ( n-i+1 )*( n-i+2 ) / 2 +
1070 jsub = ( k-1 ) / lda + 1
1071 isub = k - lda*( jsub-1 )
1073 a( isub, jsub ) =
slatm2( m, n, i, j, kl, ku,
1074 $ idist, iseed, d, igrade, dl, dr,
1075 $ ipvtng, iwork, sparse )
1084 IF( isub.GT.lda )
THEN
1088 a( isub, jsub ) =
slatm2( m, n, i, j, kl, ku,
1089 $ idist, iseed, d, igrade, dl, dr,
1090 $ ipvtng, iwork, sparse )
1095 ELSE IF( ipack.EQ.5 )
THEN
1098 DO 430 i = j - kuu, j
1100 a( j-i+1, i+n ) = zero
1102 a( j-i+1, i ) =
slatm2( m, n, i, j, kl, ku, idist,
1103 $ iseed, d, igrade, dl, dr, ipvtng,
1109 ELSE IF( ipack.EQ.6 )
THEN
1112 DO 450 i = j - kuu, j
1113 a( i-j+kuu+1, j ) =
slatm2( m, n, i, j, kl, ku, idist,
1114 $ iseed, d, igrade, dl, dr, ipvtng,
1119 ELSE IF( ipack.EQ.7 )
THEN
1121 IF( isym.EQ.0 )
THEN
1123 DO 470 i = j - kuu, j
1124 a( i-j+kuu+1, j ) =
slatm2( m, n, i, j, kl, ku,
1125 $ idist, iseed, d, igrade, dl,
1126 $ dr, ipvtng, iwork, sparse )
1128 $ a( j-i+1+kuu, i+n ) = zero
1129 IF( i.GE.1 .AND. i.NE.j )
1130 $ a( j-i+1+kuu, i ) = a( i-j+kuu+1, j )
1133 ELSE IF( isym.EQ.1 )
THEN
1135 DO 490 i = j - kuu, j + kll
1136 a( i-j+kuu+1, j ) =
slatm2( m, n, i, j, kl, ku,
1137 $ idist, iseed, d, igrade, dl,
1138 $ dr, ipvtng, iwork, sparse )
1149 IF( ipack.EQ.0 )
THEN
1150 onorm =
slange(
'M', m, n, a, lda, tempa )
1151 ELSE IF( ipack.EQ.1 )
THEN
1152 onorm =
slansy(
'M',
'U', n, a, lda, tempa )
1153 ELSE IF( ipack.EQ.2 )
THEN
1154 onorm =
slansy(
'M',
'L', n, a, lda, tempa )
1155 ELSE IF( ipack.EQ.3 )
THEN
1156 onorm =
slansp(
'M',
'U', n, a, tempa )
1157 ELSE IF( ipack.EQ.4 )
THEN
1158 onorm =
slansp(
'M',
'L', n, a, tempa )
1159 ELSE IF( ipack.EQ.5 )
THEN
1160 onorm =
slansb(
'M',
'L', n, kll, a, lda, tempa )
1161 ELSE IF( ipack.EQ.6 )
THEN
1162 onorm =
slansb(
'M',
'U', n, kuu, a, lda, tempa )
1163 ELSE IF( ipack.EQ.7 )
THEN
1164 onorm =
slangb(
'M', n, kll, kuu, a, lda, tempa )
1167 IF( anorm.GE.zero )
THEN
1169 IF( anorm.GT.zero .AND. onorm.EQ.zero )
THEN
1176 ELSE IF( ( anorm.GT.one .AND. onorm.LT.one ) .OR.
1177 $ ( anorm.LT.one .AND. onorm.GT.one ) )
THEN
1181 IF( ipack.LE.2 )
THEN
1183 CALL
sscal( m, one / onorm, a( 1, j ), 1 )
1184 CALL
sscal( m, anorm, a( 1, j ), 1 )
1187 ELSE IF( ipack.EQ.3 .OR. ipack.EQ.4 )
THEN
1189 CALL
sscal( n*( n+1 ) / 2, one / onorm, a, 1 )
1190 CALL
sscal( n*( n+1 ) / 2, anorm, a, 1 )
1192 ELSE IF( ipack.GE.5 )
THEN
1195 CALL
sscal( kll+kuu+1, one / onorm, a( 1, j ), 1 )
1196 CALL
sscal( kll+kuu+1, anorm, a( 1, j ), 1 )
1205 IF( ipack.LE.2 )
THEN
1207 CALL
sscal( m, anorm / onorm, a( 1, j ), 1 )
1210 ELSE IF( ipack.EQ.3 .OR. ipack.EQ.4 )
THEN
1212 CALL
sscal( n*( n+1 ) / 2, anorm / onorm, a, 1 )
1214 ELSE IF( ipack.GE.5 )
THEN
1217 CALL
sscal( kll+kuu+1, anorm / onorm, a( 1, j ), 1 )