1
/* -- translated by f2c (version 20050501).
2
You must link the resulting object file with libf2c:
3
on Microsoft Windows system, link with libf2c.lib;
4
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
5
or, if you install libf2c.a in a standard place, with -lf2c -lm
6
-- in that order, at the end of the command line, as in
8
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
10
http://www.netlib.org/f2c/libf2c.zip
14
#include "arpack_internal.h"
17
/* Subroutine */ int igraphdlascl_(char *type__, integer *kl, integer *ku,
18
doublereal *cfrom, doublereal *cto, integer *m, integer *n,
19
doublereal *a, integer *lda, integer *info)
21
/* System generated locals */
22
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
25
static integer i__, j, k1, k2, k3, k4;
26
static doublereal mul, cto1;
28
static doublereal ctoc;
29
extern logical igraphlsame_(char *, char *);
31
static doublereal cfrom1;
32
extern doublereal igraphdlamch_(char *);
33
static doublereal cfromc;
34
extern /* Subroutine */ int igraphxerbla_(char *, integer *);
35
static doublereal bignum, smlnum;
38
/* -- LAPACK auxiliary routine (version 3.0) -- */
39
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
40
/* Courant Institute, Argonne National Lab, and Rice University */
41
/* February 29, 1992 */
43
/* .. Scalar Arguments .. */
45
/* .. Array Arguments .. */
51
/* DLASCL multiplies the M by N real matrix A by the real scalar */
52
/* CTO/CFROM. This is done without over/underflow as long as the final */
53
/* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that */
54
/* A may be full, upper triangular, lower triangular, upper Hessenberg, */
60
/* TYPE (input) CHARACTER*1 */
61
/* TYPE indices the storage type of the input matrix. */
62
/* = 'G': A is a full matrix. */
63
/* = 'L': A is a lower triangular matrix. */
64
/* = 'U': A is an upper triangular matrix. */
65
/* = 'H': A is an upper Hessenberg matrix. */
66
/* = 'B': A is a symmetric band matrix with lower bandwidth KL */
67
/* and upper bandwidth KU and with the only the lower */
69
/* = 'Q': A is a symmetric band matrix with lower bandwidth KL */
70
/* and upper bandwidth KU and with the only the upper */
72
/* = 'Z': A is a band matrix with lower bandwidth KL and upper */
75
/* KL (input) INTEGER */
76
/* The lower bandwidth of A. Referenced only if TYPE = 'B', */
79
/* KU (input) INTEGER */
80
/* The upper bandwidth of A. Referenced only if TYPE = 'B', */
83
/* CFROM (input) DOUBLE PRECISION */
84
/* CTO (input) DOUBLE PRECISION */
85
/* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */
86
/* without over/underflow if the final result CTO*A(I,J)/CFROM */
87
/* can be represented without over/underflow. CFROM must be */
90
/* M (input) INTEGER */
91
/* The number of rows of the matrix A. M >= 0. */
93
/* N (input) INTEGER */
94
/* The number of columns of the matrix A. N >= 0. */
96
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,M) */
97
/* The matrix to be multiplied by CTO/CFROM. See TYPE for the */
100
/* LDA (input) INTEGER */
101
/* The leading dimension of the array A. LDA >= max(1,M). */
103
/* INFO (output) INTEGER */
104
/* 0 - successful exit */
105
/* <0 - if INFO = -i, the i-th argument had an illegal value. */
107
/* ===================================================================== */
109
/* .. Parameters .. */
111
/* .. Local Scalars .. */
113
/* .. External Functions .. */
115
/* .. Intrinsic Functions .. */
117
/* .. External Subroutines .. */
119
/* .. Executable Statements .. */
121
/* Test the input arguments */
123
/* Parameter adjustments */
125
a_offset = 1 + a_dim1;
131
if (igraphlsame_(type__, "G")) {
133
} else if (igraphlsame_(type__, "L")) {
135
} else if (igraphlsame_(type__, "U")) {
137
} else if (igraphlsame_(type__, "H")) {
139
} else if (igraphlsame_(type__, "B")) {
141
} else if (igraphlsame_(type__, "Q")) {
143
} else if (igraphlsame_(type__, "Z")) {
151
} else if (*cfrom == 0.) {
155
} else if (*n < 0 || (itype == 4 && *n != *m) || (itype == 5 && *n != *m)) {
157
} else if (itype <= 3 && *lda < max(1,*m)) {
159
} else if (itype >= 4) {
162
if (*kl < 0 || *kl > max(i__1,0)) {
164
} else /* if(complicated condition) */ {
167
if (*ku < 0 || *ku > max(i__1,0) || ((itype == 4 || itype == 5) &&
170
} else if ((itype == 4 && *lda < *kl + 1) || (itype == 5 && *lda < *
171
ku + 1) || (itype == 6 && *lda < (*kl << 1) + *ku + 1)) {
179
igraphxerbla_("DLASCL", &i__1);
183
/* Quick return if possible */
185
if (*n == 0 || *m == 0) {
189
/* Get machine parameters */
191
smlnum = igraphdlamch_("S");
192
bignum = 1. / smlnum;
198
cfrom1 = cfromc * smlnum;
199
cto1 = ctoc / bignum;
200
if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) {
204
} else if (abs(cto1) > abs(cfromc)) {
218
for (j = 1; j <= i__1; ++j) {
220
for (i__ = 1; i__ <= i__2; ++i__) {
221
a[i__ + j * a_dim1] *= mul;
227
} else if (itype == 1) {
229
/* Lower triangular matrix */
232
for (j = 1; j <= i__1; ++j) {
234
for (i__ = j; i__ <= i__2; ++i__) {
235
a[i__ + j * a_dim1] *= mul;
241
} else if (itype == 2) {
243
/* Upper triangular matrix */
246
for (j = 1; j <= i__1; ++j) {
248
for (i__ = 1; i__ <= i__2; ++i__) {
249
a[i__ + j * a_dim1] *= mul;
255
} else if (itype == 3) {
257
/* Upper Hessenberg matrix */
260
for (j = 1; j <= i__1; ++j) {
264
for (i__ = 1; i__ <= i__2; ++i__) {
265
a[i__ + j * a_dim1] *= mul;
271
} else if (itype == 4) {
273
/* Lower half of a symmetric band matrix */
278
for (j = 1; j <= i__1; ++j) {
280
i__3 = k3, i__4 = k4 - j;
281
i__2 = min(i__3,i__4);
282
for (i__ = 1; i__ <= i__2; ++i__) {
283
a[i__ + j * a_dim1] *= mul;
289
} else if (itype == 5) {
291
/* Upper half of a symmetric band matrix */
296
for (j = 1; j <= i__1; ++j) {
300
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
301
a[i__ + j * a_dim1] *= mul;
307
} else if (itype == 6) {
313
k3 = (*kl << 1) + *ku + 1;
314
k4 = *kl + *ku + 1 + *m;
316
for (j = 1; j <= i__1; ++j) {
320
i__4 = k3, i__5 = k4 - j;
321
i__2 = min(i__4,i__5);
322
for (i__ = max(i__3,k2); i__ <= i__2; ++i__) {
323
a[i__ + j * a_dim1] *= mul;
339
} /* igraphdlascl_ */
added
removed
src/lapack/dlascl.c
