History

Commit netlib.org version of dgemm.c and lsame.c into source tree. Update readme.md with the netlib.org LAPACK license (modified BSD license).

arr committed 9 years ago

Commit e3e44c81 parent 360d51c3 files · +556 −0Browse files

Unified · Split

3 files
  1. readme.md +51 −0
  2. src/vm/math/dgemm.c +395 −0
  3. src/vm/math/lsame.c +110 −0
readme.md+51−0
@@ -116,6 +116,57 @@ The above copyright notice and this permission notice shall be included in all c · 115 unmodified lines
116 116
117THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.117THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
118 118
119### [LAPACK](http://www.netlib.org/lapack/#_licensing) ###
120
121Copyright (c) 1992-2013 The University of Tennessee and The University
122 of Tennessee Research Foundation. All rights
123 reserved.
124Copyright (c) 2000-2013 The University of California Berkeley. All
125 rights reserved.
126Copyright (c) 2006-2013 The University of Colorado Denver. All rights
127 reserved.
128
129$COPYRIGHT$
130
131Additional copyrights may follow
132
133$HEADER$
134
135Redistribution and use in source and binary forms, with or without
136modification, are permitted provided that the following conditions are
137met:
138
139- Redistributions of source code must retain the above copyright
140 notice, this list of conditions and the following disclaimer.
141
142- Redistributions in binary form must reproduce the above copyright
143 notice, this list of conditions and the following disclaimer listed
144 in this license in the documentation and/or other materials
145 provided with the distribution.
146
147- Neither the name of the copyright holders nor the names of its
148 contributors may be used to endorse or promote products derived from
149 this software without specific prior written permission.
150
151The copyright holders provide no reassurances that the source code
152provided does not infringe any patent, copyright, or any other
153intellectual property rights of third parties. The copyright holders
154disclaim any liability to any recipient for claims brought against
155recipient by any third party for infringement of that parties
156intellectual property rights.
157
158THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
159"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
160LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
161A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
162OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
163SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
164LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
165DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
166THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
167(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
168OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
169
119### Unless otherwise stated in a `license.txt` or above - [MIT License](https://opensource.org/licenses/MIT) ###170### Unless otherwise stated in a `license.txt` or above - [MIT License](https://opensource.org/licenses/MIT) ###
120 171
121Copyright (c) 2017 arr172Copyright (c) 2017 arr
src/vm/math/dgemm.c+395−0
@@ -0,0 +1,395 @@
1
2/* -- translated by f2c (version 19940927).
3 You must link the resulting object file with the libraries:
4 -lf2c -lm (in that order)
5*/
6
7#include "f2c.h"
8
9/* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer *
10 n, integer *k, doublereal *alpha, doublereal *a, integer *lda,
11 doublereal *b, integer *ldb, doublereal *beta, doublereal *c, integer
12 *ldc)
13{
14
15
16 /* System generated locals */
17 integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
18 i__3;
19
20 /* Local variables */
21 static integer info;
22 static logical nota, notb;
23 static doublereal temp;
24 static integer i, j, l, ncola;
25 extern logical lsame_(char *, char *);
26 static integer nrowa, nrowb;
27 extern /* Subroutine */ int xerbla_(char *, integer *);
28
29
30/* Purpose
31 =======
32
33 DGEMM performs one of the matrix-matrix operations
34
35 C := alpha*op( A )*op( B ) + beta*C,
36
37 where op( X ) is one of
38
39 op( X ) = X or op( X ) = X',
40
41 alpha and beta are scalars, and A, B and C are matrices, with op( A )
42
43 an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
44
45
46 Parameters
47 ==========
48
49 TRANSA - CHARACTER*1.
50 On entry, TRANSA specifies the form of op( A ) to be used in
51
52 the matrix multiplication as follows:
53
54 TRANSA = 'N' or 'n', op( A ) = A.
55
56 TRANSA = 'T' or 't', op( A ) = A'.
57
58 TRANSA = 'C' or 'c', op( A ) = A'.
59
60 Unchanged on exit.
61
62 TRANSB - CHARACTER*1.
63 On entry, TRANSB specifies the form of op( B ) to be used in
64
65 the matrix multiplication as follows:
66
67 TRANSB = 'N' or 'n', op( B ) = B.
68
69 TRANSB = 'T' or 't', op( B ) = B'.
70
71 TRANSB = 'C' or 'c', op( B ) = B'.
72
73 Unchanged on exit.
74
75 M - INTEGER.
76 On entry, M specifies the number of rows of the matrix
77
78 op( A ) and of the matrix C. M must be at least zero.
79
80 Unchanged on exit.
81
82 N - INTEGER.
83 On entry, N specifies the number of columns of the matrix
84
85 op( B ) and the number of columns of the matrix C. N must be
86
87 at least zero.
88 Unchanged on exit.
89
90 K - INTEGER.
91 On entry, K specifies the number of columns of the matrix
92
93 op( A ) and the number of rows of the matrix op( B ). K must
94
95 be at least zero.
96 Unchanged on exit.
97
98 ALPHA - DOUBLE PRECISION.
99 On entry, ALPHA specifies the scalar alpha.
100 Unchanged on exit.
101
102 A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
103
104 k when TRANSA = 'N' or 'n', and is m otherwise.
105 Before entry with TRANSA = 'N' or 'n', the leading m by k
106
107 part of the array A must contain the matrix A, otherwise
108
109 the leading k by m part of the array A must contain the
110
111 matrix A.
112 Unchanged on exit.
113
114 LDA - INTEGER.
115 On entry, LDA specifies the first dimension of A as declared
116
117 in the calling (sub) program. When TRANSA = 'N' or 'n' then
118
119 LDA must be at least max( 1, m ), otherwise LDA must be at
120
121 least max( 1, k ).
122 Unchanged on exit.
123
124 B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
125
126 n when TRANSB = 'N' or 'n', and is k otherwise.
127 Before entry with TRANSB = 'N' or 'n', the leading k by n
128
129 part of the array B must contain the matrix B, otherwise
130
131 the leading n by k part of the array B must contain the
132
133 matrix B.
134 Unchanged on exit.
135
136 LDB - INTEGER.
137 On entry, LDB specifies the first dimension of B as declared
138
139 in the calling (sub) program. When TRANSB = 'N' or 'n' then
140
141 LDB must be at least max( 1, k ), otherwise LDB must be at
142
143 least max( 1, n ).
144 Unchanged on exit.
145
146 BETA - DOUBLE PRECISION.
147 On entry, BETA specifies the scalar beta. When BETA is
148
149 supplied as zero then C need not be set on input.
150 Unchanged on exit.
151
152 C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
153 Before entry, the leading m by n part of the array C must
154
155 contain the matrix C, except when beta is zero, in which
156
157 case C need not be set on entry.
158 On exit, the array C is overwritten by the m by n matrix
159
160 ( alpha*op( A )*op( B ) + beta*C ).
161
162 LDC - INTEGER.
163 On entry, LDC specifies the first dimension of C as declared
164
165 in the calling (sub) program. LDC must be at least
166
167 max( 1, m ).
168 Unchanged on exit.
169
170
171 Level 3 Blas routine.
172
173 -- Written on 8-February-1989.
174 Jack Dongarra, Argonne National Laboratory.
175 Iain Duff, AERE Harwell.
176 Jeremy Du Croz, Numerical Algorithms Group Ltd.
177 Sven Hammarling, Numerical Algorithms Group Ltd.
178
179
180
181 Set NOTA and NOTB as true if A and B respectively are not
182
183 transposed and set NROWA, NCOLA and NROWB as the number of rows
184
185 and columns of A and the number of rows of B respectively.
186
187
188
189 Parameter adjustments
190 Function Body */
191
192#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
193#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
194#define C(I,J) c[(I)-1 + ((J)-1)* ( *ldc)]
195
196 nota = lsame_(transa, "N");
197 notb = lsame_(transb, "N");
198 if (nota) {
199 nrowa = *m;
200 ncola = *k;
201 } else {
202 nrowa = *k;
203 ncola = *m;
204 }
205 if (notb) {
206 nrowb = *k;
207 } else {
208 nrowb = *n;
209 }
210
211/* Test the input parameters. */
212
213 info = 0;
214 if (! nota && ! lsame_(transa, "C") && ! lsame_(transa, "T")) {
215 info = 1;
216 } else if (! notb && ! lsame_(transb, "C") && ! lsame_(transb,
217 "T")) {
218 info = 2;
219 } else if (*m < 0) {
220 info = 3;
221 } else if (*n < 0) {
222 info = 4;
223 } else if (*k < 0) {
224 info = 5;
225 } else if (*lda < max(1,nrowa)) {
226 info = 8;
227 } else if (*ldb < max(1,nrowb)) {
228 info = 10;
229 } else if (*ldc < max(1,*m)) {
230 info = 13;
231 }
232 if (info != 0) {
233 xerbla_("DGEMM ", &info);
234 return 0;
235 }
236
237/* Quick return if possible. */
238
239 if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
240 return 0;
241 }
242
243/* And if alpha.eq.zero. */
244
245 if (*alpha == 0.) {
246 if (*beta == 0.) {
247 i__1 = *n;
248 for (j = 1; j <= *n; ++j) {
249 i__2 = *m;
250 for (i = 1; i <= *m; ++i) {
251 C(i,j) = 0.;
252/* L10: */
253 }
254/* L20: */
255 }
256 } else {
257 i__1 = *n;
258 for (j = 1; j <= *n; ++j) {
259 i__2 = *m;
260 for (i = 1; i <= *m; ++i) {
261 C(i,j) = *beta * C(i,j);
262/* L30: */
263 }
264/* L40: */
265 }
266 }
267 return 0;
268 }
269
270/* Start the operations. */
271
272 if (notb) {
273 if (nota) {
274
275/* Form C := alpha*A*B + beta*C. */
276
277 i__1 = *n;
278 for (j = 1; j <= *n; ++j) {
279 if (*beta == 0.) {
280 i__2 = *m;
281 for (i = 1; i <= *m; ++i) {
282 C(i,j) = 0.;
283/* L50: */
284 }
285 } else if (*beta != 1.) {
286 i__2 = *m;
287 for (i = 1; i <= *m; ++i) {
288 C(i,j) = *beta * C(i,j);
289/* L60: */
290 }
291 }
292 i__2 = *k;
293 for (l = 1; l <= *k; ++l) {
294 if (B(l,j) != 0.) {
295 temp = *alpha * B(l,j);
296 i__3 = *m;
297 for (i = 1; i <= *m; ++i) {
298 C(i,j) += temp * A(i,l);
299/* L70: */
300 }
301 }
302/* L80: */
303 }
304/* L90: */
305 }
306 } else {
307
308/* Form C := alpha*A'*B + beta*C */
309
310 i__1 = *n;
311 for (j = 1; j <= *n; ++j) {
312 i__2 = *m;
313 for (i = 1; i <= *m; ++i) {
314 temp = 0.;
315 i__3 = *k;
316 for (l = 1; l <= *k; ++l) {
317 temp += A(l,i) * B(l,j);
318/* L100: */
319 }
320 if (*beta == 0.) {
321 C(i,j) = *alpha * temp;
322 } else {
323 C(i,j) = *alpha * temp + *beta * C(i,j);
324 }
325/* L110: */
326 }
327/* L120: */
328 }
329 }
330 } else {
331 if (nota) {
332
333/* Form C := alpha*A*B' + beta*C */
334
335 i__1 = *n;
336 for (j = 1; j <= *n; ++j) {
337 if (*beta == 0.) {
338 i__2 = *m;
339 for (i = 1; i <= *m; ++i) {
340 C(i,j) = 0.;
341/* L130: */
342 }
343 } else if (*beta != 1.) {
344 i__2 = *m;
345 for (i = 1; i <= *m; ++i) {
346 C(i,j) = *beta * C(i,j);
347/* L140: */
348 }
349 }
350 i__2 = *k;
351 for (l = 1; l <= *k; ++l) {
352 if (B(j,l) != 0.) {
353 temp = *alpha * B(j,l);
354 i__3 = *m;
355 for (i = 1; i <= *m; ++i) {
356 C(i,j) += temp * A(i,l);
357/* L150: */
358 }
359 }
360/* L160: */
361 }
362/* L170: */
363 }
364 } else {
365
366/* Form C := alpha*A'*B' + beta*C */
367
368 i__1 = *n;
369 for (j = 1; j <= *n; ++j) {
370 i__2 = *m;
371 for (i = 1; i <= *m; ++i) {
372 temp = 0.;
373 i__3 = *k;
374 for (l = 1; l <= *k; ++l) {
375 temp += A(l,i) * B(j,l);
376/* L180: */
377 }
378 if (*beta == 0.) {
379 C(i,j) = *alpha * temp;
380 } else {
381 C(i,j) = *alpha * temp + *beta * C(i,j);
382 }
383/* L190: */
384 }
385/* L200: */
386 }
387 }
388 }
389
390 return 0;
391
392/* End of DGEMM . */
393
394} /* dgemm_ */
395
src/vm/math/lsame.c+110−0
@@ -0,0 +1,110 @@
1/* -- translated by f2c (version 19940927).
2 You must link the resulting object file with the libraries:
3 -lf2c -lm (in that order)
4*/
5
6#include "f2c.h"
7
8logical lsame_(char *ca, char *cb)
9{
10
11
12 /* System generated locals */
13 logical ret_val;
14
15 /* Local variables */
16 static integer inta, intb, zcode;
17
18
19/* -- LAPACK auxiliary routine (version 2.0) --
20 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
21 Courant Institute, Argonne National Lab, and Rice University
22 January 31, 1994
23
24
25 Purpose
26 =======
27
28 LSAME returns .TRUE. if CA is the same letter as CB regardless of
29 case.
30
31 Arguments
32 =========
33
34 CA (input) CHARACTER*1
35 CB (input) CHARACTER*1
36 CA and CB specify the single characters to be compared.
37
38 =====================================================================
39
40
41
42 Test if the characters are equal */
43
44 ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
45 if (ret_val) {
46 return ret_val;
47 }
48
49/* Now test for equivalence if both characters are alphabetic. */
50
51 zcode = 'Z';
52
53/* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
54 machines, on which ICHAR returns a value with bit 8 set.
55 ICHAR('A') on Prime machines returns 193 which is the same as
56 ICHAR('A') on an EBCDIC machine. */
57
58 inta = *(unsigned char *)ca;
59 intb = *(unsigned char *)cb;
60
61 if (zcode == 90 || zcode == 122) {
62
63/* ASCII is assumed - ZCODE is the ASCII code of either lower o
64r
65 upper case 'Z'. */
66
67 if (inta >= 97 && inta <= 122) {
68 inta += -32;
69 }
70 if (intb >= 97 && intb <= 122) {
71 intb += -32;
72 }
73
74 } else if (zcode == 233 || zcode == 169) {
75
76/* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower
77 or
78 upper case 'Z'. */
79
80 if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 || inta
81 >= 162 && inta <= 169) {
82 inta += 64;
83 }
84 if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 || intb
85 >= 162 && intb <= 169) {
86 intb += 64;
87 }
88
89 } else if (zcode == 218 || zcode == 250) {
90
91/* ASCII is assumed, on Prime machines - ZCODE is the ASCII cod
92e
93 plus 128 of either lower or upper case 'Z'. */
94
95 if (inta >= 225 && inta <= 250) {
96 inta += -32;
97 }
98 if (intb >= 225 && intb <= 250) {
99 intb += -32;
100 }
101 }
102 ret_val = inta == intb;
103
104/* RETURN
105
106 End of LSAME */
107
108 return ret_val;
109} /* lsame_ */
110

Keyboard shortcuts

General

Show keyboard shortcuts
?
Focus the current search
/

Issues and pull requests

Open filters
f

Issues, pull requests and Inbox

Select next item
j↓
Select previous item
k↑
Open selected item
Enter
Dismiss filters or clear selection
Esc

Repository code

Go to file
t