1 /* lapack/single/slange.f -- 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
7 cc *.o -lf2c -lm
8 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
9
10 http://www.netlib.org/f2c/libf2c.zip
11 */
12
13 #ifdef __cplusplus
14 extern "C" {
15 #endif
16 #include "v3p_netlib.h"
17
18 /* Table of constant values */
19
20 static integer c__1 = 1;
21
22 /*< REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK ) >*/
slange_(char * norm,integer * m,integer * n,real * a,integer * lda,real * work,ftnlen norm_len)23 doublereal slange_(char *norm, integer *m, integer *n, real *a, integer *lda,
24 real *work, ftnlen norm_len)
25 {
26 /* System generated locals */
27 integer a_dim1, a_offset, i__1, i__2;
28 real ret_val, r__1, r__2, r__3;
29
30 /* Builtin functions */
31 double sqrt(doublereal);
32
33 /* Local variables */
34 integer i__, j;
35 real sum, scale;
36 extern logical lsame_(const char *, const char *, ftnlen, ftnlen);
37 real value=0;
38 extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
39 real *);
40 (void)norm_len;
41
42 /* -- LAPACK auxiliary routine (version 3.0) -- */
43 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
44 /* Courant Institute, Argonne National Lab, and Rice University */
45 /* October 31, 1992 */
46
47 /* .. Scalar Arguments .. */
48 /*< CHARACTER NORM >*/
49 /*< INTEGER LDA, M, N >*/
50 /* .. */
51 /* .. Array Arguments .. */
52 /*< REAL A( LDA, * ), WORK( * ) >*/
53 /* .. */
54
55 /* Purpose */
56 /* ======= */
57
58 /* SLANGE returns the value of the one norm, or the Frobenius norm, or */
59 /* the infinity norm, or the element of largest absolute value of a */
60 /* real matrix A. */
61
62 /* Description */
63 /* =========== */
64
65 /* SLANGE returns the value */
66
67 /* SLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
68 /* ( */
69 /* ( norm1(A), NORM = '1', 'O' or 'o' */
70 /* ( */
71 /* ( normI(A), NORM = 'I' or 'i' */
72 /* ( */
73 /* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
74
75 /* where norm1 denotes the one norm of a matrix (maximum column sum), */
76 /* normI denotes the infinity norm of a matrix (maximum row sum) and */
77 /* normF denotes the Frobenius norm of a matrix (square root of sum of */
78 /* squares). Note that max(abs(A(i,j))) is not a matrix norm. */
79
80 /* Arguments */
81 /* ========= */
82
83 /* NORM (input) CHARACTER*1 */
84 /* Specifies the value to be returned in SLANGE as described */
85 /* above. */
86
87 /* M (input) INTEGER */
88 /* The number of rows of the matrix A. M >= 0. When M = 0, */
89 /* SLANGE is set to zero. */
90
91 /* N (input) INTEGER */
92 /* The number of columns of the matrix A. N >= 0. When N = 0, */
93 /* SLANGE is set to zero. */
94
95 /* A (input) REAL array, dimension (LDA,N) */
96 /* The m by n matrix A. */
97
98 /* LDA (input) INTEGER */
99 /* The leading dimension of the array A. LDA >= max(M,1). */
100
101 /* WORK (workspace) REAL array, dimension (LWORK), */
102 /* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
103 /* referenced. */
104
105 /* ===================================================================== */
106
107 /* .. Parameters .. */
108 /*< REAL ONE, ZERO >*/
109 /*< PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) >*/
110 /* .. */
111 /* .. Local Scalars .. */
112 /*< INTEGER I, J >*/
113 /*< REAL SCALE, SUM, VALUE >*/
114 /* .. */
115 /* .. External Subroutines .. */
116 /*< EXTERNAL SLASSQ >*/
117 /* .. */
118 /* .. External Functions .. */
119 /*< LOGICAL LSAME >*/
120 /*< EXTERNAL LSAME >*/
121 /* .. */
122 /* .. Intrinsic Functions .. */
123 /*< INTRINSIC ABS, MAX, MIN, SQRT >*/
124 /* .. */
125 /* .. Executable Statements .. */
126
127 /*< IF( MIN( M, N ).EQ.0 ) THEN >*/
128 /* Parameter adjustments */
129 a_dim1 = *lda;
130 a_offset = 1 + a_dim1;
131 a -= a_offset;
132 --work;
133
134 /* Function Body */
135 if (min(*m,*n) == 0) {
136 /*< VALUE = ZERO >*/
137 value = (float)0.;
138 /*< ELSE IF( LSAME( NORM, 'M' ) ) THEN >*/
139 } else if (lsame_(norm, "M", (ftnlen)1, (ftnlen)1)) {
140
141 /* Find max(abs(A(i,j))). */
142
143 /*< VALUE = ZERO >*/
144 value = (float)0.;
145 /*< DO 20 J = 1, N >*/
146 i__1 = *n;
147 for (j = 1; j <= i__1; ++j) {
148 /*< DO 10 I = 1, M >*/
149 i__2 = *m;
150 for (i__ = 1; i__ <= i__2; ++i__) {
151 /*< VALUE = MAX( VALUE, ABS( A( I, J ) ) ) >*/
152 /* Computing MAX */
153 r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
154 value = dmax(r__2,r__3);
155 /*< 10 CONTINUE >*/
156 /* L10: */
157 }
158 /*< 20 CONTINUE >*/
159 /* L20: */
160 }
161 /*< ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN >*/
162 } else if (lsame_(norm, "O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)
163 norm == '1') {
164
165 /* Find norm1(A). */
166
167 /*< VALUE = ZERO >*/
168 value = (float)0.;
169 /*< DO 40 J = 1, N >*/
170 i__1 = *n;
171 for (j = 1; j <= i__1; ++j) {
172 /*< SUM = ZERO >*/
173 sum = (float)0.;
174 /*< DO 30 I = 1, M >*/
175 i__2 = *m;
176 for (i__ = 1; i__ <= i__2; ++i__) {
177 /*< SUM = SUM + ABS( A( I, J ) ) >*/
178 sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
179 /*< 30 CONTINUE >*/
180 /* L30: */
181 }
182 /*< VALUE = MAX( VALUE, SUM ) >*/
183 value = dmax(value,sum);
184 /*< 40 CONTINUE >*/
185 /* L40: */
186 }
187 /*< ELSE IF( LSAME( NORM, 'I' ) ) THEN >*/
188 } else if (lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
189
190 /* Find normI(A). */
191
192 /*< DO 50 I = 1, M >*/
193 i__1 = *m;
194 for (i__ = 1; i__ <= i__1; ++i__) {
195 /*< WORK( I ) = ZERO >*/
196 work[i__] = (float)0.;
197 /*< 50 CONTINUE >*/
198 /* L50: */
199 }
200 /*< DO 70 J = 1, N >*/
201 i__1 = *n;
202 for (j = 1; j <= i__1; ++j) {
203 /*< DO 60 I = 1, M >*/
204 i__2 = *m;
205 for (i__ = 1; i__ <= i__2; ++i__) {
206 /*< WORK( I ) = WORK( I ) + ABS( A( I, J ) ) >*/
207 work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
208 /*< 60 CONTINUE >*/
209 /* L60: */
210 }
211 /*< 70 CONTINUE >*/
212 /* L70: */
213 }
214 /*< VALUE = ZERO >*/
215 value = (float)0.;
216 /*< DO 80 I = 1, M >*/
217 i__1 = *m;
218 for (i__ = 1; i__ <= i__1; ++i__) {
219 /*< VALUE = MAX( VALUE, WORK( I ) ) >*/
220 /* Computing MAX */
221 r__1 = value, r__2 = work[i__];
222 value = dmax(r__1,r__2);
223 /*< 80 CONTINUE >*/
224 /* L80: */
225 }
226 /*< ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN >*/
227 } else if (lsame_(norm, "F", (ftnlen)1, (ftnlen)1) || lsame_(norm, "E", (
228 ftnlen)1, (ftnlen)1)) {
229
230 /* Find normF(A). */
231
232 /*< SCALE = ZERO >*/
233 scale = (float)0.;
234 /*< SUM = ONE >*/
235 sum = (float)1.;
236 /*< DO 90 J = 1, N >*/
237 i__1 = *n;
238 for (j = 1; j <= i__1; ++j) {
239 /*< CALL SLASSQ( M, A( 1, J ), 1, SCALE, SUM ) >*/
240 slassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
241 /*< 90 CONTINUE >*/
242 /* L90: */
243 }
244 /*< VALUE = SCALE*SQRT( SUM ) >*/
245 value = scale * sqrt(sum);
246 /*< END IF >*/
247 }
248
249 /*< SLANGE = VALUE >*/
250 ret_val = value;
251 /*< RETURN >*/
252 return ret_val;
253
254 /* End of SLANGE */
255
256 /*< END >*/
257 } /* slange_ */
258
259 #ifdef __cplusplus
260 }
261 #endif
262