3 /* Subroutine */ int dlascl_(char *type__, integer *kl, integer *ku,
4 doublereal *cfrom, doublereal *cto, integer *m, integer *n,
5 doublereal *a, integer *lda, integer *info)
7 /* System generated locals */
8 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
11 integer i__, j, k1, k2, k3, k4;
15 extern logical lsame_(char *, char *);
18 extern doublereal dlamch_(char *);
20 extern /* Subroutine */ int xerbla_(char *, integer *);
21 doublereal bignum, smlnum;
24 /* -- LAPACK auxiliary routine (version 3.1) -- */
25 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
28 /* .. Scalar Arguments .. */
30 /* .. Array Arguments .. */
36 /* DLASCL multiplies the M by N real matrix A by the real scalar */
37 /* CTO/CFROM. This is done without over/underflow as long as the final */
38 /* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that */
39 /* A may be full, upper triangular, lower triangular, upper Hessenberg, */
45 /* TYPE (input) CHARACTER*1 */
46 /* TYPE indices the storage type of the input matrix. */
47 /* = 'G': A is a full matrix. */
48 /* = 'L': A is a lower triangular matrix. */
49 /* = 'U': A is an upper triangular matrix. */
50 /* = 'H': A is an upper Hessenberg matrix. */
51 /* = 'B': A is a symmetric band matrix with lower bandwidth KL */
52 /* and upper bandwidth KU and with the only the lower */
54 /* = 'Q': A is a symmetric band matrix with lower bandwidth KL */
55 /* and upper bandwidth KU and with the only the upper */
57 /* = 'Z': A is a band matrix with lower bandwidth KL and upper */
60 /* KL (input) INTEGER */
61 /* The lower bandwidth of A. Referenced only if TYPE = 'B', */
64 /* KU (input) INTEGER */
65 /* The upper bandwidth of A. Referenced only if TYPE = 'B', */
68 /* CFROM (input) DOUBLE PRECISION */
69 /* CTO (input) DOUBLE PRECISION */
70 /* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */
71 /* without over/underflow if the final result CTO*A(I,J)/CFROM */
72 /* can be represented without over/underflow. CFROM must be */
75 /* M (input) INTEGER */
76 /* The number of rows of the matrix A. M >= 0. */
78 /* N (input) INTEGER */
79 /* The number of columns of the matrix A. N >= 0. */
81 /* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
82 /* The matrix to be multiplied by CTO/CFROM. See TYPE for the */
85 /* LDA (input) INTEGER */
86 /* The leading dimension of the array A. LDA >= max(1,M). */
88 /* INFO (output) INTEGER */
89 /* 0 - successful exit */
90 /* <0 - if INFO = -i, the i-th argument had an illegal value. */
92 /* ===================================================================== */
94 /* .. Parameters .. */
96 /* .. Local Scalars .. */
98 /* .. External Functions .. */
100 /* .. Intrinsic Functions .. */
102 /* .. External Subroutines .. */
104 /* .. Executable Statements .. */
106 /* Test the input arguments */
108 /* Parameter adjustments */
110 a_offset = 1 + a_dim1;
116 if (lsame_(type__, "G")) {
118 } else if (lsame_(type__, "L")) {
120 } else if (lsame_(type__, "U")) {
122 } else if (lsame_(type__, "H")) {
124 } else if (lsame_(type__, "B")) {
126 } else if (lsame_(type__, "Q")) {
128 } else if (lsame_(type__, "Z")) {
136 } else if (*cfrom == 0.) {
140 } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
142 } else if (itype <= 3 && *lda < max(1,*m)) {
144 } else if (itype >= 4) {
147 if (*kl < 0 || *kl > max(i__1,0)) {
149 } else /* if(complicated condition) */ {
152 if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) &&
155 } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
156 ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
164 xerbla_("DLASCL", &i__1);
168 /* Quick return if possible */
170 if (*n == 0 || *m == 0) {
174 /* Get machine parameters */
176 smlnum = dlamch_("S");
177 bignum = 1. / smlnum;
183 cfrom1 = cfromc * smlnum;
184 cto1 = ctoc / bignum;
185 if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) {
189 } else if (abs(cto1) > abs(cfromc)) {
203 for (j = 1; j <= i__1; ++j) {
205 for (i__ = 1; i__ <= i__2; ++i__) {
206 a[i__ + j * a_dim1] *= mul;
212 } else if (itype == 1) {
214 /* Lower triangular matrix */
217 for (j = 1; j <= i__1; ++j) {
219 for (i__ = j; i__ <= i__2; ++i__) {
220 a[i__ + j * a_dim1] *= mul;
226 } else if (itype == 2) {
228 /* Upper triangular matrix */
231 for (j = 1; j <= i__1; ++j) {
233 for (i__ = 1; i__ <= i__2; ++i__) {
234 a[i__ + j * a_dim1] *= mul;
240 } else if (itype == 3) {
242 /* Upper Hessenberg matrix */
245 for (j = 1; j <= i__1; ++j) {
249 for (i__ = 1; i__ <= i__2; ++i__) {
250 a[i__ + j * a_dim1] *= mul;
256 } else if (itype == 4) {
258 /* Lower half of a symmetric band matrix */
263 for (j = 1; j <= i__1; ++j) {
265 i__3 = k3, i__4 = k4 - j;
266 i__2 = min(i__3,i__4);
267 for (i__ = 1; i__ <= i__2; ++i__) {
268 a[i__ + j * a_dim1] *= mul;
274 } else if (itype == 5) {
276 /* Upper half of a symmetric band matrix */
281 for (j = 1; j <= i__1; ++j) {
285 for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
286 a[i__ + j * a_dim1] *= mul;
292 } else if (itype == 6) {
298 k3 = (*kl << 1) + *ku + 1;
299 k4 = *kl + *ku + 1 + *m;
301 for (j = 1; j <= i__1; ++j) {
305 i__4 = k3, i__5 = k4 - j;
306 i__2 = min(i__4,i__5);
307 for (i__ = max(i__3,k2); i__ <= i__2; ++i__) {
308 a[i__ + j * a_dim1] *= mul;