Merge lp://qastaging/~nipy-developers/nipy/lapack-included into lp://qastaging/~nipy-developers/nipy/obsolete-do-not-use
- lapack-included
- Merge into obsolete-do-not-use
Status: | Rejected |
---|---|
Rejected by: | Matthew Brett |
Proposed branch: | lp://qastaging/~nipy-developers/nipy/lapack-included |
Merge into: | lp://qastaging/~nipy-developers/nipy/obsolete-do-not-use |
Diff against target: |
49385 lines (+49271/-35) 10 files modified
libcstat/lapack_lite/blas_lite.c (+5676/-0) libcstat/lapack_lite/dlamch.c (+951/-0) libcstat/lapack_lite/dlapack_lite.c (+41548/-0) libcstat/lapack_lite/f2c.h (+217/-0) libcstat/lapack_lite/f2c_lite.c (+519/-0) libcstat/lapack_lite/remake/README (+31/-0) libcstat/lapack_lite/remake/make_lite.py (+264/-0) libcstat/lapack_lite/remake/wrapped_routines.txt (+40/-0) nipy/neurospin/__init__.py (+2/-1) nipy/neurospin/setup.py (+23/-34) |
To merge this branch: | bzr merge lp://qastaging/~nipy-developers/nipy/lapack-included |
Related bugs: |
Reviewer | Review Type | Date Requested | Status |
---|---|---|---|
Matthew Brett | Disapprove | ||
Review via email:
|
Commit message
Description of the change
![](/+icing/build/overlay/assets/skins/sam/images/close.gif)
Alexis Roche (alexis-roche) wrote : | # |
![](/+icing/build/overlay/assets/skins/sam/images/close.gif)
Matthew Brett (matthew-brett) wrote : | # |
Thanks for doing this.
Just a question - can you think of any way of dealing with this by an automated pull-and-patch from the numpy sources? Is there anything of the fixes here that we should contribute back to numpy, to make it easier to maintain?
I see you've made the dependency checks not raise an error, but this means that anyone running the tests and without the dependencies, is likely to hit lots of errors. I suggest we take that back to the list, and remove it from this patch, because it's solving a different problem.
For future portability and to reduce some odd effects, all classes should be explicitly new-style;
class FortranRoutine: -> class FortranRoutine(
- 1801. By Alexis Roche
-
Revert main setup.py to original version (hard dependency check)
![](/+icing/build/overlay/assets/skins/sam/images/close.gif)
Alexis Roche (alexis-roche) wrote : | # |
Hi,
> Just a question - can you think of any way of dealing with this by an automated pull-and-patch from the numpy sources? Is there anything of the fixes here that we should contribute back to numpy, to make it easier to maintain?
The mechanism I implemented is mainly a copy-paste from the numpy
approach, so I am afraid there is not much to contribute back at the
moment. This is described here:
Of course, the ideal situation would be to have lapack_lite exposed by
numpy, and I am willing to contribute any effort in that direction if
I can help. From the nipy side, we will have to make sure that all the
routines we need are included in that library.
Note that we have the very same problem with the randomkit library (a
copy of which is currently sleeping in our repo).
> I see you've made the dependency checks not raise an error, but this means that anyone running the tests and without the dependencies, is likely to hit lots of errors. I suggest we take that back to the list, and remove it from this patch, because it's solving a different problem.
>
Yeah, I agree, I just reverted it (it was my initial intention, but forgot).
This brings us back to the ease-of-
last week. I am using this custom setup.py to avoid installing pynifti
on my windows system, which is currently a non-trivial task with
python 2.6 (last time I checked, there was no binary installer).
Cheers,
Alexis
![](/+icing/build/overlay/assets/skins/sam/images/close.gif)
Matthew Brett (matthew-brett) wrote : | # |
Alexis - I believe this branch is superseded by the later neurospin trunk merge? OK to 'supersede' this branch?
![](/+icing/build/overlay/assets/skins/sam/images/close.gif)
Alexis Roche (alexis-roche) wrote : | # |
OK.
Happy new year BTW.
Cheers,
Alexis
On Wed, Jan 13, 2010 at 2:06 PM, Matthew Brett <email address hidden> wrote:
> Alexis - I believe this branch is superseded by the later neurospin trunk merge? OK to 'supersede' this branch?
> --
> https:/
> You proposed lp:~nipy-developers/nipy/lapack-included for merging.
>
--
Alexis Roche, PhD
Researcher, CEA, Neurospin, Paris, France
Academic Guest, ETHZ, Computer Vision Lab, Zurich, Switzerland
http://
![](/+icing/build/overlay/assets/skins/sam/images/close.gif)
Matthew Brett (matthew-brett) wrote : | # |
Thanks - likewise...
![](/+icing/build/overlay/assets/skins/sam/images/close.gif)
Alexis Roche (alexis-roche) wrote : | # |
Hi,
I'd like to add you to my professional network on LinkedIn.
- Alexis
You received an invitation to connect. LinkedIn will use your email address to make suggestions to our members in features like People You May Know. Unsubscribe here: http://
© 2014, LinkedIn Corporation. 2029 Stierlin Ct. Mountain View, CA 94043, USA
Unmerged revisions
- 1801. By Alexis Roche
-
Revert main setup.py to original version (hard dependency check)
Preview Diff
1 | === added directory 'libcstat/lapack_lite' |
2 | === added file 'libcstat/lapack_lite/blas_lite.c' |
3 | --- libcstat/lapack_lite/blas_lite.c 1970-01-01 00:00:00 +0000 |
4 | +++ libcstat/lapack_lite/blas_lite.c 2009-11-14 08:49:09 +0000 |
5 | @@ -0,0 +1,5676 @@ |
6 | +/* |
7 | +NOTE: This is generated code. Look in Misc/lapack_lite for information on |
8 | + remaking this file. |
9 | +*/ |
10 | +#include "f2c.h" |
11 | + |
12 | +#ifdef HAVE_CONFIG |
13 | +#include "config.h" |
14 | +#else |
15 | +extern doublereal dlamch_(char *); |
16 | +#define EPSILON dlamch_("Epsilon") |
17 | +#define SAFEMINIMUM dlamch_("Safe minimum") |
18 | +#define PRECISION dlamch_("Precision") |
19 | +#define BASE dlamch_("Base") |
20 | +#endif |
21 | + |
22 | +extern doublereal dlapy2_(doublereal *x, doublereal *y); |
23 | + |
24 | + |
25 | + |
26 | +/* Table of constant values */ |
27 | + |
28 | +static doublereal c_b90 = 1.; |
29 | +static integer c__1 = 1; |
30 | + |
31 | +doublereal dasum_(integer *n, doublereal *dx, integer *incx) |
32 | +{ |
33 | + /* System generated locals */ |
34 | + integer i__1, i__2; |
35 | + doublereal ret_val, d__1, d__2, d__3, d__4, d__5, d__6; |
36 | + |
37 | + /* Local variables */ |
38 | + static integer i__, m; |
39 | + static doublereal dtemp; |
40 | + static integer nincx, mp1; |
41 | + |
42 | + |
43 | +/* |
44 | + Purpose |
45 | + ======= |
46 | + |
47 | + takes the sum of the absolute values. |
48 | + jack dongarra, linpack, 3/11/78. |
49 | + modified 3/93 to return if incx .le. 0. |
50 | + modified 12/3/93, array(1) declarations changed to array(*) |
51 | +*/ |
52 | + |
53 | + |
54 | + /* Parameter adjustments */ |
55 | + --dx; |
56 | + |
57 | + /* Function Body */ |
58 | + ret_val = 0.; |
59 | + dtemp = 0.; |
60 | + if (*n <= 0 || *incx <= 0) { |
61 | + return ret_val; |
62 | + } |
63 | + if (*incx == 1) { |
64 | + goto L20; |
65 | + } |
66 | + |
67 | +/* code for increment not equal to 1 */ |
68 | + |
69 | + nincx = *n * *incx; |
70 | + i__1 = nincx; |
71 | + i__2 = *incx; |
72 | + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { |
73 | + dtemp += (d__1 = dx[i__], abs(d__1)); |
74 | +/* L10: */ |
75 | + } |
76 | + ret_val = dtemp; |
77 | + return ret_val; |
78 | + |
79 | +/* |
80 | + code for increment equal to 1 |
81 | + |
82 | + |
83 | + clean-up loop |
84 | +*/ |
85 | + |
86 | +L20: |
87 | + m = *n % 6; |
88 | + if (m == 0) { |
89 | + goto L40; |
90 | + } |
91 | + i__2 = m; |
92 | + for (i__ = 1; i__ <= i__2; ++i__) { |
93 | + dtemp += (d__1 = dx[i__], abs(d__1)); |
94 | +/* L30: */ |
95 | + } |
96 | + if (*n < 6) { |
97 | + goto L60; |
98 | + } |
99 | +L40: |
100 | + mp1 = m + 1; |
101 | + i__2 = *n; |
102 | + for (i__ = mp1; i__ <= i__2; i__ += 6) { |
103 | + dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1], |
104 | + abs(d__2)) + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = dx[i__ |
105 | + + 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5)) + (d__6 = |
106 | + dx[i__ + 5], abs(d__6)); |
107 | +/* L50: */ |
108 | + } |
109 | +L60: |
110 | + ret_val = dtemp; |
111 | + return ret_val; |
112 | +} /* dasum_ */ |
113 | + |
114 | +/* Subroutine */ int daxpy_(integer *n, doublereal *da, doublereal *dx, |
115 | + integer *incx, doublereal *dy, integer *incy) |
116 | +{ |
117 | + /* System generated locals */ |
118 | + integer i__1; |
119 | + |
120 | + /* Local variables */ |
121 | + static integer i__, m, ix, iy, mp1; |
122 | + |
123 | + |
124 | +/* |
125 | + Purpose |
126 | + ======= |
127 | + |
128 | + constant times a vector plus a vector. |
129 | + uses unrolled loops for increments equal to one. |
130 | + jack dongarra, linpack, 3/11/78. |
131 | + modified 12/3/93, array(1) declarations changed to array(*) |
132 | +*/ |
133 | + |
134 | + |
135 | + /* Parameter adjustments */ |
136 | + --dy; |
137 | + --dx; |
138 | + |
139 | + /* Function Body */ |
140 | + if (*n <= 0) { |
141 | + return 0; |
142 | + } |
143 | + if (*da == 0.) { |
144 | + return 0; |
145 | + } |
146 | + if (*incx == 1 && *incy == 1) { |
147 | + goto L20; |
148 | + } |
149 | + |
150 | +/* |
151 | + code for unequal increments or equal increments |
152 | + not equal to 1 |
153 | +*/ |
154 | + |
155 | + ix = 1; |
156 | + iy = 1; |
157 | + if (*incx < 0) { |
158 | + ix = (-(*n) + 1) * *incx + 1; |
159 | + } |
160 | + if (*incy < 0) { |
161 | + iy = (-(*n) + 1) * *incy + 1; |
162 | + } |
163 | + i__1 = *n; |
164 | + for (i__ = 1; i__ <= i__1; ++i__) { |
165 | + dy[iy] += *da * dx[ix]; |
166 | + ix += *incx; |
167 | + iy += *incy; |
168 | +/* L10: */ |
169 | + } |
170 | + return 0; |
171 | + |
172 | +/* |
173 | + code for both increments equal to 1 |
174 | + |
175 | + |
176 | + clean-up loop |
177 | +*/ |
178 | + |
179 | +L20: |
180 | + m = *n % 4; |
181 | + if (m == 0) { |
182 | + goto L40; |
183 | + } |
184 | + i__1 = m; |
185 | + for (i__ = 1; i__ <= i__1; ++i__) { |
186 | + dy[i__] += *da * dx[i__]; |
187 | +/* L30: */ |
188 | + } |
189 | + if (*n < 4) { |
190 | + return 0; |
191 | + } |
192 | +L40: |
193 | + mp1 = m + 1; |
194 | + i__1 = *n; |
195 | + for (i__ = mp1; i__ <= i__1; i__ += 4) { |
196 | + dy[i__] += *da * dx[i__]; |
197 | + dy[i__ + 1] += *da * dx[i__ + 1]; |
198 | + dy[i__ + 2] += *da * dx[i__ + 2]; |
199 | + dy[i__ + 3] += *da * dx[i__ + 3]; |
200 | +/* L50: */ |
201 | + } |
202 | + return 0; |
203 | +} /* daxpy_ */ |
204 | + |
205 | +doublereal dcabs1_(doublecomplex *z__) |
206 | +{ |
207 | + /* System generated locals */ |
208 | + doublereal ret_val, d__1, d__2; |
209 | + |
210 | + /* Builtin functions */ |
211 | + double d_imag(doublecomplex *); |
212 | + |
213 | +/* |
214 | + Purpose |
215 | + ======= |
216 | + |
217 | + DCABS1 computes absolute value of a double complex number |
218 | +*/ |
219 | + |
220 | + |
221 | + ret_val = (d__1 = z__->r, abs(d__1)) + (d__2 = d_imag(z__), abs(d__2)); |
222 | + return ret_val; |
223 | +} /* dcabs1_ */ |
224 | + |
225 | +/* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx, |
226 | + doublereal *dy, integer *incy) |
227 | +{ |
228 | + /* System generated locals */ |
229 | + integer i__1; |
230 | + |
231 | + /* Local variables */ |
232 | + static integer i__, m, ix, iy, mp1; |
233 | + |
234 | + |
235 | +/* |
236 | + Purpose |
237 | + ======= |
238 | + |
239 | + copies a vector, x, to a vector, y. |
240 | + uses unrolled loops for increments equal to one. |
241 | + jack dongarra, linpack, 3/11/78. |
242 | + modified 12/3/93, array(1) declarations changed to array(*) |
243 | +*/ |
244 | + |
245 | + |
246 | + /* Parameter adjustments */ |
247 | + --dy; |
248 | + --dx; |
249 | + |
250 | + /* Function Body */ |
251 | + if (*n <= 0) { |
252 | + return 0; |
253 | + } |
254 | + if (*incx == 1 && *incy == 1) { |
255 | + goto L20; |
256 | + } |
257 | + |
258 | +/* |
259 | + code for unequal increments or equal increments |
260 | + not equal to 1 |
261 | +*/ |
262 | + |
263 | + ix = 1; |
264 | + iy = 1; |
265 | + if (*incx < 0) { |
266 | + ix = (-(*n) + 1) * *incx + 1; |
267 | + } |
268 | + if (*incy < 0) { |
269 | + iy = (-(*n) + 1) * *incy + 1; |
270 | + } |
271 | + i__1 = *n; |
272 | + for (i__ = 1; i__ <= i__1; ++i__) { |
273 | + dy[iy] = dx[ix]; |
274 | + ix += *incx; |
275 | + iy += *incy; |
276 | +/* L10: */ |
277 | + } |
278 | + return 0; |
279 | + |
280 | +/* |
281 | + code for both increments equal to 1 |
282 | + |
283 | + |
284 | + clean-up loop |
285 | +*/ |
286 | + |
287 | +L20: |
288 | + m = *n % 7; |
289 | + if (m == 0) { |
290 | + goto L40; |
291 | + } |
292 | + i__1 = m; |
293 | + for (i__ = 1; i__ <= i__1; ++i__) { |
294 | + dy[i__] = dx[i__]; |
295 | +/* L30: */ |
296 | + } |
297 | + if (*n < 7) { |
298 | + return 0; |
299 | + } |
300 | +L40: |
301 | + mp1 = m + 1; |
302 | + i__1 = *n; |
303 | + for (i__ = mp1; i__ <= i__1; i__ += 7) { |
304 | + dy[i__] = dx[i__]; |
305 | + dy[i__ + 1] = dx[i__ + 1]; |
306 | + dy[i__ + 2] = dx[i__ + 2]; |
307 | + dy[i__ + 3] = dx[i__ + 3]; |
308 | + dy[i__ + 4] = dx[i__ + 4]; |
309 | + dy[i__ + 5] = dx[i__ + 5]; |
310 | + dy[i__ + 6] = dx[i__ + 6]; |
311 | +/* L50: */ |
312 | + } |
313 | + return 0; |
314 | +} /* dcopy_ */ |
315 | + |
316 | +doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, |
317 | + integer *incy) |
318 | +{ |
319 | + /* System generated locals */ |
320 | + integer i__1; |
321 | + doublereal ret_val; |
322 | + |
323 | + /* Local variables */ |
324 | + static integer i__, m; |
325 | + static doublereal dtemp; |
326 | + static integer ix, iy, mp1; |
327 | + |
328 | + |
329 | +/* |
330 | + Purpose |
331 | + ======= |
332 | + |
333 | + forms the dot product of two vectors. |
334 | + uses unrolled loops for increments equal to one. |
335 | + jack dongarra, linpack, 3/11/78. |
336 | + modified 12/3/93, array(1) declarations changed to array(*) |
337 | +*/ |
338 | + |
339 | + |
340 | + /* Parameter adjustments */ |
341 | + --dy; |
342 | + --dx; |
343 | + |
344 | + /* Function Body */ |
345 | + ret_val = 0.; |
346 | + dtemp = 0.; |
347 | + if (*n <= 0) { |
348 | + return ret_val; |
349 | + } |
350 | + if (*incx == 1 && *incy == 1) { |
351 | + goto L20; |
352 | + } |
353 | + |
354 | +/* |
355 | + code for unequal increments or equal increments |
356 | + not equal to 1 |
357 | +*/ |
358 | + |
359 | + ix = 1; |
360 | + iy = 1; |
361 | + if (*incx < 0) { |
362 | + ix = (-(*n) + 1) * *incx + 1; |
363 | + } |
364 | + if (*incy < 0) { |
365 | + iy = (-(*n) + 1) * *incy + 1; |
366 | + } |
367 | + i__1 = *n; |
368 | + for (i__ = 1; i__ <= i__1; ++i__) { |
369 | + dtemp += dx[ix] * dy[iy]; |
370 | + ix += *incx; |
371 | + iy += *incy; |
372 | +/* L10: */ |
373 | + } |
374 | + ret_val = dtemp; |
375 | + return ret_val; |
376 | + |
377 | +/* |
378 | + code for both increments equal to 1 |
379 | + |
380 | + |
381 | + clean-up loop |
382 | +*/ |
383 | + |
384 | +L20: |
385 | + m = *n % 5; |
386 | + if (m == 0) { |
387 | + goto L40; |
388 | + } |
389 | + i__1 = m; |
390 | + for (i__ = 1; i__ <= i__1; ++i__) { |
391 | + dtemp += dx[i__] * dy[i__]; |
392 | +/* L30: */ |
393 | + } |
394 | + if (*n < 5) { |
395 | + goto L60; |
396 | + } |
397 | +L40: |
398 | + mp1 = m + 1; |
399 | + i__1 = *n; |
400 | + for (i__ = mp1; i__ <= i__1; i__ += 5) { |
401 | + dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] + dx[ |
402 | + i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] + dx[i__ + |
403 | + 4] * dy[i__ + 4]; |
404 | +/* L50: */ |
405 | + } |
406 | +L60: |
407 | + ret_val = dtemp; |
408 | + return ret_val; |
409 | +} /* ddot_ */ |
410 | + |
411 | +/* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer * |
412 | + n, integer *k, doublereal *alpha, doublereal *a, integer *lda, |
413 | + doublereal *b, integer *ldb, doublereal *beta, doublereal *c__, |
414 | + integer *ldc) |
415 | +{ |
416 | + /* System generated locals */ |
417 | + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, |
418 | + i__3; |
419 | + |
420 | + /* Local variables */ |
421 | + static integer info; |
422 | + static logical nota, notb; |
423 | + static doublereal temp; |
424 | + static integer i__, j, l, ncola; |
425 | + extern logical lsame_(char *, char *); |
426 | + static integer nrowa, nrowb; |
427 | + extern /* Subroutine */ int xerbla_(char *, integer *); |
428 | + |
429 | + |
430 | +/* |
431 | + Purpose |
432 | + ======= |
433 | + |
434 | + DGEMM performs one of the matrix-matrix operations |
435 | + |
436 | + C := alpha*op( A )*op( B ) + beta*C, |
437 | + |
438 | + where op( X ) is one of |
439 | + |
440 | + op( X ) = X or op( X ) = X', |
441 | + |
442 | + alpha and beta are scalars, and A, B and C are matrices, with op( A ) |
443 | + an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. |
444 | + |
445 | + Arguments |
446 | + ========== |
447 | + |
448 | + TRANSA - CHARACTER*1. |
449 | + On entry, TRANSA specifies the form of op( A ) to be used in |
450 | + the matrix multiplication as follows: |
451 | + |
452 | + TRANSA = 'N' or 'n', op( A ) = A. |
453 | + |
454 | + TRANSA = 'T' or 't', op( A ) = A'. |
455 | + |
456 | + TRANSA = 'C' or 'c', op( A ) = A'. |
457 | + |
458 | + Unchanged on exit. |
459 | + |
460 | + TRANSB - CHARACTER*1. |
461 | + On entry, TRANSB specifies the form of op( B ) to be used in |
462 | + the matrix multiplication as follows: |
463 | + |
464 | + TRANSB = 'N' or 'n', op( B ) = B. |
465 | + |
466 | + TRANSB = 'T' or 't', op( B ) = B'. |
467 | + |
468 | + TRANSB = 'C' or 'c', op( B ) = B'. |
469 | + |
470 | + Unchanged on exit. |
471 | + |
472 | + M - INTEGER. |
473 | + On entry, M specifies the number of rows of the matrix |
474 | + op( A ) and of the matrix C. M must be at least zero. |
475 | + Unchanged on exit. |
476 | + |
477 | + N - INTEGER. |
478 | + On entry, N specifies the number of columns of the matrix |
479 | + op( B ) and the number of columns of the matrix C. N must be |
480 | + at least zero. |
481 | + Unchanged on exit. |
482 | + |
483 | + K - INTEGER. |
484 | + On entry, K specifies the number of columns of the matrix |
485 | + op( A ) and the number of rows of the matrix op( B ). K must |
486 | + be at least zero. |
487 | + Unchanged on exit. |
488 | + |
489 | + ALPHA - DOUBLE PRECISION. |
490 | + On entry, ALPHA specifies the scalar alpha. |
491 | + Unchanged on exit. |
492 | + |
493 | + A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is |
494 | + k when TRANSA = 'N' or 'n', and is m otherwise. |
495 | + Before entry with TRANSA = 'N' or 'n', the leading m by k |
496 | + part of the array A must contain the matrix A, otherwise |
497 | + the leading k by m part of the array A must contain the |
498 | + matrix A. |
499 | + Unchanged on exit. |
500 | + |
501 | + LDA - INTEGER. |
502 | + On entry, LDA specifies the first dimension of A as declared |
503 | + in the calling (sub) program. When TRANSA = 'N' or 'n' then |
504 | + LDA must be at least max( 1, m ), otherwise LDA must be at |
505 | + least max( 1, k ). |
506 | + Unchanged on exit. |
507 | + |
508 | + B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is |
509 | + n when TRANSB = 'N' or 'n', and is k otherwise. |
510 | + Before entry with TRANSB = 'N' or 'n', the leading k by n |
511 | + part of the array B must contain the matrix B, otherwise |
512 | + the leading n by k part of the array B must contain the |
513 | + matrix B. |
514 | + Unchanged on exit. |
515 | + |
516 | + LDB - INTEGER. |
517 | + On entry, LDB specifies the first dimension of B as declared |
518 | + in the calling (sub) program. When TRANSB = 'N' or 'n' then |
519 | + LDB must be at least max( 1, k ), otherwise LDB must be at |
520 | + least max( 1, n ). |
521 | + Unchanged on exit. |
522 | + |
523 | + BETA - DOUBLE PRECISION. |
524 | + On entry, BETA specifies the scalar beta. When BETA is |
525 | + supplied as zero then C need not be set on input. |
526 | + Unchanged on exit. |
527 | + |
528 | + C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). |
529 | + Before entry, the leading m by n part of the array C must |
530 | + contain the matrix C, except when beta is zero, in which |
531 | + case C need not be set on entry. |
532 | + On exit, the array C is overwritten by the m by n matrix |
533 | + ( alpha*op( A )*op( B ) + beta*C ). |
534 | + |
535 | + LDC - INTEGER. |
536 | + On entry, LDC specifies the first dimension of C as declared |
537 | + in the calling (sub) program. LDC must be at least |
538 | + max( 1, m ). |
539 | + Unchanged on exit. |
540 | + |
541 | + |
542 | + Level 3 Blas routine. |
543 | + |
544 | + -- Written on 8-February-1989. |
545 | + Jack Dongarra, Argonne National Laboratory. |
546 | + Iain Duff, AERE Harwell. |
547 | + Jeremy Du Croz, Numerical Algorithms Group Ltd. |
548 | + Sven Hammarling, Numerical Algorithms Group Ltd. |
549 | + |
550 | + |
551 | + Set NOTA and NOTB as true if A and B respectively are not |
552 | + transposed and set NROWA, NCOLA and NROWB as the number of rows |
553 | + and columns of A and the number of rows of B respectively. |
554 | +*/ |
555 | + |
556 | + /* Parameter adjustments */ |
557 | + a_dim1 = *lda; |
558 | + a_offset = 1 + a_dim1 * 1; |
559 | + a -= a_offset; |
560 | + b_dim1 = *ldb; |
561 | + b_offset = 1 + b_dim1 * 1; |
562 | + b -= b_offset; |
563 | + c_dim1 = *ldc; |
564 | + c_offset = 1 + c_dim1 * 1; |
565 | + c__ -= c_offset; |
566 | + |
567 | + /* Function Body */ |
568 | + nota = lsame_(transa, "N"); |
569 | + notb = lsame_(transb, "N"); |
570 | + if (nota) { |
571 | + nrowa = *m; |
572 | + ncola = *k; |
573 | + } else { |
574 | + nrowa = *k; |
575 | + ncola = *m; |
576 | + } |
577 | + if (notb) { |
578 | + nrowb = *k; |
579 | + } else { |
580 | + nrowb = *n; |
581 | + } |
582 | + |
583 | +/* Test the input parameters. */ |
584 | + |
585 | + info = 0; |
586 | + if (! nota && ! lsame_(transa, "C") && ! lsame_( |
587 | + transa, "T")) { |
588 | + info = 1; |
589 | + } else if (! notb && ! lsame_(transb, "C") && ! |
590 | + lsame_(transb, "T")) { |
591 | + info = 2; |
592 | + } else if (*m < 0) { |
593 | + info = 3; |
594 | + } else if (*n < 0) { |
595 | + info = 4; |
596 | + } else if (*k < 0) { |
597 | + info = 5; |
598 | + } else if (*lda < max(1,nrowa)) { |
599 | + info = 8; |
600 | + } else if (*ldb < max(1,nrowb)) { |
601 | + info = 10; |
602 | + } else if (*ldc < max(1,*m)) { |
603 | + info = 13; |
604 | + } |
605 | + if (info != 0) { |
606 | + xerbla_("DGEMM ", &info); |
607 | + return 0; |
608 | + } |
609 | + |
610 | +/* Quick return if possible. */ |
611 | + |
612 | + if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { |
613 | + return 0; |
614 | + } |
615 | + |
616 | +/* And if alpha.eq.zero. */ |
617 | + |
618 | + if (*alpha == 0.) { |
619 | + if (*beta == 0.) { |
620 | + i__1 = *n; |
621 | + for (j = 1; j <= i__1; ++j) { |
622 | + i__2 = *m; |
623 | + for (i__ = 1; i__ <= i__2; ++i__) { |
624 | + c__[i__ + j * c_dim1] = 0.; |
625 | +/* L10: */ |
626 | + } |
627 | +/* L20: */ |
628 | + } |
629 | + } else { |
630 | + i__1 = *n; |
631 | + for (j = 1; j <= i__1; ++j) { |
632 | + i__2 = *m; |
633 | + for (i__ = 1; i__ <= i__2; ++i__) { |
634 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; |
635 | +/* L30: */ |
636 | + } |
637 | +/* L40: */ |
638 | + } |
639 | + } |
640 | + return 0; |
641 | + } |
642 | + |
643 | +/* Start the operations. */ |
644 | + |
645 | + if (notb) { |
646 | + if (nota) { |
647 | + |
648 | +/* Form C := alpha*A*B + beta*C. */ |
649 | + |
650 | + i__1 = *n; |
651 | + for (j = 1; j <= i__1; ++j) { |
652 | + if (*beta == 0.) { |
653 | + i__2 = *m; |
654 | + for (i__ = 1; i__ <= i__2; ++i__) { |
655 | + c__[i__ + j * c_dim1] = 0.; |
656 | +/* L50: */ |
657 | + } |
658 | + } else if (*beta != 1.) { |
659 | + i__2 = *m; |
660 | + for (i__ = 1; i__ <= i__2; ++i__) { |
661 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; |
662 | +/* L60: */ |
663 | + } |
664 | + } |
665 | + i__2 = *k; |
666 | + for (l = 1; l <= i__2; ++l) { |
667 | + if (b[l + j * b_dim1] != 0.) { |
668 | + temp = *alpha * b[l + j * b_dim1]; |
669 | + i__3 = *m; |
670 | + for (i__ = 1; i__ <= i__3; ++i__) { |
671 | + c__[i__ + j * c_dim1] += temp * a[i__ + l * |
672 | + a_dim1]; |
673 | +/* L70: */ |
674 | + } |
675 | + } |
676 | +/* L80: */ |
677 | + } |
678 | +/* L90: */ |
679 | + } |
680 | + } else { |
681 | + |
682 | +/* Form C := alpha*A'*B + beta*C */ |
683 | + |
684 | + i__1 = *n; |
685 | + for (j = 1; j <= i__1; ++j) { |
686 | + i__2 = *m; |
687 | + for (i__ = 1; i__ <= i__2; ++i__) { |
688 | + temp = 0.; |
689 | + i__3 = *k; |
690 | + for (l = 1; l <= i__3; ++l) { |
691 | + temp += a[l + i__ * a_dim1] * b[l + j * b_dim1]; |
692 | +/* L100: */ |
693 | + } |
694 | + if (*beta == 0.) { |
695 | + c__[i__ + j * c_dim1] = *alpha * temp; |
696 | + } else { |
697 | + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ |
698 | + i__ + j * c_dim1]; |
699 | + } |
700 | +/* L110: */ |
701 | + } |
702 | +/* L120: */ |
703 | + } |
704 | + } |
705 | + } else { |
706 | + if (nota) { |
707 | + |
708 | +/* Form C := alpha*A*B' + beta*C */ |
709 | + |
710 | + i__1 = *n; |
711 | + for (j = 1; j <= i__1; ++j) { |
712 | + if (*beta == 0.) { |
713 | + i__2 = *m; |
714 | + for (i__ = 1; i__ <= i__2; ++i__) { |
715 | + c__[i__ + j * c_dim1] = 0.; |
716 | +/* L130: */ |
717 | + } |
718 | + } else if (*beta != 1.) { |
719 | + i__2 = *m; |
720 | + for (i__ = 1; i__ <= i__2; ++i__) { |
721 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; |
722 | +/* L140: */ |
723 | + } |
724 | + } |
725 | + i__2 = *k; |
726 | + for (l = 1; l <= i__2; ++l) { |
727 | + if (b[j + l * b_dim1] != 0.) { |
728 | + temp = *alpha * b[j + l * b_dim1]; |
729 | + i__3 = *m; |
730 | + for (i__ = 1; i__ <= i__3; ++i__) { |
731 | + c__[i__ + j * c_dim1] += temp * a[i__ + l * |
732 | + a_dim1]; |
733 | +/* L150: */ |
734 | + } |
735 | + } |
736 | +/* L160: */ |
737 | + } |
738 | +/* L170: */ |
739 | + } |
740 | + } else { |
741 | + |
742 | +/* Form C := alpha*A'*B' + beta*C */ |
743 | + |
744 | + i__1 = *n; |
745 | + for (j = 1; j <= i__1; ++j) { |
746 | + i__2 = *m; |
747 | + for (i__ = 1; i__ <= i__2; ++i__) { |
748 | + temp = 0.; |
749 | + i__3 = *k; |
750 | + for (l = 1; l <= i__3; ++l) { |
751 | + temp += a[l + i__ * a_dim1] * b[j + l * b_dim1]; |
752 | +/* L180: */ |
753 | + } |
754 | + if (*beta == 0.) { |
755 | + c__[i__ + j * c_dim1] = *alpha * temp; |
756 | + } else { |
757 | + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ |
758 | + i__ + j * c_dim1]; |
759 | + } |
760 | +/* L190: */ |
761 | + } |
762 | +/* L200: */ |
763 | + } |
764 | + } |
765 | + } |
766 | + |
767 | + return 0; |
768 | + |
769 | +/* End of DGEMM . */ |
770 | + |
771 | +} /* dgemm_ */ |
772 | + |
773 | +/* Subroutine */ int dgemv_(char *trans, integer *m, integer *n, doublereal * |
774 | + alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, |
775 | + doublereal *beta, doublereal *y, integer *incy) |
776 | +{ |
777 | + /* System generated locals */ |
778 | + integer a_dim1, a_offset, i__1, i__2; |
779 | + |
780 | + /* Local variables */ |
781 | + static integer info; |
782 | + static doublereal temp; |
783 | + static integer lenx, leny, i__, j; |
784 | + extern logical lsame_(char *, char *); |
785 | + static integer ix, iy, jx, jy, kx, ky; |
786 | + extern /* Subroutine */ int xerbla_(char *, integer *); |
787 | + |
788 | + |
789 | +/* |
790 | + Purpose |
791 | + ======= |
792 | + |
793 | + DGEMV performs one of the matrix-vector operations |
794 | + |
795 | + y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, |
796 | + |
797 | + where alpha and beta are scalars, x and y are vectors and A is an |
798 | + m by n matrix. |
799 | + |
800 | + Arguments |
801 | + ========== |
802 | + |
803 | + TRANS - CHARACTER*1. |
804 | + On entry, TRANS specifies the operation to be performed as |
805 | + follows: |
806 | + |
807 | + TRANS = 'N' or 'n' y := alpha*A*x + beta*y. |
808 | + |
809 | + TRANS = 'T' or 't' y := alpha*A'*x + beta*y. |
810 | + |
811 | + TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. |
812 | + |
813 | + Unchanged on exit. |
814 | + |
815 | + M - INTEGER. |
816 | + On entry, M specifies the number of rows of the matrix A. |
817 | + M must be at least zero. |
818 | + Unchanged on exit. |
819 | + |
820 | + N - INTEGER. |
821 | + On entry, N specifies the number of columns of the matrix A. |
822 | + N must be at least zero. |
823 | + Unchanged on exit. |
824 | + |
825 | + ALPHA - DOUBLE PRECISION. |
826 | + On entry, ALPHA specifies the scalar alpha. |
827 | + Unchanged on exit. |
828 | + |
829 | + A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). |
830 | + Before entry, the leading m by n part of the array A must |
831 | + contain the matrix of coefficients. |
832 | + Unchanged on exit. |
833 | + |
834 | + LDA - INTEGER. |
835 | + On entry, LDA specifies the first dimension of A as declared |
836 | + in the calling (sub) program. LDA must be at least |
837 | + max( 1, m ). |
838 | + Unchanged on exit. |
839 | + |
840 | + X - DOUBLE PRECISION array of DIMENSION at least |
841 | + ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' |
842 | + and at least |
843 | + ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. |
844 | + Before entry, the incremented array X must contain the |
845 | + vector x. |
846 | + Unchanged on exit. |
847 | + |
848 | + INCX - INTEGER. |
849 | + On entry, INCX specifies the increment for the elements of |
850 | + X. INCX must not be zero. |
851 | + Unchanged on exit. |
852 | + |
853 | + BETA - DOUBLE PRECISION. |
854 | + On entry, BETA specifies the scalar beta. When BETA is |
855 | + supplied as zero then Y need not be set on input. |
856 | + Unchanged on exit. |
857 | + |
858 | + Y - DOUBLE PRECISION array of DIMENSION at least |
859 | + ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' |
860 | + and at least |
861 | + ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. |
862 | + Before entry with BETA non-zero, the incremented array Y |
863 | + must contain the vector y. On exit, Y is overwritten by the |
864 | + updated vector y. |
865 | + |
866 | + INCY - INTEGER. |
867 | + On entry, INCY specifies the increment for the elements of |
868 | + Y. INCY must not be zero. |
869 | + Unchanged on exit. |
870 | + |
871 | + |
872 | + Level 2 Blas routine. |
873 | + |
874 | + -- Written on 22-October-1986. |
875 | + Jack Dongarra, Argonne National Lab. |
876 | + Jeremy Du Croz, Nag Central Office. |
877 | + Sven Hammarling, Nag Central Office. |
878 | + Richard Hanson, Sandia National Labs. |
879 | + |
880 | + |
881 | + Test the input parameters. |
882 | +*/ |
883 | + |
884 | + /* Parameter adjustments */ |
885 | + a_dim1 = *lda; |
886 | + a_offset = 1 + a_dim1 * 1; |
887 | + a -= a_offset; |
888 | + --x; |
889 | + --y; |
890 | + |
891 | + /* Function Body */ |
892 | + info = 0; |
893 | + if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") |
894 | + ) { |
895 | + info = 1; |
896 | + } else if (*m < 0) { |
897 | + info = 2; |
898 | + } else if (*n < 0) { |
899 | + info = 3; |
900 | + } else if (*lda < max(1,*m)) { |
901 | + info = 6; |
902 | + } else if (*incx == 0) { |
903 | + info = 8; |
904 | + } else if (*incy == 0) { |
905 | + info = 11; |
906 | + } |
907 | + if (info != 0) { |
908 | + xerbla_("DGEMV ", &info); |
909 | + return 0; |
910 | + } |
911 | + |
912 | +/* Quick return if possible. */ |
913 | + |
914 | + if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { |
915 | + return 0; |
916 | + } |
917 | + |
918 | +/* |
919 | + Set LENX and LENY, the lengths of the vectors x and y, and set |
920 | + up the start points in X and Y. |
921 | +*/ |
922 | + |
923 | + if (lsame_(trans, "N")) { |
924 | + lenx = *n; |
925 | + leny = *m; |
926 | + } else { |
927 | + lenx = *m; |
928 | + leny = *n; |
929 | + } |
930 | + if (*incx > 0) { |
931 | + kx = 1; |
932 | + } else { |
933 | + kx = 1 - (lenx - 1) * *incx; |
934 | + } |
935 | + if (*incy > 0) { |
936 | + ky = 1; |
937 | + } else { |
938 | + ky = 1 - (leny - 1) * *incy; |
939 | + } |
940 | + |
941 | +/* |
942 | + Start the operations. In this version the elements of A are |
943 | + accessed sequentially with one pass through A. |
944 | + |
945 | + First form y := beta*y. |
946 | +*/ |
947 | + |
948 | + if (*beta != 1.) { |
949 | + if (*incy == 1) { |
950 | + if (*beta == 0.) { |
951 | + i__1 = leny; |
952 | + for (i__ = 1; i__ <= i__1; ++i__) { |
953 | + y[i__] = 0.; |
954 | +/* L10: */ |
955 | + } |
956 | + } else { |
957 | + i__1 = leny; |
958 | + for (i__ = 1; i__ <= i__1; ++i__) { |
959 | + y[i__] = *beta * y[i__]; |
960 | +/* L20: */ |
961 | + } |
962 | + } |
963 | + } else { |
964 | + iy = ky; |
965 | + if (*beta == 0.) { |
966 | + i__1 = leny; |
967 | + for (i__ = 1; i__ <= i__1; ++i__) { |
968 | + y[iy] = 0.; |
969 | + iy += *incy; |
970 | +/* L30: */ |
971 | + } |
972 | + } else { |
973 | + i__1 = leny; |
974 | + for (i__ = 1; i__ <= i__1; ++i__) { |
975 | + y[iy] = *beta * y[iy]; |
976 | + iy += *incy; |
977 | +/* L40: */ |
978 | + } |
979 | + } |
980 | + } |
981 | + } |
982 | + if (*alpha == 0.) { |
983 | + return 0; |
984 | + } |
985 | + if (lsame_(trans, "N")) { |
986 | + |
987 | +/* Form y := alpha*A*x + y. */ |
988 | + |
989 | + jx = kx; |
990 | + if (*incy == 1) { |
991 | + i__1 = *n; |
992 | + for (j = 1; j <= i__1; ++j) { |
993 | + if (x[jx] != 0.) { |
994 | + temp = *alpha * x[jx]; |
995 | + i__2 = *m; |
996 | + for (i__ = 1; i__ <= i__2; ++i__) { |
997 | + y[i__] += temp * a[i__ + j * a_dim1]; |
998 | +/* L50: */ |
999 | + } |
1000 | + } |
1001 | + jx += *incx; |
1002 | +/* L60: */ |
1003 | + } |
1004 | + } else { |
1005 | + i__1 = *n; |
1006 | + for (j = 1; j <= i__1; ++j) { |
1007 | + if (x[jx] != 0.) { |
1008 | + temp = *alpha * x[jx]; |
1009 | + iy = ky; |
1010 | + i__2 = *m; |
1011 | + for (i__ = 1; i__ <= i__2; ++i__) { |
1012 | + y[iy] += temp * a[i__ + j * a_dim1]; |
1013 | + iy += *incy; |
1014 | +/* L70: */ |
1015 | + } |
1016 | + } |
1017 | + jx += *incx; |
1018 | +/* L80: */ |
1019 | + } |
1020 | + } |
1021 | + } else { |
1022 | + |
1023 | +/* Form y := alpha*A'*x + y. */ |
1024 | + |
1025 | + jy = ky; |
1026 | + if (*incx == 1) { |
1027 | + i__1 = *n; |
1028 | + for (j = 1; j <= i__1; ++j) { |
1029 | + temp = 0.; |
1030 | + i__2 = *m; |
1031 | + for (i__ = 1; i__ <= i__2; ++i__) { |
1032 | + temp += a[i__ + j * a_dim1] * x[i__]; |
1033 | +/* L90: */ |
1034 | + } |
1035 | + y[jy] += *alpha * temp; |
1036 | + jy += *incy; |
1037 | +/* L100: */ |
1038 | + } |
1039 | + } else { |
1040 | + i__1 = *n; |
1041 | + for (j = 1; j <= i__1; ++j) { |
1042 | + temp = 0.; |
1043 | + ix = kx; |
1044 | + i__2 = *m; |
1045 | + for (i__ = 1; i__ <= i__2; ++i__) { |
1046 | + temp += a[i__ + j * a_dim1] * x[ix]; |
1047 | + ix += *incx; |
1048 | +/* L110: */ |
1049 | + } |
1050 | + y[jy] += *alpha * temp; |
1051 | + jy += *incy; |
1052 | +/* L120: */ |
1053 | + } |
1054 | + } |
1055 | + } |
1056 | + |
1057 | + return 0; |
1058 | + |
1059 | +/* End of DGEMV . */ |
1060 | + |
1061 | +} /* dgemv_ */ |
1062 | + |
1063 | +/* Subroutine */ int dger_(integer *m, integer *n, doublereal *alpha, |
1064 | + doublereal *x, integer *incx, doublereal *y, integer *incy, |
1065 | + doublereal *a, integer *lda) |
1066 | +{ |
1067 | + /* System generated locals */ |
1068 | + integer a_dim1, a_offset, i__1, i__2; |
1069 | + |
1070 | + /* Local variables */ |
1071 | + static integer info; |
1072 | + static doublereal temp; |
1073 | + static integer i__, j, ix, jy, kx; |
1074 | + extern /* Subroutine */ int xerbla_(char *, integer *); |
1075 | + |
1076 | + |
1077 | +/* |
1078 | + Purpose |
1079 | + ======= |
1080 | + |
1081 | + DGER performs the rank 1 operation |
1082 | + |
1083 | + A := alpha*x*y' + A, |
1084 | + |
1085 | + where alpha is a scalar, x is an m element vector, y is an n element |
1086 | + vector and A is an m by n matrix. |
1087 | + |
1088 | + Arguments |
1089 | + ========== |
1090 | + |
1091 | + M - INTEGER. |
1092 | + On entry, M specifies the number of rows of the matrix A. |
1093 | + M must be at least zero. |
1094 | + Unchanged on exit. |
1095 | + |
1096 | + N - INTEGER. |
1097 | + On entry, N specifies the number of columns of the matrix A. |
1098 | + N must be at least zero. |
1099 | + Unchanged on exit. |
1100 | + |
1101 | + ALPHA - DOUBLE PRECISION. |
1102 | + On entry, ALPHA specifies the scalar alpha. |
1103 | + Unchanged on exit. |
1104 | + |
1105 | + X - DOUBLE PRECISION array of dimension at least |
1106 | + ( 1 + ( m - 1 )*abs( INCX ) ). |
1107 | + Before entry, the incremented array X must contain the m |
1108 | + element vector x. |
1109 | + Unchanged on exit. |
1110 | + |
1111 | + INCX - INTEGER. |
1112 | + On entry, INCX specifies the increment for the elements of |
1113 | + X. INCX must not be zero. |
1114 | + Unchanged on exit. |
1115 | + |
1116 | + Y - DOUBLE PRECISION array of dimension at least |
1117 | + ( 1 + ( n - 1 )*abs( INCY ) ). |
1118 | + Before entry, the incremented array Y must contain the n |
1119 | + element vector y. |
1120 | + Unchanged on exit. |
1121 | + |
1122 | + INCY - INTEGER. |
1123 | + On entry, INCY specifies the increment for the elements of |
1124 | + Y. INCY must not be zero. |
1125 | + Unchanged on exit. |
1126 | + |
1127 | + A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). |
1128 | + Before entry, the leading m by n part of the array A must |
1129 | + contain the matrix of coefficients. On exit, A is |
1130 | + overwritten by the updated matrix. |
1131 | + |
1132 | + LDA - INTEGER. |
1133 | + On entry, LDA specifies the first dimension of A as declared |
1134 | + in the calling (sub) program. LDA must be at least |
1135 | + max( 1, m ). |
1136 | + Unchanged on exit. |
1137 | + |
1138 | + |
1139 | + Level 2 Blas routine. |
1140 | + |
1141 | + -- Written on 22-October-1986. |
1142 | + Jack Dongarra, Argonne National Lab. |
1143 | + Jeremy Du Croz, Nag Central Office. |
1144 | + Sven Hammarling, Nag Central Office. |
1145 | + Richard Hanson, Sandia National Labs. |
1146 | + |
1147 | + |
1148 | + Test the input parameters. |
1149 | +*/ |
1150 | + |
1151 | + /* Parameter adjustments */ |
1152 | + --x; |
1153 | + --y; |
1154 | + a_dim1 = *lda; |
1155 | + a_offset = 1 + a_dim1 * 1; |
1156 | + a -= a_offset; |
1157 | + |
1158 | + /* Function Body */ |
1159 | + info = 0; |
1160 | + if (*m < 0) { |
1161 | + info = 1; |
1162 | + } else if (*n < 0) { |
1163 | + info = 2; |
1164 | + } else if (*incx == 0) { |
1165 | + info = 5; |
1166 | + } else if (*incy == 0) { |
1167 | + info = 7; |
1168 | + } else if (*lda < max(1,*m)) { |
1169 | + info = 9; |
1170 | + } |
1171 | + if (info != 0) { |
1172 | + xerbla_("DGER ", &info); |
1173 | + return 0; |
1174 | + } |
1175 | + |
1176 | +/* Quick return if possible. */ |
1177 | + |
1178 | + if (*m == 0 || *n == 0 || *alpha == 0.) { |
1179 | + return 0; |
1180 | + } |
1181 | + |
1182 | +/* |
1183 | + Start the operations. In this version the elements of A are |
1184 | + accessed sequentially with one pass through A. |
1185 | +*/ |
1186 | + |
1187 | + if (*incy > 0) { |
1188 | + jy = 1; |
1189 | + } else { |
1190 | + jy = 1 - (*n - 1) * *incy; |
1191 | + } |
1192 | + if (*incx == 1) { |
1193 | + i__1 = *n; |
1194 | + for (j = 1; j <= i__1; ++j) { |
1195 | + if (y[jy] != 0.) { |
1196 | + temp = *alpha * y[jy]; |
1197 | + i__2 = *m; |
1198 | + for (i__ = 1; i__ <= i__2; ++i__) { |
1199 | + a[i__ + j * a_dim1] += x[i__] * temp; |
1200 | +/* L10: */ |
1201 | + } |
1202 | + } |
1203 | + jy += *incy; |
1204 | +/* L20: */ |
1205 | + } |
1206 | + } else { |
1207 | + if (*incx > 0) { |
1208 | + kx = 1; |
1209 | + } else { |
1210 | + kx = 1 - (*m - 1) * *incx; |
1211 | + } |
1212 | + i__1 = *n; |
1213 | + for (j = 1; j <= i__1; ++j) { |
1214 | + if (y[jy] != 0.) { |
1215 | + temp = *alpha * y[jy]; |
1216 | + ix = kx; |
1217 | + i__2 = *m; |
1218 | + for (i__ = 1; i__ <= i__2; ++i__) { |
1219 | + a[i__ + j * a_dim1] += x[ix] * temp; |
1220 | + ix += *incx; |
1221 | +/* L30: */ |
1222 | + } |
1223 | + } |
1224 | + jy += *incy; |
1225 | +/* L40: */ |
1226 | + } |
1227 | + } |
1228 | + |
1229 | + return 0; |
1230 | + |
1231 | +/* End of DGER . */ |
1232 | + |
1233 | +} /* dger_ */ |
1234 | + |
1235 | +doublereal dnrm2_(integer *n, doublereal *x, integer *incx) |
1236 | +{ |
1237 | + /* System generated locals */ |
1238 | + integer i__1, i__2; |
1239 | + doublereal ret_val, d__1; |
1240 | + |
1241 | + /* Builtin functions */ |
1242 | + double sqrt(doublereal); |
1243 | + |
1244 | + /* Local variables */ |
1245 | + static doublereal norm, scale, absxi; |
1246 | + static integer ix; |
1247 | + static doublereal ssq; |
1248 | + |
1249 | + |
1250 | +/* |
1251 | + Purpose |
1252 | + ======= |
1253 | + |
1254 | + DNRM2 returns the euclidean norm of a vector via the function |
1255 | + name, so that |
1256 | + |
1257 | + DNRM2 := sqrt( x'*x ) |
1258 | + |
1259 | + |
1260 | + -- This version written on 25-October-1982. |
1261 | + Modified on 14-October-1993 to inline the call to DLASSQ. |
1262 | + Sven Hammarling, Nag Ltd. |
1263 | +*/ |
1264 | + |
1265 | + |
1266 | + /* Parameter adjustments */ |
1267 | + --x; |
1268 | + |
1269 | + /* Function Body */ |
1270 | + if (*n < 1 || *incx < 1) { |
1271 | + norm = 0.; |
1272 | + } else if (*n == 1) { |
1273 | + norm = abs(x[1]); |
1274 | + } else { |
1275 | + scale = 0.; |
1276 | + ssq = 1.; |
1277 | +/* |
1278 | + The following loop is equivalent to this call to the LAPACK |
1279 | + auxiliary routine: |
1280 | + CALL DLASSQ( N, X, INCX, SCALE, SSQ ) |
1281 | +*/ |
1282 | + |
1283 | + i__1 = (*n - 1) * *incx + 1; |
1284 | + i__2 = *incx; |
1285 | + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { |
1286 | + if (x[ix] != 0.) { |
1287 | + absxi = (d__1 = x[ix], abs(d__1)); |
1288 | + if (scale < absxi) { |
1289 | +/* Computing 2nd power */ |
1290 | + d__1 = scale / absxi; |
1291 | + ssq = ssq * (d__1 * d__1) + 1.; |
1292 | + scale = absxi; |
1293 | + } else { |
1294 | +/* Computing 2nd power */ |
1295 | + d__1 = absxi / scale; |
1296 | + ssq += d__1 * d__1; |
1297 | + } |
1298 | + } |
1299 | +/* L10: */ |
1300 | + } |
1301 | + norm = scale * sqrt(ssq); |
1302 | + } |
1303 | + |
1304 | + ret_val = norm; |
1305 | + return ret_val; |
1306 | + |
1307 | +/* End of DNRM2. */ |
1308 | + |
1309 | +} /* dnrm2_ */ |
1310 | + |
1311 | +/* Subroutine */ int drot_(integer *n, doublereal *dx, integer *incx, |
1312 | + doublereal *dy, integer *incy, doublereal *c__, doublereal *s) |
1313 | +{ |
1314 | + /* System generated locals */ |
1315 | + integer i__1; |
1316 | + |
1317 | + /* Local variables */ |
1318 | + static integer i__; |
1319 | + static doublereal dtemp; |
1320 | + static integer ix, iy; |
1321 | + |
1322 | + |
1323 | +/* |
1324 | + Purpose |
1325 | + ======= |
1326 | + |
1327 | + applies a plane rotation. |
1328 | + jack dongarra, linpack, 3/11/78. |
1329 | + modified 12/3/93, array(1) declarations changed to array(*) |
1330 | +*/ |
1331 | + |
1332 | + |
1333 | + /* Parameter adjustments */ |
1334 | + --dy; |
1335 | + --dx; |
1336 | + |
1337 | + /* Function Body */ |
1338 | + if (*n <= 0) { |
1339 | + return 0; |
1340 | + } |
1341 | + if (*incx == 1 && *incy == 1) { |
1342 | + goto L20; |
1343 | + } |
1344 | + |
1345 | +/* |
1346 | + code for unequal increments or equal increments not equal |
1347 | + to 1 |
1348 | +*/ |
1349 | + |
1350 | + ix = 1; |
1351 | + iy = 1; |
1352 | + if (*incx < 0) { |
1353 | + ix = (-(*n) + 1) * *incx + 1; |
1354 | + } |
1355 | + if (*incy < 0) { |
1356 | + iy = (-(*n) + 1) * *incy + 1; |
1357 | + } |
1358 | + i__1 = *n; |
1359 | + for (i__ = 1; i__ <= i__1; ++i__) { |
1360 | + dtemp = *c__ * dx[ix] + *s * dy[iy]; |
1361 | + dy[iy] = *c__ * dy[iy] - *s * dx[ix]; |
1362 | + dx[ix] = dtemp; |
1363 | + ix += *incx; |
1364 | + iy += *incy; |
1365 | +/* L10: */ |
1366 | + } |
1367 | + return 0; |
1368 | + |
1369 | +/* code for both increments equal to 1 */ |
1370 | + |
1371 | +L20: |
1372 | + i__1 = *n; |
1373 | + for (i__ = 1; i__ <= i__1; ++i__) { |
1374 | + dtemp = *c__ * dx[i__] + *s * dy[i__]; |
1375 | + dy[i__] = *c__ * dy[i__] - *s * dx[i__]; |
1376 | + dx[i__] = dtemp; |
1377 | +/* L30: */ |
1378 | + } |
1379 | + return 0; |
1380 | +} /* drot_ */ |
1381 | + |
1382 | +/* Subroutine */ int drotg_(doublereal *da, doublereal *db, doublereal *c__, |
1383 | + doublereal *s) |
1384 | +{ |
1385 | + /* System generated locals */ |
1386 | + doublereal d__1, d__2; |
1387 | + |
1388 | + /* Builtin functions */ |
1389 | + double sqrt(doublereal), d_sign(doublereal *, doublereal *); |
1390 | + |
1391 | + /* Local variables */ |
1392 | + static doublereal r__, scale, z__, roe; |
1393 | + |
1394 | + |
1395 | +/* |
1396 | + Purpose |
1397 | + ======= |
1398 | + |
1399 | + construct givens plane rotation. |
1400 | + jack dongarra, linpack, 3/11/78. |
1401 | +*/ |
1402 | + |
1403 | + |
1404 | + roe = *db; |
1405 | + if (abs(*da) > abs(*db)) { |
1406 | + roe = *da; |
1407 | + } |
1408 | + scale = abs(*da) + abs(*db); |
1409 | + if (scale != 0.) { |
1410 | + goto L10; |
1411 | + } |
1412 | + *c__ = 1.; |
1413 | + *s = 0.; |
1414 | + r__ = 0.; |
1415 | + z__ = 0.; |
1416 | + goto L20; |
1417 | +L10: |
1418 | +/* Computing 2nd power */ |
1419 | + d__1 = *da / scale; |
1420 | +/* Computing 2nd power */ |
1421 | + d__2 = *db / scale; |
1422 | + r__ = scale * sqrt(d__1 * d__1 + d__2 * d__2); |
1423 | + r__ = d_sign(&c_b90, &roe) * r__; |
1424 | + *c__ = *da / r__; |
1425 | + *s = *db / r__; |
1426 | + z__ = 1.; |
1427 | + if (abs(*da) > abs(*db)) { |
1428 | + z__ = *s; |
1429 | + } |
1430 | + if (abs(*db) >= abs(*da) && *c__ != 0.) { |
1431 | + z__ = 1. / *c__; |
1432 | + } |
1433 | +L20: |
1434 | + *da = r__; |
1435 | + *db = z__; |
1436 | + return 0; |
1437 | +} /* drotg_ */ |
1438 | + |
1439 | +/* Subroutine */ int drotm_(integer *n, doublereal *dx, integer *incx, |
1440 | + doublereal *dy, integer *incy, doublereal *dparam) |
1441 | +{ |
1442 | + /* Initialized data */ |
1443 | + |
1444 | + static doublereal zero = 0.; |
1445 | + static doublereal two = 2.; |
1446 | + |
1447 | + /* System generated locals */ |
1448 | + integer i__1, i__2; |
1449 | + |
1450 | + /* Local variables */ |
1451 | + static integer i__; |
1452 | + static doublereal dflag, w, z__; |
1453 | + static integer kx, ky, nsteps; |
1454 | + static doublereal dh11, dh12, dh21, dh22; |
1455 | + |
1456 | + |
1457 | +/* |
1458 | + Purpose |
1459 | + ======= |
1460 | + |
1461 | + APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX |
1462 | + |
1463 | + (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN |
1464 | + (DY**T) |
1465 | + |
1466 | + DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE |
1467 | + LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. |
1468 | + WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. |
1469 | + |
1470 | + DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 |
1471 | + |
1472 | + (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) |
1473 | + H=( ) ( ) ( ) ( ) |
1474 | + (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). |
1475 | + SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. |
1476 | + |
1477 | + Arguments |
1478 | + ========= |
1479 | + |
1480 | + N (input) INTEGER |
1481 | + number of elements in input vector(s) |
1482 | + |
1483 | + DX (input/output) DOUBLE PRECISION array, dimension N |
1484 | + double precision vector with 5 elements |
1485 | + |
1486 | + INCX (input) INTEGER |
1487 | + storage spacing between elements of DX |
1488 | + |
1489 | + DY (input/output) DOUBLE PRECISION array, dimension N |
1490 | + double precision vector with N elements |
1491 | + |
1492 | + INCY (input) INTEGER |
1493 | + storage spacing between elements of DY |
1494 | + |
1495 | + DPARAM (input/output) DOUBLE PRECISION array, dimension 5 |
1496 | + DPARAM(1)=DFLAG |
1497 | + DPARAM(2)=DH11 |
1498 | + DPARAM(3)=DH21 |
1499 | + DPARAM(4)=DH12 |
1500 | + DPARAM(5)=DH22 |
1501 | + |
1502 | + ===================================================================== |
1503 | +*/ |
1504 | + |
1505 | + /* Parameter adjustments */ |
1506 | + --dparam; |
1507 | + --dy; |
1508 | + --dx; |
1509 | + |
1510 | + /* Function Body */ |
1511 | + |
1512 | + dflag = dparam[1]; |
1513 | + if (*n <= 0 || dflag + two == zero) { |
1514 | + goto L140; |
1515 | + } |
1516 | + if (! (*incx == *incy && *incx > 0)) { |
1517 | + goto L70; |
1518 | + } |
1519 | + |
1520 | + nsteps = *n * *incx; |
1521 | + if (dflag < 0.) { |
1522 | + goto L50; |
1523 | + } else if (dflag == 0) { |
1524 | + goto L10; |
1525 | + } else { |
1526 | + goto L30; |
1527 | + } |
1528 | +L10: |
1529 | + dh12 = dparam[4]; |
1530 | + dh21 = dparam[3]; |
1531 | + i__1 = nsteps; |
1532 | + i__2 = *incx; |
1533 | + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { |
1534 | + w = dx[i__]; |
1535 | + z__ = dy[i__]; |
1536 | + dx[i__] = w + z__ * dh12; |
1537 | + dy[i__] = w * dh21 + z__; |
1538 | +/* L20: */ |
1539 | + } |
1540 | + goto L140; |
1541 | +L30: |
1542 | + dh11 = dparam[2]; |
1543 | + dh22 = dparam[5]; |
1544 | + i__2 = nsteps; |
1545 | + i__1 = *incx; |
1546 | + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { |
1547 | + w = dx[i__]; |
1548 | + z__ = dy[i__]; |
1549 | + dx[i__] = w * dh11 + z__; |
1550 | + dy[i__] = -w + dh22 * z__; |
1551 | +/* L40: */ |
1552 | + } |
1553 | + goto L140; |
1554 | +L50: |
1555 | + dh11 = dparam[2]; |
1556 | + dh12 = dparam[4]; |
1557 | + dh21 = dparam[3]; |
1558 | + dh22 = dparam[5]; |
1559 | + i__1 = nsteps; |
1560 | + i__2 = *incx; |
1561 | + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { |
1562 | + w = dx[i__]; |
1563 | + z__ = dy[i__]; |
1564 | + dx[i__] = w * dh11 + z__ * dh12; |
1565 | + dy[i__] = w * dh21 + z__ * dh22; |
1566 | +/* L60: */ |
1567 | + } |
1568 | + goto L140; |
1569 | +L70: |
1570 | + kx = 1; |
1571 | + ky = 1; |
1572 | + if (*incx < 0) { |
1573 | + kx = (1 - *n) * *incx + 1; |
1574 | + } |
1575 | + if (*incy < 0) { |
1576 | + ky = (1 - *n) * *incy + 1; |
1577 | + } |
1578 | + |
1579 | + if (dflag < 0.) { |
1580 | + goto L120; |
1581 | + } else if (dflag == 0) { |
1582 | + goto L80; |
1583 | + } else { |
1584 | + goto L100; |
1585 | + } |
1586 | +L80: |
1587 | + dh12 = dparam[4]; |
1588 | + dh21 = dparam[3]; |
1589 | + i__2 = *n; |
1590 | + for (i__ = 1; i__ <= i__2; ++i__) { |
1591 | + w = dx[kx]; |
1592 | + z__ = dy[ky]; |
1593 | + dx[kx] = w + z__ * dh12; |
1594 | + dy[ky] = w * dh21 + z__; |
1595 | + kx += *incx; |
1596 | + ky += *incy; |
1597 | +/* L90: */ |
1598 | + } |
1599 | + goto L140; |
1600 | +L100: |
1601 | + dh11 = dparam[2]; |
1602 | + dh22 = dparam[5]; |
1603 | + i__2 = *n; |
1604 | + for (i__ = 1; i__ <= i__2; ++i__) { |
1605 | + w = dx[kx]; |
1606 | + z__ = dy[ky]; |
1607 | + dx[kx] = w * dh11 + z__; |
1608 | + dy[ky] = -w + dh22 * z__; |
1609 | + kx += *incx; |
1610 | + ky += *incy; |
1611 | +/* L110: */ |
1612 | + } |
1613 | + goto L140; |
1614 | +L120: |
1615 | + dh11 = dparam[2]; |
1616 | + dh12 = dparam[4]; |
1617 | + dh21 = dparam[3]; |
1618 | + dh22 = dparam[5]; |
1619 | + i__2 = *n; |
1620 | + for (i__ = 1; i__ <= i__2; ++i__) { |
1621 | + w = dx[kx]; |
1622 | + z__ = dy[ky]; |
1623 | + dx[kx] = w * dh11 + z__ * dh12; |
1624 | + dy[ky] = w * dh21 + z__ * dh22; |
1625 | + kx += *incx; |
1626 | + ky += *incy; |
1627 | +/* L130: */ |
1628 | + } |
1629 | +L140: |
1630 | + return 0; |
1631 | +} /* drotm_ */ |
1632 | + |
1633 | +/* Subroutine */ int drotmg_(doublereal *dd1, doublereal *dd2, doublereal * |
1634 | + dx1, doublereal *dy1, doublereal *dparam) |
1635 | +{ |
1636 | + /* Initialized data */ |
1637 | + |
1638 | + static doublereal zero = 0.; |
1639 | + static doublereal one = 1.; |
1640 | + static doublereal two = 2.; |
1641 | + static doublereal gam = 4096.; |
1642 | + static doublereal gamsq = 16777216.; |
1643 | + static doublereal rgamsq = 5.9604645e-8; |
1644 | + |
1645 | + /* Format strings */ |
1646 | + static char fmt_120[] = ""; |
1647 | + static char fmt_150[] = ""; |
1648 | + static char fmt_180[] = ""; |
1649 | + static char fmt_210[] = ""; |
1650 | + |
1651 | + /* System generated locals */ |
1652 | + doublereal d__1; |
1653 | + |
1654 | + /* Local variables */ |
1655 | + static doublereal dflag, dtemp, du, dp1, dp2, dq1, dq2, dh11, dh12, dh21, |
1656 | + dh22; |
1657 | + static integer igo; |
1658 | + |
1659 | + /* Assigned format variables */ |
1660 | + static char *igo_fmt; |
1661 | + |
1662 | + |
1663 | +/* |
1664 | + Purpose |
1665 | + ======= |
1666 | + |
1667 | + CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS |
1668 | + THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* |
1669 | + DY2)**T. |
1670 | + WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. |
1671 | + |
1672 | + DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 |
1673 | + |
1674 | + (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) |
1675 | + H=( ) ( ) ( ) ( ) |
1676 | + (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). |
1677 | + LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 |
1678 | + RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE |
1679 | + VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) |
1680 | + |
1681 | + THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE |
1682 | + INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE |
1683 | + OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. |
1684 | + |
1685 | + |
1686 | + Arguments |
1687 | + ========= |
1688 | + |
1689 | + DD1 (input/output) DOUBLE PRECISION |
1690 | + |
1691 | + DD2 (input/output) DOUBLE PRECISION |
1692 | + |
1693 | + DX1 (input/output) DOUBLE PRECISION |
1694 | + |
1695 | + DY1 (input) DOUBLE PRECISION |
1696 | + |
1697 | + DPARAM (input/output) DOUBLE PRECISION array, dimension 5 |
1698 | + DPARAM(1)=DFLAG |
1699 | + DPARAM(2)=DH11 |
1700 | + DPARAM(3)=DH21 |
1701 | + DPARAM(4)=DH12 |
1702 | + DPARAM(5)=DH22 |
1703 | + |
1704 | + ===================================================================== |
1705 | +*/ |
1706 | + |
1707 | + |
1708 | + /* Parameter adjustments */ |
1709 | + --dparam; |
1710 | + |
1711 | + /* Function Body */ |
1712 | + if (! (*dd1 < zero)) { |
1713 | + goto L10; |
1714 | + } |
1715 | +/* GO ZERO-H-D-AND-DX1.. */ |
1716 | + goto L60; |
1717 | +L10: |
1718 | +/* CASE-DD1-NONNEGATIVE */ |
1719 | + dp2 = *dd2 * *dy1; |
1720 | + if (! (dp2 == zero)) { |
1721 | + goto L20; |
1722 | + } |
1723 | + dflag = -two; |
1724 | + goto L260; |
1725 | +/* REGULAR-CASE.. */ |
1726 | +L20: |
1727 | + dp1 = *dd1 * *dx1; |
1728 | + dq2 = dp2 * *dy1; |
1729 | + dq1 = dp1 * *dx1; |
1730 | + |
1731 | + if (! (abs(dq1) > abs(dq2))) { |
1732 | + goto L40; |
1733 | + } |
1734 | + dh21 = -(*dy1) / *dx1; |
1735 | + dh12 = dp2 / dp1; |
1736 | + |
1737 | + du = one - dh12 * dh21; |
1738 | + |
1739 | + if (! (du <= zero)) { |
1740 | + goto L30; |
1741 | + } |
1742 | +/* GO ZERO-H-D-AND-DX1.. */ |
1743 | + goto L60; |
1744 | +L30: |
1745 | + dflag = zero; |
1746 | + *dd1 /= du; |
1747 | + *dd2 /= du; |
1748 | + *dx1 *= du; |
1749 | +/* GO SCALE-CHECK.. */ |
1750 | + goto L100; |
1751 | +L40: |
1752 | + if (! (dq2 < zero)) { |
1753 | + goto L50; |
1754 | + } |
1755 | +/* GO ZERO-H-D-AND-DX1.. */ |
1756 | + goto L60; |
1757 | +L50: |
1758 | + dflag = one; |
1759 | + dh11 = dp1 / dp2; |
1760 | + dh22 = *dx1 / *dy1; |
1761 | + du = one + dh11 * dh22; |
1762 | + dtemp = *dd2 / du; |
1763 | + *dd2 = *dd1 / du; |
1764 | + *dd1 = dtemp; |
1765 | + *dx1 = *dy1 * du; |
1766 | +/* GO SCALE-CHECK */ |
1767 | + goto L100; |
1768 | +/* PROCEDURE..ZERO-H-D-AND-DX1.. */ |
1769 | +L60: |
1770 | + dflag = -one; |
1771 | + dh11 = zero; |
1772 | + dh12 = zero; |
1773 | + dh21 = zero; |
1774 | + dh22 = zero; |
1775 | + |
1776 | + *dd1 = zero; |
1777 | + *dd2 = zero; |
1778 | + *dx1 = zero; |
1779 | +/* RETURN.. */ |
1780 | + goto L220; |
1781 | +/* PROCEDURE..FIX-H.. */ |
1782 | +L70: |
1783 | + if (! (dflag >= zero)) { |
1784 | + goto L90; |
1785 | + } |
1786 | + |
1787 | + if (! (dflag == zero)) { |
1788 | + goto L80; |
1789 | + } |
1790 | + dh11 = one; |
1791 | + dh22 = one; |
1792 | + dflag = -one; |
1793 | + goto L90; |
1794 | +L80: |
1795 | + dh21 = -one; |
1796 | + dh12 = one; |
1797 | + dflag = -one; |
1798 | +L90: |
1799 | + switch (igo) { |
1800 | + case 0: goto L120; |
1801 | + case 1: goto L150; |
1802 | + case 2: goto L180; |
1803 | + case 3: goto L210; |
1804 | + } |
1805 | +/* PROCEDURE..SCALE-CHECK */ |
1806 | +L100: |
1807 | +L110: |
1808 | + if (! (*dd1 <= rgamsq)) { |
1809 | + goto L130; |
1810 | + } |
1811 | + if (*dd1 == zero) { |
1812 | + goto L160; |
1813 | + } |
1814 | + igo = 0; |
1815 | + igo_fmt = fmt_120; |
1816 | +/* FIX-H.. */ |
1817 | + goto L70; |
1818 | +L120: |
1819 | +/* Computing 2nd power */ |
1820 | + d__1 = gam; |
1821 | + *dd1 *= d__1 * d__1; |
1822 | + *dx1 /= gam; |
1823 | + dh11 /= gam; |
1824 | + dh12 /= gam; |
1825 | + goto L110; |
1826 | +L130: |
1827 | +L140: |
1828 | + if (! (*dd1 >= gamsq)) { |
1829 | + goto L160; |
1830 | + } |
1831 | + igo = 1; |
1832 | + igo_fmt = fmt_150; |
1833 | +/* FIX-H.. */ |
1834 | + goto L70; |
1835 | +L150: |
1836 | +/* Computing 2nd power */ |
1837 | + d__1 = gam; |
1838 | + *dd1 /= d__1 * d__1; |
1839 | + *dx1 *= gam; |
1840 | + dh11 *= gam; |
1841 | + dh12 *= gam; |
1842 | + goto L140; |
1843 | +L160: |
1844 | +L170: |
1845 | + if (! (abs(*dd2) <= rgamsq)) { |
1846 | + goto L190; |
1847 | + } |
1848 | + if (*dd2 == zero) { |
1849 | + goto L220; |
1850 | + } |
1851 | + igo = 2; |
1852 | + igo_fmt = fmt_180; |
1853 | +/* FIX-H.. */ |
1854 | + goto L70; |
1855 | +L180: |
1856 | +/* Computing 2nd power */ |
1857 | + d__1 = gam; |
1858 | + *dd2 *= d__1 * d__1; |
1859 | + dh21 /= gam; |
1860 | + dh22 /= gam; |
1861 | + goto L170; |
1862 | +L190: |
1863 | +L200: |
1864 | + if (! (abs(*dd2) >= gamsq)) { |
1865 | + goto L220; |
1866 | + } |
1867 | + igo = 3; |
1868 | + igo_fmt = fmt_210; |
1869 | +/* FIX-H.. */ |
1870 | + goto L70; |
1871 | +L210: |
1872 | +/* Computing 2nd power */ |
1873 | + d__1 = gam; |
1874 | + *dd2 /= d__1 * d__1; |
1875 | + dh21 *= gam; |
1876 | + dh22 *= gam; |
1877 | + goto L200; |
1878 | +L220: |
1879 | + if (dflag < 0.) { |
1880 | + goto L250; |
1881 | + } else if (dflag == 0) { |
1882 | + goto L230; |
1883 | + } else { |
1884 | + goto L240; |
1885 | + } |
1886 | +L230: |
1887 | + dparam[3] = dh21; |
1888 | + dparam[4] = dh12; |
1889 | + goto L260; |
1890 | +L240: |
1891 | + dparam[2] = dh11; |
1892 | + dparam[5] = dh22; |
1893 | + goto L260; |
1894 | +L250: |
1895 | + dparam[2] = dh11; |
1896 | + dparam[3] = dh21; |
1897 | + dparam[4] = dh12; |
1898 | + dparam[5] = dh22; |
1899 | +L260: |
1900 | + dparam[1] = dflag; |
1901 | + return 0; |
1902 | +} /* drotmg_ */ |
1903 | + |
1904 | +/* Subroutine */ int dscal_(integer *n, doublereal *da, doublereal *dx, |
1905 | + integer *incx) |
1906 | +{ |
1907 | + /* System generated locals */ |
1908 | + integer i__1, i__2; |
1909 | + |
1910 | + /* Local variables */ |
1911 | + static integer i__, m, nincx, mp1; |
1912 | + |
1913 | + |
1914 | +/* |
1915 | + Purpose |
1916 | + ======= |
1917 | + * |
1918 | + scales a vector by a constant. |
1919 | + uses unrolled loops for increment equal to one. |
1920 | + jack dongarra, linpack, 3/11/78. |
1921 | + modified 3/93 to return if incx .le. 0. |
1922 | + modified 12/3/93, array(1) declarations changed to array(*) |
1923 | +*/ |
1924 | + |
1925 | + |
1926 | + /* Parameter adjustments */ |
1927 | + --dx; |
1928 | + |
1929 | + /* Function Body */ |
1930 | + if (*n <= 0 || *incx <= 0) { |
1931 | + return 0; |
1932 | + } |
1933 | + if (*incx == 1) { |
1934 | + goto L20; |
1935 | + } |
1936 | + |
1937 | +/* code for increment not equal to 1 */ |
1938 | + |
1939 | + nincx = *n * *incx; |
1940 | + i__1 = nincx; |
1941 | + i__2 = *incx; |
1942 | + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { |
1943 | + dx[i__] = *da * dx[i__]; |
1944 | +/* L10: */ |
1945 | + } |
1946 | + return 0; |
1947 | + |
1948 | +/* |
1949 | + code for increment equal to 1 |
1950 | + |
1951 | + |
1952 | + clean-up loop |
1953 | +*/ |
1954 | + |
1955 | +L20: |
1956 | + m = *n % 5; |
1957 | + if (m == 0) { |
1958 | + goto L40; |
1959 | + } |
1960 | + i__2 = m; |
1961 | + for (i__ = 1; i__ <= i__2; ++i__) { |
1962 | + dx[i__] = *da * dx[i__]; |
1963 | +/* L30: */ |
1964 | + } |
1965 | + if (*n < 5) { |
1966 | + return 0; |
1967 | + } |
1968 | +L40: |
1969 | + mp1 = m + 1; |
1970 | + i__2 = *n; |
1971 | + for (i__ = mp1; i__ <= i__2; i__ += 5) { |
1972 | + dx[i__] = *da * dx[i__]; |
1973 | + dx[i__ + 1] = *da * dx[i__ + 1]; |
1974 | + dx[i__ + 2] = *da * dx[i__ + 2]; |
1975 | + dx[i__ + 3] = *da * dx[i__ + 3]; |
1976 | + dx[i__ + 4] = *da * dx[i__ + 4]; |
1977 | +/* L50: */ |
1978 | + } |
1979 | + return 0; |
1980 | +} /* dscal_ */ |
1981 | + |
1982 | +/* Subroutine */ int dswap_(integer *n, doublereal *dx, integer *incx, |
1983 | + doublereal *dy, integer *incy) |
1984 | +{ |
1985 | + /* System generated locals */ |
1986 | + integer i__1; |
1987 | + |
1988 | + /* Local variables */ |
1989 | + static integer i__, m; |
1990 | + static doublereal dtemp; |
1991 | + static integer ix, iy, mp1; |
1992 | + |
1993 | + |
1994 | +/* |
1995 | + Purpose |
1996 | + ======= |
1997 | + |
1998 | + interchanges two vectors. |
1999 | + uses unrolled loops for increments equal one. |
2000 | + jack dongarra, linpack, 3/11/78. |
2001 | + modified 12/3/93, array(1) declarations changed to array(*) |
2002 | +*/ |
2003 | + |
2004 | + |
2005 | + /* Parameter adjustments */ |
2006 | + --dy; |
2007 | + --dx; |
2008 | + |
2009 | + /* Function Body */ |
2010 | + if (*n <= 0) { |
2011 | + return 0; |
2012 | + } |
2013 | + if (*incx == 1 && *incy == 1) { |
2014 | + goto L20; |
2015 | + } |
2016 | + |
2017 | +/* |
2018 | + code for unequal increments or equal increments not equal |
2019 | + to 1 |
2020 | +*/ |
2021 | + |
2022 | + ix = 1; |
2023 | + iy = 1; |
2024 | + if (*incx < 0) { |
2025 | + ix = (-(*n) + 1) * *incx + 1; |
2026 | + } |
2027 | + if (*incy < 0) { |
2028 | + iy = (-(*n) + 1) * *incy + 1; |
2029 | + } |
2030 | + i__1 = *n; |
2031 | + for (i__ = 1; i__ <= i__1; ++i__) { |
2032 | + dtemp = dx[ix]; |
2033 | + dx[ix] = dy[iy]; |
2034 | + dy[iy] = dtemp; |
2035 | + ix += *incx; |
2036 | + iy += *incy; |
2037 | +/* L10: */ |
2038 | + } |
2039 | + return 0; |
2040 | + |
2041 | +/* |
2042 | + code for both increments equal to 1 |
2043 | + |
2044 | + |
2045 | + clean-up loop |
2046 | +*/ |
2047 | + |
2048 | +L20: |
2049 | + m = *n % 3; |
2050 | + if (m == 0) { |
2051 | + goto L40; |
2052 | + } |
2053 | + i__1 = m; |
2054 | + for (i__ = 1; i__ <= i__1; ++i__) { |
2055 | + dtemp = dx[i__]; |
2056 | + dx[i__] = dy[i__]; |
2057 | + dy[i__] = dtemp; |
2058 | +/* L30: */ |
2059 | + } |
2060 | + if (*n < 3) { |
2061 | + return 0; |
2062 | + } |
2063 | +L40: |
2064 | + mp1 = m + 1; |
2065 | + i__1 = *n; |
2066 | + for (i__ = mp1; i__ <= i__1; i__ += 3) { |
2067 | + dtemp = dx[i__]; |
2068 | + dx[i__] = dy[i__]; |
2069 | + dy[i__] = dtemp; |
2070 | + dtemp = dx[i__ + 1]; |
2071 | + dx[i__ + 1] = dy[i__ + 1]; |
2072 | + dy[i__ + 1] = dtemp; |
2073 | + dtemp = dx[i__ + 2]; |
2074 | + dx[i__ + 2] = dy[i__ + 2]; |
2075 | + dy[i__ + 2] = dtemp; |
2076 | +/* L50: */ |
2077 | + } |
2078 | + return 0; |
2079 | +} /* dswap_ */ |
2080 | + |
2081 | +/* Subroutine */ int dsymm_(char *side, char *uplo, integer *m, integer *n, |
2082 | + doublereal *alpha, doublereal *a, integer *lda, doublereal *b, |
2083 | + integer *ldb, doublereal *beta, doublereal *c__, integer *ldc) |
2084 | +{ |
2085 | + /* System generated locals */ |
2086 | + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, |
2087 | + i__3; |
2088 | + |
2089 | + /* Local variables */ |
2090 | + static integer info; |
2091 | + static doublereal temp1, temp2; |
2092 | + static integer i__, j, k; |
2093 | + extern logical lsame_(char *, char *); |
2094 | + static integer nrowa; |
2095 | + static logical upper; |
2096 | + extern /* Subroutine */ int xerbla_(char *, integer *); |
2097 | + |
2098 | + |
2099 | +/* |
2100 | + Purpose |
2101 | + ======= |
2102 | + |
2103 | + DSYMM performs one of the matrix-matrix operations |
2104 | + |
2105 | + C := alpha*A*B + beta*C, |
2106 | + |
2107 | + or |
2108 | + |
2109 | + C := alpha*B*A + beta*C, |
2110 | + |
2111 | + where alpha and beta are scalars, A is a symmetric matrix and B and |
2112 | + C are m by n matrices. |
2113 | + |
2114 | + Arguments |
2115 | + ========== |
2116 | + |
2117 | + SIDE - CHARACTER*1. |
2118 | + On entry, SIDE specifies whether the symmetric matrix A |
2119 | + appears on the left or right in the operation as follows: |
2120 | + |
2121 | + SIDE = 'L' or 'l' C := alpha*A*B + beta*C, |
2122 | + |
2123 | + SIDE = 'R' or 'r' C := alpha*B*A + beta*C, |
2124 | + |
2125 | + Unchanged on exit. |
2126 | + |
2127 | + UPLO - CHARACTER*1. |
2128 | + On entry, UPLO specifies whether the upper or lower |
2129 | + triangular part of the symmetric matrix A is to be |
2130 | + referenced as follows: |
2131 | + |
2132 | + UPLO = 'U' or 'u' Only the upper triangular part of the |
2133 | + symmetric matrix is to be referenced. |
2134 | + |
2135 | + UPLO = 'L' or 'l' Only the lower triangular part of the |
2136 | + symmetric matrix is to be referenced. |
2137 | + |
2138 | + Unchanged on exit. |
2139 | + |
2140 | + M - INTEGER. |
2141 | + On entry, M specifies the number of rows of the matrix C. |
2142 | + M must be at least zero. |
2143 | + Unchanged on exit. |
2144 | + |
2145 | + N - INTEGER. |
2146 | + On entry, N specifies the number of columns of the matrix C. |
2147 | + N must be at least zero. |
2148 | + Unchanged on exit. |
2149 | + |
2150 | + ALPHA - DOUBLE PRECISION. |
2151 | + On entry, ALPHA specifies the scalar alpha. |
2152 | + Unchanged on exit. |
2153 | + |
2154 | + A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is |
2155 | + m when SIDE = 'L' or 'l' and is n otherwise. |
2156 | + Before entry with SIDE = 'L' or 'l', the m by m part of |
2157 | + the array A must contain the symmetric matrix, such that |
2158 | + when UPLO = 'U' or 'u', the leading m by m upper triangular |
2159 | + part of the array A must contain the upper triangular part |
2160 | + of the symmetric matrix and the strictly lower triangular |
2161 | + part of A is not referenced, and when UPLO = 'L' or 'l', |
2162 | + the leading m by m lower triangular part of the array A |
2163 | + must contain the lower triangular part of the symmetric |
2164 | + matrix and the strictly upper triangular part of A is not |
2165 | + referenced. |
2166 | + Before entry with SIDE = 'R' or 'r', the n by n part of |
2167 | + the array A must contain the symmetric matrix, such that |
2168 | + when UPLO = 'U' or 'u', the leading n by n upper triangular |
2169 | + part of the array A must contain the upper triangular part |
2170 | + of the symmetric matrix and the strictly lower triangular |
2171 | + part of A is not referenced, and when UPLO = 'L' or 'l', |
2172 | + the leading n by n lower triangular part of the array A |
2173 | + must contain the lower triangular part of the symmetric |
2174 | + matrix and the strictly upper triangular part of A is not |
2175 | + referenced. |
2176 | + Unchanged on exit. |
2177 | + |
2178 | + LDA - INTEGER. |
2179 | + On entry, LDA specifies the first dimension of A as declared |
2180 | + in the calling (sub) program. When SIDE = 'L' or 'l' then |
2181 | + LDA must be at least max( 1, m ), otherwise LDA must be at |
2182 | + least max( 1, n ). |
2183 | + Unchanged on exit. |
2184 | + |
2185 | + B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). |
2186 | + Before entry, the leading m by n part of the array B must |
2187 | + contain the matrix B. |
2188 | + Unchanged on exit. |
2189 | + |
2190 | + LDB - INTEGER. |
2191 | + On entry, LDB specifies the first dimension of B as declared |
2192 | + in the calling (sub) program. LDB must be at least |
2193 | + max( 1, m ). |
2194 | + Unchanged on exit. |
2195 | + |
2196 | + BETA - DOUBLE PRECISION. |
2197 | + On entry, BETA specifies the scalar beta. When BETA is |
2198 | + supplied as zero then C need not be set on input. |
2199 | + Unchanged on exit. |
2200 | + |
2201 | + C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). |
2202 | + Before entry, the leading m by n part of the array C must |
2203 | + contain the matrix C, except when beta is zero, in which |
2204 | + case C need not be set on entry. |
2205 | + On exit, the array C is overwritten by the m by n updated |
2206 | + matrix. |
2207 | + |
2208 | + LDC - INTEGER. |
2209 | + On entry, LDC specifies the first dimension of C as declared |
2210 | + in the calling (sub) program. LDC must be at least |
2211 | + max( 1, m ). |
2212 | + Unchanged on exit. |
2213 | + |
2214 | + |
2215 | + Level 3 Blas routine. |
2216 | + |
2217 | + -- Written on 8-February-1989. |
2218 | + Jack Dongarra, Argonne National Laboratory. |
2219 | + Iain Duff, AERE Harwell. |
2220 | + Jeremy Du Croz, Numerical Algorithms Group Ltd. |
2221 | + Sven Hammarling, Numerical Algorithms Group Ltd. |
2222 | + |
2223 | + |
2224 | + Set NROWA as the number of rows of A. |
2225 | +*/ |
2226 | + |
2227 | + /* Parameter adjustments */ |
2228 | + a_dim1 = *lda; |
2229 | + a_offset = 1 + a_dim1 * 1; |
2230 | + a -= a_offset; |
2231 | + b_dim1 = *ldb; |
2232 | + b_offset = 1 + b_dim1 * 1; |
2233 | + b -= b_offset; |
2234 | + c_dim1 = *ldc; |
2235 | + c_offset = 1 + c_dim1 * 1; |
2236 | + c__ -= c_offset; |
2237 | + |
2238 | + /* Function Body */ |
2239 | + if (lsame_(side, "L")) { |
2240 | + nrowa = *m; |
2241 | + } else { |
2242 | + nrowa = *n; |
2243 | + } |
2244 | + upper = lsame_(uplo, "U"); |
2245 | + |
2246 | +/* Test the input parameters. */ |
2247 | + |
2248 | + info = 0; |
2249 | + if (! lsame_(side, "L") && ! lsame_(side, "R")) { |
2250 | + info = 1; |
2251 | + } else if (! upper && ! lsame_(uplo, "L")) { |
2252 | + info = 2; |
2253 | + } else if (*m < 0) { |
2254 | + info = 3; |
2255 | + } else if (*n < 0) { |
2256 | + info = 4; |
2257 | + } else if (*lda < max(1,nrowa)) { |
2258 | + info = 7; |
2259 | + } else if (*ldb < max(1,*m)) { |
2260 | + info = 9; |
2261 | + } else if (*ldc < max(1,*m)) { |
2262 | + info = 12; |
2263 | + } |
2264 | + if (info != 0) { |
2265 | + xerbla_("DSYMM ", &info); |
2266 | + return 0; |
2267 | + } |
2268 | + |
2269 | +/* Quick return if possible. */ |
2270 | + |
2271 | + if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { |
2272 | + return 0; |
2273 | + } |
2274 | + |
2275 | +/* And when alpha.eq.zero. */ |
2276 | + |
2277 | + if (*alpha == 0.) { |
2278 | + if (*beta == 0.) { |
2279 | + i__1 = *n; |
2280 | + for (j = 1; j <= i__1; ++j) { |
2281 | + i__2 = *m; |
2282 | + for (i__ = 1; i__ <= i__2; ++i__) { |
2283 | + c__[i__ + j * c_dim1] = 0.; |
2284 | +/* L10: */ |
2285 | + } |
2286 | +/* L20: */ |
2287 | + } |
2288 | + } else { |
2289 | + i__1 = *n; |
2290 | + for (j = 1; j <= i__1; ++j) { |
2291 | + i__2 = *m; |
2292 | + for (i__ = 1; i__ <= i__2; ++i__) { |
2293 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; |
2294 | +/* L30: */ |
2295 | + } |
2296 | +/* L40: */ |
2297 | + } |
2298 | + } |
2299 | + return 0; |
2300 | + } |
2301 | + |
2302 | +/* Start the operations. */ |
2303 | + |
2304 | + if (lsame_(side, "L")) { |
2305 | + |
2306 | +/* Form C := alpha*A*B + beta*C. */ |
2307 | + |
2308 | + if (upper) { |
2309 | + i__1 = *n; |
2310 | + for (j = 1; j <= i__1; ++j) { |
2311 | + i__2 = *m; |
2312 | + for (i__ = 1; i__ <= i__2; ++i__) { |
2313 | + temp1 = *alpha * b[i__ + j * b_dim1]; |
2314 | + temp2 = 0.; |
2315 | + i__3 = i__ - 1; |
2316 | + for (k = 1; k <= i__3; ++k) { |
2317 | + c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; |
2318 | + temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; |
2319 | +/* L50: */ |
2320 | + } |
2321 | + if (*beta == 0.) { |
2322 | + c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] |
2323 | + + *alpha * temp2; |
2324 | + } else { |
2325 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] |
2326 | + + temp1 * a[i__ + i__ * a_dim1] + *alpha * |
2327 | + temp2; |
2328 | + } |
2329 | +/* L60: */ |
2330 | + } |
2331 | +/* L70: */ |
2332 | + } |
2333 | + } else { |
2334 | + i__1 = *n; |
2335 | + for (j = 1; j <= i__1; ++j) { |
2336 | + for (i__ = *m; i__ >= 1; --i__) { |
2337 | + temp1 = *alpha * b[i__ + j * b_dim1]; |
2338 | + temp2 = 0.; |
2339 | + i__2 = *m; |
2340 | + for (k = i__ + 1; k <= i__2; ++k) { |
2341 | + c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; |
2342 | + temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; |
2343 | +/* L80: */ |
2344 | + } |
2345 | + if (*beta == 0.) { |
2346 | + c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] |
2347 | + + *alpha * temp2; |
2348 | + } else { |
2349 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] |
2350 | + + temp1 * a[i__ + i__ * a_dim1] + *alpha * |
2351 | + temp2; |
2352 | + } |
2353 | +/* L90: */ |
2354 | + } |
2355 | +/* L100: */ |
2356 | + } |
2357 | + } |
2358 | + } else { |
2359 | + |
2360 | +/* Form C := alpha*B*A + beta*C. */ |
2361 | + |
2362 | + i__1 = *n; |
2363 | + for (j = 1; j <= i__1; ++j) { |
2364 | + temp1 = *alpha * a[j + j * a_dim1]; |
2365 | + if (*beta == 0.) { |
2366 | + i__2 = *m; |
2367 | + for (i__ = 1; i__ <= i__2; ++i__) { |
2368 | + c__[i__ + j * c_dim1] = temp1 * b[i__ + j * b_dim1]; |
2369 | +/* L110: */ |
2370 | + } |
2371 | + } else { |
2372 | + i__2 = *m; |
2373 | + for (i__ = 1; i__ <= i__2; ++i__) { |
2374 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + |
2375 | + temp1 * b[i__ + j * b_dim1]; |
2376 | +/* L120: */ |
2377 | + } |
2378 | + } |
2379 | + i__2 = j - 1; |
2380 | + for (k = 1; k <= i__2; ++k) { |
2381 | + if (upper) { |
2382 | + temp1 = *alpha * a[k + j * a_dim1]; |
2383 | + } else { |
2384 | + temp1 = *alpha * a[j + k * a_dim1]; |
2385 | + } |
2386 | + i__3 = *m; |
2387 | + for (i__ = 1; i__ <= i__3; ++i__) { |
2388 | + c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; |
2389 | +/* L130: */ |
2390 | + } |
2391 | +/* L140: */ |
2392 | + } |
2393 | + i__2 = *n; |
2394 | + for (k = j + 1; k <= i__2; ++k) { |
2395 | + if (upper) { |
2396 | + temp1 = *alpha * a[j + k * a_dim1]; |
2397 | + } else { |
2398 | + temp1 = *alpha * a[k + j * a_dim1]; |
2399 | + } |
2400 | + i__3 = *m; |
2401 | + for (i__ = 1; i__ <= i__3; ++i__) { |
2402 | + c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; |
2403 | +/* L150: */ |
2404 | + } |
2405 | +/* L160: */ |
2406 | + } |
2407 | +/* L170: */ |
2408 | + } |
2409 | + } |
2410 | + |
2411 | + return 0; |
2412 | + |
2413 | +/* End of DSYMM . */ |
2414 | + |
2415 | +} /* dsymm_ */ |
2416 | + |
2417 | +/* Subroutine */ int dsymv_(char *uplo, integer *n, doublereal *alpha, |
2418 | + doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal |
2419 | + *beta, doublereal *y, integer *incy) |
2420 | +{ |
2421 | + /* System generated locals */ |
2422 | + integer a_dim1, a_offset, i__1, i__2; |
2423 | + |
2424 | + /* Local variables */ |
2425 | + static integer info; |
2426 | + static doublereal temp1, temp2; |
2427 | + static integer i__, j; |
2428 | + extern logical lsame_(char *, char *); |
2429 | + static integer ix, iy, jx, jy, kx, ky; |
2430 | + extern /* Subroutine */ int xerbla_(char *, integer *); |
2431 | + |
2432 | + |
2433 | +/* |
2434 | + Purpose |
2435 | + ======= |
2436 | + |
2437 | + DSYMV performs the matrix-vector operation |
2438 | + |
2439 | + y := alpha*A*x + beta*y, |
2440 | + |
2441 | + where alpha and beta are scalars, x and y are n element vectors and |
2442 | + A is an n by n symmetric matrix. |
2443 | + |
2444 | + Arguments |
2445 | + ========== |
2446 | + |
2447 | + UPLO - CHARACTER*1. |
2448 | + On entry, UPLO specifies whether the upper or lower |
2449 | + triangular part of the array A is to be referenced as |
2450 | + follows: |
2451 | + |
2452 | + UPLO = 'U' or 'u' Only the upper triangular part of A |
2453 | + is to be referenced. |
2454 | + |
2455 | + UPLO = 'L' or 'l' Only the lower triangular part of A |
2456 | + is to be referenced. |
2457 | + |
2458 | + Unchanged on exit. |
2459 | + |
2460 | + N - INTEGER. |
2461 | + On entry, N specifies the order of the matrix A. |
2462 | + N must be at least zero. |
2463 | + Unchanged on exit. |
2464 | + |
2465 | + ALPHA - DOUBLE PRECISION. |
2466 | + On entry, ALPHA specifies the scalar alpha. |
2467 | + Unchanged on exit. |
2468 | + |
2469 | + A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). |
2470 | + Before entry with UPLO = 'U' or 'u', the leading n by n |
2471 | + upper triangular part of the array A must contain the upper |
2472 | + triangular part of the symmetric matrix and the strictly |
2473 | + lower triangular part of A is not referenced. |
2474 | + Before entry with UPLO = 'L' or 'l', the leading n by n |
2475 | + lower triangular part of the array A must contain the lower |
2476 | + triangular part of the symmetric matrix and the strictly |
2477 | + upper triangular part of A is not referenced. |
2478 | + Unchanged on exit. |
2479 | + |
2480 | + LDA - INTEGER. |
2481 | + On entry, LDA specifies the first dimension of A as declared |
2482 | + in the calling (sub) program. LDA must be at least |
2483 | + max( 1, n ). |
2484 | + Unchanged on exit. |
2485 | + |
2486 | + X - DOUBLE PRECISION array of dimension at least |
2487 | + ( 1 + ( n - 1 )*abs( INCX ) ). |
2488 | + Before entry, the incremented array X must contain the n |
2489 | + element vector x. |
2490 | + Unchanged on exit. |
2491 | + |
2492 | + INCX - INTEGER. |
2493 | + On entry, INCX specifies the increment for the elements of |
2494 | + X. INCX must not be zero. |
2495 | + Unchanged on exit. |
2496 | + |
2497 | + BETA - DOUBLE PRECISION. |
2498 | + On entry, BETA specifies the scalar beta. When BETA is |
2499 | + supplied as zero then Y need not be set on input. |
2500 | + Unchanged on exit. |
2501 | + |
2502 | + Y - DOUBLE PRECISION array of dimension at least |
2503 | + ( 1 + ( n - 1 )*abs( INCY ) ). |
2504 | + Before entry, the incremented array Y must contain the n |
2505 | + element vector y. On exit, Y is overwritten by the updated |
2506 | + vector y. |
2507 | + |
2508 | + INCY - INTEGER. |
2509 | + On entry, INCY specifies the increment for the elements of |
2510 | + Y. INCY must not be zero. |
2511 | + Unchanged on exit. |
2512 | + |
2513 | + |
2514 | + Level 2 Blas routine. |
2515 | + |
2516 | + -- Written on 22-October-1986. |
2517 | + Jack Dongarra, Argonne National Lab. |
2518 | + Jeremy Du Croz, Nag Central Office. |
2519 | + Sven Hammarling, Nag Central Office. |
2520 | + Richard Hanson, Sandia National Labs. |
2521 | + |
2522 | + |
2523 | + Test the input parameters. |
2524 | +*/ |
2525 | + |
2526 | + /* Parameter adjustments */ |
2527 | + a_dim1 = *lda; |
2528 | + a_offset = 1 + a_dim1 * 1; |
2529 | + a -= a_offset; |
2530 | + --x; |
2531 | + --y; |
2532 | + |
2533 | + /* Function Body */ |
2534 | + info = 0; |
2535 | + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { |
2536 | + info = 1; |
2537 | + } else if (*n < 0) { |
2538 | + info = 2; |
2539 | + } else if (*lda < max(1,*n)) { |
2540 | + info = 5; |
2541 | + } else if (*incx == 0) { |
2542 | + info = 7; |
2543 | + } else if (*incy == 0) { |
2544 | + info = 10; |
2545 | + } |
2546 | + if (info != 0) { |
2547 | + xerbla_("DSYMV ", &info); |
2548 | + return 0; |
2549 | + } |
2550 | + |
2551 | +/* Quick return if possible. */ |
2552 | + |
2553 | + if (*n == 0 || *alpha == 0. && *beta == 1.) { |
2554 | + return 0; |
2555 | + } |
2556 | + |
2557 | +/* Set up the start points in X and Y. */ |
2558 | + |
2559 | + if (*incx > 0) { |
2560 | + kx = 1; |
2561 | + } else { |
2562 | + kx = 1 - (*n - 1) * *incx; |
2563 | + } |
2564 | + if (*incy > 0) { |
2565 | + ky = 1; |
2566 | + } else { |
2567 | + ky = 1 - (*n - 1) * *incy; |
2568 | + } |
2569 | + |
2570 | +/* |
2571 | + Start the operations. In this version the elements of A are |
2572 | + accessed sequentially with one pass through the triangular part |
2573 | + of A. |
2574 | + |
2575 | + First form y := beta*y. |
2576 | +*/ |
2577 | + |
2578 | + if (*beta != 1.) { |
2579 | + if (*incy == 1) { |
2580 | + if (*beta == 0.) { |
2581 | + i__1 = *n; |
2582 | + for (i__ = 1; i__ <= i__1; ++i__) { |
2583 | + y[i__] = 0.; |
2584 | +/* L10: */ |
2585 | + } |
2586 | + } else { |
2587 | + i__1 = *n; |
2588 | + for (i__ = 1; i__ <= i__1; ++i__) { |
2589 | + y[i__] = *beta * y[i__]; |
2590 | +/* L20: */ |
2591 | + } |
2592 | + } |
2593 | + } else { |
2594 | + iy = ky; |
2595 | + if (*beta == 0.) { |
2596 | + i__1 = *n; |
2597 | + for (i__ = 1; i__ <= i__1; ++i__) { |
2598 | + y[iy] = 0.; |
2599 | + iy += *incy; |
2600 | +/* L30: */ |
2601 | + } |
2602 | + } else { |
2603 | + i__1 = *n; |
2604 | + for (i__ = 1; i__ <= i__1; ++i__) { |
2605 | + y[iy] = *beta * y[iy]; |
2606 | + iy += *incy; |
2607 | +/* L40: */ |
2608 | + } |
2609 | + } |
2610 | + } |
2611 | + } |
2612 | + if (*alpha == 0.) { |
2613 | + return 0; |
2614 | + } |
2615 | + if (lsame_(uplo, "U")) { |
2616 | + |
2617 | +/* Form y when A is stored in upper triangle. */ |
2618 | + |
2619 | + if (*incx == 1 && *incy == 1) { |
2620 | + i__1 = *n; |
2621 | + for (j = 1; j <= i__1; ++j) { |
2622 | + temp1 = *alpha * x[j]; |
2623 | + temp2 = 0.; |
2624 | + i__2 = j - 1; |
2625 | + for (i__ = 1; i__ <= i__2; ++i__) { |
2626 | + y[i__] += temp1 * a[i__ + j * a_dim1]; |
2627 | + temp2 += a[i__ + j * a_dim1] * x[i__]; |
2628 | +/* L50: */ |
2629 | + } |
2630 | + y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2; |
2631 | +/* L60: */ |
2632 | + } |
2633 | + } else { |
2634 | + jx = kx; |
2635 | + jy = ky; |
2636 | + i__1 = *n; |
2637 | + for (j = 1; j <= i__1; ++j) { |
2638 | + temp1 = *alpha * x[jx]; |
2639 | + temp2 = 0.; |
2640 | + ix = kx; |
2641 | + iy = ky; |
2642 | + i__2 = j - 1; |
2643 | + for (i__ = 1; i__ <= i__2; ++i__) { |
2644 | + y[iy] += temp1 * a[i__ + j * a_dim1]; |
2645 | + temp2 += a[i__ + j * a_dim1] * x[ix]; |
2646 | + ix += *incx; |
2647 | + iy += *incy; |
2648 | +/* L70: */ |
2649 | + } |
2650 | + y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2; |
2651 | + jx += *incx; |
2652 | + jy += *incy; |
2653 | +/* L80: */ |
2654 | + } |
2655 | + } |
2656 | + } else { |
2657 | + |
2658 | +/* Form y when A is stored in lower triangle. */ |
2659 | + |
2660 | + if (*incx == 1 && *incy == 1) { |
2661 | + i__1 = *n; |
2662 | + for (j = 1; j <= i__1; ++j) { |
2663 | + temp1 = *alpha * x[j]; |
2664 | + temp2 = 0.; |
2665 | + y[j] += temp1 * a[j + j * a_dim1]; |
2666 | + i__2 = *n; |
2667 | + for (i__ = j + 1; i__ <= i__2; ++i__) { |
2668 | + y[i__] += temp1 * a[i__ + j * a_dim1]; |
2669 | + temp2 += a[i__ + j * a_dim1] * x[i__]; |
2670 | +/* L90: */ |
2671 | + } |
2672 | + y[j] += *alpha * temp2; |
2673 | +/* L100: */ |
2674 | + } |
2675 | + } else { |
2676 | + jx = kx; |
2677 | + jy = ky; |
2678 | + i__1 = *n; |
2679 | + for (j = 1; j <= i__1; ++j) { |
2680 | + temp1 = *alpha * x[jx]; |
2681 | + temp2 = 0.; |
2682 | + y[jy] += temp1 * a[j + j * a_dim1]; |
2683 | + ix = jx; |
2684 | + iy = jy; |
2685 | + i__2 = *n; |
2686 | + for (i__ = j + 1; i__ <= i__2; ++i__) { |
2687 | + ix += *incx; |
2688 | + iy += *incy; |
2689 | + y[iy] += temp1 * a[i__ + j * a_dim1]; |
2690 | + temp2 += a[i__ + j * a_dim1] * x[ix]; |
2691 | +/* L110: */ |
2692 | + } |
2693 | + y[jy] += *alpha * temp2; |
2694 | + jx += *incx; |
2695 | + jy += *incy; |
2696 | +/* L120: */ |
2697 | + } |
2698 | + } |
2699 | + } |
2700 | + |
2701 | + return 0; |
2702 | + |
2703 | +/* End of DSYMV . */ |
2704 | + |
2705 | +} /* dsymv_ */ |
2706 | + |
2707 | +/* Subroutine */ int dsyr_(char *uplo, integer *n, doublereal *alpha, |
2708 | + doublereal *x, integer *incx, doublereal *a, integer *lda) |
2709 | +{ |
2710 | + /* System generated locals */ |
2711 | + integer a_dim1, a_offset, i__1, i__2; |
2712 | + |
2713 | + /* Local variables */ |
2714 | + static integer info; |
2715 | + static doublereal temp; |
2716 | + static integer i__, j; |
2717 | + extern logical lsame_(char *, char *); |
2718 | + static integer ix, jx, kx; |
2719 | + extern /* Subroutine */ int xerbla_(char *, integer *); |
2720 | + |
2721 | + |
2722 | +/* |
2723 | + Purpose |
2724 | + ======= |
2725 | + |
2726 | + DSYR performs the symmetric rank 1 operation |
2727 | + |
2728 | + A := alpha*x*x' + A, |
2729 | + |
2730 | + where alpha is a real scalar, x is an n element vector and A is an |
2731 | + n by n symmetric matrix. |
2732 | + |
2733 | + Arguments |
2734 | + ========== |
2735 | + |
2736 | + UPLO - CHARACTER*1. |
2737 | + On entry, UPLO specifies whether the upper or lower |
2738 | + triangular part of the array A is to be referenced as |
2739 | + follows: |
2740 | + |
2741 | + UPLO = 'U' or 'u' Only the upper triangular part of A |
2742 | + is to be referenced. |
2743 | + |
2744 | + UPLO = 'L' or 'l' Only the lower triangular part of A |
2745 | + is to be referenced. |
2746 | + |
2747 | + Unchanged on exit. |
2748 | + |
2749 | + N - INTEGER. |
2750 | + On entry, N specifies the order of the matrix A. |
2751 | + N must be at least zero. |
2752 | + Unchanged on exit. |
2753 | + |
2754 | + ALPHA - DOUBLE PRECISION. |
2755 | + On entry, ALPHA specifies the scalar alpha. |
2756 | + Unchanged on exit. |
2757 | + |
2758 | + X - DOUBLE PRECISION array of dimension at least |
2759 | + ( 1 + ( n - 1 )*abs( INCX ) ). |
2760 | + Before entry, the incremented array X must contain the n |
2761 | + element vector x. |
2762 | + Unchanged on exit. |
2763 | + |
2764 | + INCX - INTEGER. |
2765 | + On entry, INCX specifies the increment for the elements of |
2766 | + X. INCX must not be zero. |
2767 | + Unchanged on exit. |
2768 | + |
2769 | + A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). |
2770 | + Before entry with UPLO = 'U' or 'u', the leading n by n |
2771 | + upper triangular part of the array A must contain the upper |
2772 | + triangular part of the symmetric matrix and the strictly |
2773 | + lower triangular part of A is not referenced. On exit, the |
2774 | + upper triangular part of the array A is overwritten by the |
2775 | + upper triangular part of the updated matrix. |
2776 | + Before entry with UPLO = 'L' or 'l', the leading n by n |
2777 | + lower triangular part of the array A must contain the lower |
2778 | + triangular part of the symmetric matrix and the strictly |
2779 | + upper triangular part of A is not referenced. On exit, the |
2780 | + lower triangular part of the array A is overwritten by the |
2781 | + lower triangular part of the updated matrix. |
2782 | + |
2783 | + LDA - INTEGER. |
2784 | + On entry, LDA specifies the first dimension of A as declared |
2785 | + in the calling (sub) program. LDA must be at least |
2786 | + max( 1, n ). |
2787 | + Unchanged on exit. |
2788 | + |
2789 | + |
2790 | + Level 2 Blas routine. |
2791 | + |
2792 | + -- Written on 22-October-1986. |
2793 | + Jack Dongarra, Argonne National Lab. |
2794 | + Jeremy Du Croz, Nag Central Office. |
2795 | + Sven Hammarling, Nag Central Office. |
2796 | + Richard Hanson, Sandia National Labs. |
2797 | + |
2798 | + |
2799 | + Test the input parameters. |
2800 | +*/ |
2801 | + |
2802 | + /* Parameter adjustments */ |
2803 | + --x; |
2804 | + a_dim1 = *lda; |
2805 | + a_offset = 1 + a_dim1 * 1; |
2806 | + a -= a_offset; |
2807 | + |
2808 | + /* Function Body */ |
2809 | + info = 0; |
2810 | + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { |
2811 | + info = 1; |
2812 | + } else if (*n < 0) { |
2813 | + info = 2; |
2814 | + } else if (*incx == 0) { |
2815 | + info = 5; |
2816 | + } else if (*lda < max(1,*n)) { |
2817 | + info = 7; |
2818 | + } |
2819 | + if (info != 0) { |
2820 | + xerbla_("DSYR ", &info); |
2821 | + return 0; |
2822 | + } |
2823 | + |
2824 | +/* Quick return if possible. */ |
2825 | + |
2826 | + if (*n == 0 || *alpha == 0.) { |
2827 | + return 0; |
2828 | + } |
2829 | + |
2830 | +/* Set the start point in X if the increment is not unity. */ |
2831 | + |
2832 | + if (*incx <= 0) { |
2833 | + kx = 1 - (*n - 1) * *incx; |
2834 | + } else if (*incx != 1) { |
2835 | + kx = 1; |
2836 | + } |
2837 | + |
2838 | +/* |
2839 | + Start the operations. In this version the elements of A are |
2840 | + accessed sequentially with one pass through the triangular part |
2841 | + of A. |
2842 | +*/ |
2843 | + |
2844 | + if (lsame_(uplo, "U")) { |
2845 | + |
2846 | +/* Form A when A is stored in upper triangle. */ |
2847 | + |
2848 | + if (*incx == 1) { |
2849 | + i__1 = *n; |
2850 | + for (j = 1; j <= i__1; ++j) { |
2851 | + if (x[j] != 0.) { |
2852 | + temp = *alpha * x[j]; |
2853 | + i__2 = j; |
2854 | + for (i__ = 1; i__ <= i__2; ++i__) { |
2855 | + a[i__ + j * a_dim1] += x[i__] * temp; |
2856 | +/* L10: */ |
2857 | + } |
2858 | + } |
2859 | +/* L20: */ |
2860 | + } |
2861 | + } else { |
2862 | + jx = kx; |
2863 | + i__1 = *n; |
2864 | + for (j = 1; j <= i__1; ++j) { |
2865 | + if (x[jx] != 0.) { |
2866 | + temp = *alpha * x[jx]; |
2867 | + ix = kx; |
2868 | + i__2 = j; |
2869 | + for (i__ = 1; i__ <= i__2; ++i__) { |
2870 | + a[i__ + j * a_dim1] += x[ix] * temp; |
2871 | + ix += *incx; |
2872 | +/* L30: */ |
2873 | + } |
2874 | + } |
2875 | + jx += *incx; |
2876 | +/* L40: */ |
2877 | + } |
2878 | + } |
2879 | + } else { |
2880 | + |
2881 | +/* Form A when A is stored in lower triangle. */ |
2882 | + |
2883 | + if (*incx == 1) { |
2884 | + i__1 = *n; |
2885 | + for (j = 1; j <= i__1; ++j) { |
2886 | + if (x[j] != 0.) { |
2887 | + temp = *alpha * x[j]; |
2888 | + i__2 = *n; |
2889 | + for (i__ = j; i__ <= i__2; ++i__) { |
2890 | + a[i__ + j * a_dim1] += x[i__] * temp; |
2891 | +/* L50: */ |
2892 | + } |
2893 | + } |
2894 | +/* L60: */ |
2895 | + } |
2896 | + } else { |
2897 | + jx = kx; |
2898 | + i__1 = *n; |
2899 | + for (j = 1; j <= i__1; ++j) { |
2900 | + if (x[jx] != 0.) { |
2901 | + temp = *alpha * x[jx]; |
2902 | + ix = jx; |
2903 | + i__2 = *n; |
2904 | + for (i__ = j; i__ <= i__2; ++i__) { |
2905 | + a[i__ + j * a_dim1] += x[ix] * temp; |
2906 | + ix += *incx; |
2907 | +/* L70: */ |
2908 | + } |
2909 | + } |
2910 | + jx += *incx; |
2911 | +/* L80: */ |
2912 | + } |
2913 | + } |
2914 | + } |
2915 | + |
2916 | + return 0; |
2917 | + |
2918 | +/* End of DSYR . */ |
2919 | + |
2920 | +} /* dsyr_ */ |
2921 | + |
2922 | +/* Subroutine */ int dsyr2_(char *uplo, integer *n, doublereal *alpha, |
2923 | + doublereal *x, integer *incx, doublereal *y, integer *incy, |
2924 | + doublereal *a, integer *lda) |
2925 | +{ |
2926 | + /* System generated locals */ |
2927 | + integer a_dim1, a_offset, i__1, i__2; |
2928 | + |
2929 | + /* Local variables */ |
2930 | + static integer info; |
2931 | + static doublereal temp1, temp2; |
2932 | + static integer i__, j; |
2933 | + extern logical lsame_(char *, char *); |
2934 | + static integer ix, iy, jx, jy, kx, ky; |
2935 | + extern /* Subroutine */ int xerbla_(char *, integer *); |
2936 | + |
2937 | + |
2938 | +/* |
2939 | + Purpose |
2940 | + ======= |
2941 | + |
2942 | + DSYR2 performs the symmetric rank 2 operation |
2943 | + |
2944 | + A := alpha*x*y' + alpha*y*x' + A, |
2945 | + |
2946 | + where alpha is a scalar, x and y are n element vectors and A is an n |
2947 | + by n symmetric matrix. |
2948 | + |
2949 | + Arguments |
2950 | + ========== |
2951 | + |
2952 | + UPLO - CHARACTER*1. |
2953 | + On entry, UPLO specifies whether the upper or lower |
2954 | + triangular part of the array A is to be referenced as |
2955 | + follows: |
2956 | + |
2957 | + UPLO = 'U' or 'u' Only the upper triangular part of A |
2958 | + is to be referenced. |
2959 | + |
2960 | + UPLO = 'L' or 'l' Only the lower triangular part of A |
2961 | + is to be referenced. |
2962 | + |
2963 | + Unchanged on exit. |
2964 | + |
2965 | + N - INTEGER. |
2966 | + On entry, N specifies the order of the matrix A. |
2967 | + N must be at least zero. |
2968 | + Unchanged on exit. |
2969 | + |
2970 | + ALPHA - DOUBLE PRECISION. |
2971 | + On entry, ALPHA specifies the scalar alpha. |
2972 | + Unchanged on exit. |
2973 | + |
2974 | + X - DOUBLE PRECISION array of dimension at least |
2975 | + ( 1 + ( n - 1 )*abs( INCX ) ). |
2976 | + Before entry, the incremented array X must contain the n |
2977 | + element vector x. |
2978 | + Unchanged on exit. |
2979 | + |
2980 | + INCX - INTEGER. |
2981 | + On entry, INCX specifies the increment for the elements of |
2982 | + X. INCX must not be zero. |
2983 | + Unchanged on exit. |
2984 | + |
2985 | + Y - DOUBLE PRECISION array of dimension at least |
2986 | + ( 1 + ( n - 1 )*abs( INCY ) ). |
2987 | + Before entry, the incremented array Y must contain the n |
2988 | + element vector y. |
2989 | + Unchanged on exit. |
2990 | + |
2991 | + INCY - INTEGER. |
2992 | + On entry, INCY specifies the increment for the elements of |
2993 | + Y. INCY must not be zero. |
2994 | + Unchanged on exit. |
2995 | + |
2996 | + A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). |
2997 | + Before entry with UPLO = 'U' or 'u', the leading n by n |
2998 | + upper triangular part of the array A must contain the upper |
2999 | + triangular part of the symmetric matrix and the strictly |
3000 | + lower triangular part of A is not referenced. On exit, the |
3001 | + upper triangular part of the array A is overwritten by the |
3002 | + upper triangular part of the updated matrix. |
3003 | + Before entry with UPLO = 'L' or 'l', the leading n by n |
3004 | + lower triangular part of the array A must contain the lower |
3005 | + triangular part of the symmetric matrix and the strictly |
3006 | + upper triangular part of A is not referenced. On exit, the |
3007 | + lower triangular part of the array A is overwritten by the |
3008 | + lower triangular part of the updated matrix. |
3009 | + |
3010 | + LDA - INTEGER. |
3011 | + On entry, LDA specifies the first dimension of A as declared |
3012 | + in the calling (sub) program. LDA must be at least |
3013 | + max( 1, n ). |
3014 | + Unchanged on exit. |
3015 | + |
3016 | + |
3017 | + Level 2 Blas routine. |
3018 | + |
3019 | + -- Written on 22-October-1986. |
3020 | + Jack Dongarra, Argonne National Lab. |
3021 | + Jeremy Du Croz, Nag Central Office. |
3022 | + Sven Hammarling, Nag Central Office. |
3023 | + Richard Hanson, Sandia National Labs. |
3024 | + |
3025 | + |
3026 | + Test the input parameters. |
3027 | +*/ |
3028 | + |
3029 | + /* Parameter adjustments */ |
3030 | + --x; |
3031 | + --y; |
3032 | + a_dim1 = *lda; |
3033 | + a_offset = 1 + a_dim1 * 1; |
3034 | + a -= a_offset; |
3035 | + |
3036 | + /* Function Body */ |
3037 | + info = 0; |
3038 | + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { |
3039 | + info = 1; |
3040 | + } else if (*n < 0) { |
3041 | + info = 2; |
3042 | + } else if (*incx == 0) { |
3043 | + info = 5; |
3044 | + } else if (*incy == 0) { |
3045 | + info = 7; |
3046 | + } else if (*lda < max(1,*n)) { |
3047 | + info = 9; |
3048 | + } |
3049 | + if (info != 0) { |
3050 | + xerbla_("DSYR2 ", &info); |
3051 | + return 0; |
3052 | + } |
3053 | + |
3054 | +/* Quick return if possible. */ |
3055 | + |
3056 | + if (*n == 0 || *alpha == 0.) { |
3057 | + return 0; |
3058 | + } |
3059 | + |
3060 | +/* |
3061 | + Set up the start points in X and Y if the increments are not both |
3062 | + unity. |
3063 | +*/ |
3064 | + |
3065 | + if (*incx != 1 || *incy != 1) { |
3066 | + if (*incx > 0) { |
3067 | + kx = 1; |
3068 | + } else { |
3069 | + kx = 1 - (*n - 1) * *incx; |
3070 | + } |
3071 | + if (*incy > 0) { |
3072 | + ky = 1; |
3073 | + } else { |
3074 | + ky = 1 - (*n - 1) * *incy; |
3075 | + } |
3076 | + jx = kx; |
3077 | + jy = ky; |
3078 | + } |
3079 | + |
3080 | +/* |
3081 | + Start the operations. In this version the elements of A are |
3082 | + accessed sequentially with one pass through the triangular part |
3083 | + of A. |
3084 | +*/ |
3085 | + |
3086 | + if (lsame_(uplo, "U")) { |
3087 | + |
3088 | +/* Form A when A is stored in the upper triangle. */ |
3089 | + |
3090 | + if (*incx == 1 && *incy == 1) { |
3091 | + i__1 = *n; |
3092 | + for (j = 1; j <= i__1; ++j) { |
3093 | + if (x[j] != 0. || y[j] != 0.) { |
3094 | + temp1 = *alpha * y[j]; |
3095 | + temp2 = *alpha * x[j]; |
3096 | + i__2 = j; |
3097 | + for (i__ = 1; i__ <= i__2; ++i__) { |
3098 | + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * |
3099 | + temp1 + y[i__] * temp2; |
3100 | +/* L10: */ |
3101 | + } |
3102 | + } |
3103 | +/* L20: */ |
3104 | + } |
3105 | + } else { |
3106 | + i__1 = *n; |
3107 | + for (j = 1; j <= i__1; ++j) { |
3108 | + if (x[jx] != 0. || y[jy] != 0.) { |
3109 | + temp1 = *alpha * y[jy]; |
3110 | + temp2 = *alpha * x[jx]; |
3111 | + ix = kx; |
3112 | + iy = ky; |
3113 | + i__2 = j; |
3114 | + for (i__ = 1; i__ <= i__2; ++i__) { |
3115 | + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * |
3116 | + temp1 + y[iy] * temp2; |
3117 | + ix += *incx; |
3118 | + iy += *incy; |
3119 | +/* L30: */ |
3120 | + } |
3121 | + } |
3122 | + jx += *incx; |
3123 | + jy += *incy; |
3124 | +/* L40: */ |
3125 | + } |
3126 | + } |
3127 | + } else { |
3128 | + |
3129 | +/* Form A when A is stored in the lower triangle. */ |
3130 | + |
3131 | + if (*incx == 1 && *incy == 1) { |
3132 | + i__1 = *n; |
3133 | + for (j = 1; j <= i__1; ++j) { |
3134 | + if (x[j] != 0. || y[j] != 0.) { |
3135 | + temp1 = *alpha * y[j]; |
3136 | + temp2 = *alpha * x[j]; |
3137 | + i__2 = *n; |
3138 | + for (i__ = j; i__ <= i__2; ++i__) { |
3139 | + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * |
3140 | + temp1 + y[i__] * temp2; |
3141 | +/* L50: */ |
3142 | + } |
3143 | + } |
3144 | +/* L60: */ |
3145 | + } |
3146 | + } else { |
3147 | + i__1 = *n; |
3148 | + for (j = 1; j <= i__1; ++j) { |
3149 | + if (x[jx] != 0. || y[jy] != 0.) { |
3150 | + temp1 = *alpha * y[jy]; |
3151 | + temp2 = *alpha * x[jx]; |
3152 | + ix = jx; |
3153 | + iy = jy; |
3154 | + i__2 = *n; |
3155 | + for (i__ = j; i__ <= i__2; ++i__) { |
3156 | + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * |
3157 | + temp1 + y[iy] * temp2; |
3158 | + ix += *incx; |
3159 | + iy += *incy; |
3160 | +/* L70: */ |
3161 | + } |
3162 | + } |
3163 | + jx += *incx; |
3164 | + jy += *incy; |
3165 | +/* L80: */ |
3166 | + } |
3167 | + } |
3168 | + } |
3169 | + |
3170 | + return 0; |
3171 | + |
3172 | +/* End of DSYR2 . */ |
3173 | + |
3174 | +} /* dsyr2_ */ |
3175 | + |
3176 | +/* Subroutine */ int dsyr2k_(char *uplo, char *trans, integer *n, integer *k, |
3177 | + doublereal *alpha, doublereal *a, integer *lda, doublereal *b, |
3178 | + integer *ldb, doublereal *beta, doublereal *c__, integer *ldc) |
3179 | +{ |
3180 | + /* System generated locals */ |
3181 | + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, |
3182 | + i__3; |
3183 | + |
3184 | + /* Local variables */ |
3185 | + static integer info; |
3186 | + static doublereal temp1, temp2; |
3187 | + static integer i__, j, l; |
3188 | + extern logical lsame_(char *, char *); |
3189 | + static integer nrowa; |
3190 | + static logical upper; |
3191 | + extern /* Subroutine */ int xerbla_(char *, integer *); |
3192 | + |
3193 | + |
3194 | +/* |
3195 | + Purpose |
3196 | + ======= |
3197 | + |
3198 | + DSYR2K performs one of the symmetric rank 2k operations |
3199 | + |
3200 | + C := alpha*A*B' + alpha*B*A' + beta*C, |
3201 | + |
3202 | + or |
3203 | + |
3204 | + C := alpha*A'*B + alpha*B'*A + beta*C, |
3205 | + |
3206 | + where alpha and beta are scalars, C is an n by n symmetric matrix |
3207 | + and A and B are n by k matrices in the first case and k by n |
3208 | + matrices in the second case. |
3209 | + |
3210 | + Arguments |
3211 | + ========== |
3212 | + |
3213 | + UPLO - CHARACTER*1. |
3214 | + On entry, UPLO specifies whether the upper or lower |
3215 | + triangular part of the array C is to be referenced as |
3216 | + follows: |
3217 | + |
3218 | + UPLO = 'U' or 'u' Only the upper triangular part of C |
3219 | + is to be referenced. |
3220 | + |
3221 | + UPLO = 'L' or 'l' Only the lower triangular part of C |
3222 | + is to be referenced. |
3223 | + |
3224 | + Unchanged on exit. |
3225 | + |
3226 | + TRANS - CHARACTER*1. |
3227 | + On entry, TRANS specifies the operation to be performed as |
3228 | + follows: |
3229 | + |
3230 | + TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + |
3231 | + beta*C. |
3232 | + |
3233 | + TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + |
3234 | + beta*C. |
3235 | + |
3236 | + TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + |
3237 | + beta*C. |
3238 | + |
3239 | + Unchanged on exit. |
3240 | + |
3241 | + N - INTEGER. |
3242 | + On entry, N specifies the order of the matrix C. N must be |
3243 | + at least zero. |
3244 | + Unchanged on exit. |
3245 | + |
3246 | + K - INTEGER. |
3247 | + On entry with TRANS = 'N' or 'n', K specifies the number |
3248 | + of columns of the matrices A and B, and on entry with |
3249 | + TRANS = 'T' or 't' or 'C' or 'c', K specifies the number |
3250 | + of rows of the matrices A and B. K must be at least zero. |
3251 | + Unchanged on exit. |
3252 | + |
3253 | + ALPHA - DOUBLE PRECISION. |
3254 | + On entry, ALPHA specifies the scalar alpha. |
3255 | + Unchanged on exit. |
3256 | + |
3257 | + A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is |
3258 | + k when TRANS = 'N' or 'n', and is n otherwise. |
3259 | + Before entry with TRANS = 'N' or 'n', the leading n by k |
3260 | + part of the array A must contain the matrix A, otherwise |
3261 | + the leading k by n part of the array A must contain the |
3262 | + matrix A. |
3263 | + Unchanged on exit. |
3264 | + |
3265 | + LDA - INTEGER. |
3266 | + On entry, LDA specifies the first dimension of A as declared |
3267 | + in the calling (sub) program. When TRANS = 'N' or 'n' |
3268 | + then LDA must be at least max( 1, n ), otherwise LDA must |
3269 | + be at least max( 1, k ). |
3270 | + Unchanged on exit. |
3271 | + |
3272 | + B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is |
3273 | + k when TRANS = 'N' or 'n', and is n otherwise. |
3274 | + Before entry with TRANS = 'N' or 'n', the leading n by k |
3275 | + part of the array B must contain the matrix B, otherwise |
3276 | + the leading k by n part of the array B must contain the |
3277 | + matrix B. |
3278 | + Unchanged on exit. |
3279 | + |
3280 | + LDB - INTEGER. |
3281 | + On entry, LDB specifies the first dimension of B as declared |
3282 | + in the calling (sub) program. When TRANS = 'N' or 'n' |
3283 | + then LDB must be at least max( 1, n ), otherwise LDB must |
3284 | + be at least max( 1, k ). |
3285 | + Unchanged on exit. |
3286 | + |
3287 | + BETA - DOUBLE PRECISION. |
3288 | + On entry, BETA specifies the scalar beta. |
3289 | + Unchanged on exit. |
3290 | + |
3291 | + C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). |
3292 | + Before entry with UPLO = 'U' or 'u', the leading n by n |
3293 | + upper triangular part of the array C must contain the upper |
3294 | + triangular part of the symmetric matrix and the strictly |
3295 | + lower triangular part of C is not referenced. On exit, the |
3296 | + upper triangular part of the array C is overwritten by the |
3297 | + upper triangular part of the updated matrix. |
3298 | + Before entry with UPLO = 'L' or 'l', the leading n by n |
3299 | + lower triangular part of the array C must contain the lower |
3300 | + triangular part of the symmetric matrix and the strictly |
3301 | + upper triangular part of C is not referenced. On exit, the |
3302 | + lower triangular part of the array C is overwritten by the |
3303 | + lower triangular part of the updated matrix. |
3304 | + |
3305 | + LDC - INTEGER. |
3306 | + On entry, LDC specifies the first dimension of C as declared |
3307 | + in the calling (sub) program. LDC must be at least |
3308 | + max( 1, n ). |
3309 | + Unchanged on exit. |
3310 | + |
3311 | + |
3312 | + Level 3 Blas routine. |
3313 | + |
3314 | + |
3315 | + -- Written on 8-February-1989. |
3316 | + Jack Dongarra, Argonne National Laboratory. |
3317 | + Iain Duff, AERE Harwell. |
3318 | + Jeremy Du Croz, Numerical Algorithms Group Ltd. |
3319 | + Sven Hammarling, Numerical Algorithms Group Ltd. |
3320 | + |
3321 | + |
3322 | + Test the input parameters. |
3323 | +*/ |
3324 | + |
3325 | + /* Parameter adjustments */ |
3326 | + a_dim1 = *lda; |
3327 | + a_offset = 1 + a_dim1 * 1; |
3328 | + a -= a_offset; |
3329 | + b_dim1 = *ldb; |
3330 | + b_offset = 1 + b_dim1 * 1; |
3331 | + b -= b_offset; |
3332 | + c_dim1 = *ldc; |
3333 | + c_offset = 1 + c_dim1 * 1; |
3334 | + c__ -= c_offset; |
3335 | + |
3336 | + /* Function Body */ |
3337 | + if (lsame_(trans, "N")) { |
3338 | + nrowa = *n; |
3339 | + } else { |
3340 | + nrowa = *k; |
3341 | + } |
3342 | + upper = lsame_(uplo, "U"); |
3343 | + |
3344 | + info = 0; |
3345 | + if (! upper && ! lsame_(uplo, "L")) { |
3346 | + info = 1; |
3347 | + } else if (! lsame_(trans, "N") && ! lsame_(trans, |
3348 | + "T") && ! lsame_(trans, "C")) { |
3349 | + info = 2; |
3350 | + } else if (*n < 0) { |
3351 | + info = 3; |
3352 | + } else if (*k < 0) { |
3353 | + info = 4; |
3354 | + } else if (*lda < max(1,nrowa)) { |
3355 | + info = 7; |
3356 | + } else if (*ldb < max(1,nrowa)) { |
3357 | + info = 9; |
3358 | + } else if (*ldc < max(1,*n)) { |
3359 | + info = 12; |
3360 | + } |
3361 | + if (info != 0) { |
3362 | + xerbla_("DSYR2K", &info); |
3363 | + return 0; |
3364 | + } |
3365 | + |
3366 | +/* Quick return if possible. */ |
3367 | + |
3368 | + if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { |
3369 | + return 0; |
3370 | + } |
3371 | + |
3372 | +/* And when alpha.eq.zero. */ |
3373 | + |
3374 | + if (*alpha == 0.) { |
3375 | + if (upper) { |
3376 | + if (*beta == 0.) { |
3377 | + i__1 = *n; |
3378 | + for (j = 1; j <= i__1; ++j) { |
3379 | + i__2 = j; |
3380 | + for (i__ = 1; i__ <= i__2; ++i__) { |
3381 | + c__[i__ + j * c_dim1] = 0.; |
3382 | +/* L10: */ |
3383 | + } |
3384 | +/* L20: */ |
3385 | + } |
3386 | + } else { |
3387 | + i__1 = *n; |
3388 | + for (j = 1; j <= i__1; ++j) { |
3389 | + i__2 = j; |
3390 | + for (i__ = 1; i__ <= i__2; ++i__) { |
3391 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; |
3392 | +/* L30: */ |
3393 | + } |
3394 | +/* L40: */ |
3395 | + } |
3396 | + } |
3397 | + } else { |
3398 | + if (*beta == 0.) { |
3399 | + i__1 = *n; |
3400 | + for (j = 1; j <= i__1; ++j) { |
3401 | + i__2 = *n; |
3402 | + for (i__ = j; i__ <= i__2; ++i__) { |
3403 | + c__[i__ + j * c_dim1] = 0.; |
3404 | +/* L50: */ |
3405 | + } |
3406 | +/* L60: */ |
3407 | + } |
3408 | + } else { |
3409 | + i__1 = *n; |
3410 | + for (j = 1; j <= i__1; ++j) { |
3411 | + i__2 = *n; |
3412 | + for (i__ = j; i__ <= i__2; ++i__) { |
3413 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; |
3414 | +/* L70: */ |
3415 | + } |
3416 | +/* L80: */ |
3417 | + } |
3418 | + } |
3419 | + } |
3420 | + return 0; |
3421 | + } |
3422 | + |
3423 | +/* Start the operations. */ |
3424 | + |
3425 | + if (lsame_(trans, "N")) { |
3426 | + |
3427 | +/* Form C := alpha*A*B' + alpha*B*A' + C. */ |
3428 | + |
3429 | + if (upper) { |
3430 | + i__1 = *n; |
3431 | + for (j = 1; j <= i__1; ++j) { |
3432 | + if (*beta == 0.) { |
3433 | + i__2 = j; |
3434 | + for (i__ = 1; i__ <= i__2; ++i__) { |
3435 | + c__[i__ + j * c_dim1] = 0.; |
3436 | +/* L90: */ |
3437 | + } |
3438 | + } else if (*beta != 1.) { |
3439 | + i__2 = j; |
3440 | + for (i__ = 1; i__ <= i__2; ++i__) { |
3441 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; |
3442 | +/* L100: */ |
3443 | + } |
3444 | + } |
3445 | + i__2 = *k; |
3446 | + for (l = 1; l <= i__2; ++l) { |
3447 | + if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { |
3448 | + temp1 = *alpha * b[j + l * b_dim1]; |
3449 | + temp2 = *alpha * a[j + l * a_dim1]; |
3450 | + i__3 = j; |
3451 | + for (i__ = 1; i__ <= i__3; ++i__) { |
3452 | + c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ |
3453 | + i__ + l * a_dim1] * temp1 + b[i__ + l * |
3454 | + b_dim1] * temp2; |
3455 | +/* L110: */ |
3456 | + } |
3457 | + } |
3458 | +/* L120: */ |
3459 | + } |
3460 | +/* L130: */ |
3461 | + } |
3462 | + } else { |
3463 | + i__1 = *n; |
3464 | + for (j = 1; j <= i__1; ++j) { |
3465 | + if (*beta == 0.) { |
3466 | + i__2 = *n; |
3467 | + for (i__ = j; i__ <= i__2; ++i__) { |
3468 | + c__[i__ + j * c_dim1] = 0.; |
3469 | +/* L140: */ |
3470 | + } |
3471 | + } else if (*beta != 1.) { |
3472 | + i__2 = *n; |
3473 | + for (i__ = j; i__ <= i__2; ++i__) { |
3474 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; |
3475 | +/* L150: */ |
3476 | + } |
3477 | + } |
3478 | + i__2 = *k; |
3479 | + for (l = 1; l <= i__2; ++l) { |
3480 | + if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { |
3481 | + temp1 = *alpha * b[j + l * b_dim1]; |
3482 | + temp2 = *alpha * a[j + l * a_dim1]; |
3483 | + i__3 = *n; |
3484 | + for (i__ = j; i__ <= i__3; ++i__) { |
3485 | + c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ |
3486 | + i__ + l * a_dim1] * temp1 + b[i__ + l * |
3487 | + b_dim1] * temp2; |
3488 | +/* L160: */ |
3489 | + } |
3490 | + } |
3491 | +/* L170: */ |
3492 | + } |
3493 | +/* L180: */ |
3494 | + } |
3495 | + } |
3496 | + } else { |
3497 | + |
3498 | +/* Form C := alpha*A'*B + alpha*B'*A + C. */ |
3499 | + |
3500 | + if (upper) { |
3501 | + i__1 = *n; |
3502 | + for (j = 1; j <= i__1; ++j) { |
3503 | + i__2 = j; |
3504 | + for (i__ = 1; i__ <= i__2; ++i__) { |
3505 | + temp1 = 0.; |
3506 | + temp2 = 0.; |
3507 | + i__3 = *k; |
3508 | + for (l = 1; l <= i__3; ++l) { |
3509 | + temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; |
3510 | + temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; |
3511 | +/* L190: */ |
3512 | + } |
3513 | + if (*beta == 0.) { |
3514 | + c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * |
3515 | + temp2; |
3516 | + } else { |
3517 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] |
3518 | + + *alpha * temp1 + *alpha * temp2; |
3519 | + } |
3520 | +/* L200: */ |
3521 | + } |
3522 | +/* L210: */ |
3523 | + } |
3524 | + } else { |
3525 | + i__1 = *n; |
3526 | + for (j = 1; j <= i__1; ++j) { |
3527 | + i__2 = *n; |
3528 | + for (i__ = j; i__ <= i__2; ++i__) { |
3529 | + temp1 = 0.; |
3530 | + temp2 = 0.; |
3531 | + i__3 = *k; |
3532 | + for (l = 1; l <= i__3; ++l) { |
3533 | + temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; |
3534 | + temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; |
3535 | +/* L220: */ |
3536 | + } |
3537 | + if (*beta == 0.) { |
3538 | + c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * |
3539 | + temp2; |
3540 | + } else { |
3541 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] |
3542 | + + *alpha * temp1 + *alpha * temp2; |
3543 | + } |
3544 | +/* L230: */ |
3545 | + } |
3546 | +/* L240: */ |
3547 | + } |
3548 | + } |
3549 | + } |
3550 | + |
3551 | + return 0; |
3552 | + |
3553 | +/* End of DSYR2K. */ |
3554 | + |
3555 | +} /* dsyr2k_ */ |
3556 | + |
3557 | +/* Subroutine */ int dsyrk_(char *uplo, char *trans, integer *n, integer *k, |
3558 | + doublereal *alpha, doublereal *a, integer *lda, doublereal *beta, |
3559 | + doublereal *c__, integer *ldc) |
3560 | +{ |
3561 | + /* System generated locals */ |
3562 | + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; |
3563 | + |
3564 | + /* Local variables */ |
3565 | + static integer info; |
3566 | + static doublereal temp; |
3567 | + static integer i__, j, l; |
3568 | + extern logical lsame_(char *, char *); |
3569 | + static integer nrowa; |
3570 | + static logical upper; |
3571 | + extern /* Subroutine */ int xerbla_(char *, integer *); |
3572 | + |
3573 | + |
3574 | +/* |
3575 | + Purpose |
3576 | + ======= |
3577 | + |
3578 | + DSYRK performs one of the symmetric rank k operations |
3579 | + |
3580 | + C := alpha*A*A' + beta*C, |
3581 | + |
3582 | + or |
3583 | + |
3584 | + C := alpha*A'*A + beta*C, |
3585 | + |
3586 | + where alpha and beta are scalars, C is an n by n symmetric matrix |
3587 | + and A is an n by k matrix in the first case and a k by n matrix |
3588 | + in the second case. |
3589 | + |
3590 | + Arguments |
3591 | + ========== |
3592 | + |
3593 | + UPLO - CHARACTER*1. |
3594 | + On entry, UPLO specifies whether the upper or lower |
3595 | + triangular part of the array C is to be referenced as |
3596 | + follows: |
3597 | + |
3598 | + UPLO = 'U' or 'u' Only the upper triangular part of C |
3599 | + is to be referenced. |
3600 | + |
3601 | + UPLO = 'L' or 'l' Only the lower triangular part of C |
3602 | + is to be referenced. |
3603 | + |
3604 | + Unchanged on exit. |
3605 | + |
3606 | + TRANS - CHARACTER*1. |
3607 | + On entry, TRANS specifies the operation to be performed as |
3608 | + follows: |
3609 | + |
3610 | + TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. |
3611 | + |
3612 | + TRANS = 'T' or 't' C := alpha*A'*A + beta*C. |
3613 | + |
3614 | + TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. |
3615 | + |
3616 | + Unchanged on exit. |
3617 | + |
3618 | + N - INTEGER. |
3619 | + On entry, N specifies the order of the matrix C. N must be |
3620 | + at least zero. |
3621 | + Unchanged on exit. |
3622 | + |
3623 | + K - INTEGER. |
3624 | + On entry with TRANS = 'N' or 'n', K specifies the number |
3625 | + of columns of the matrix A, and on entry with |
3626 | + TRANS = 'T' or 't' or 'C' or 'c', K specifies the number |
3627 | + of rows of the matrix A. K must be at least zero. |
3628 | + Unchanged on exit. |
3629 | + |
3630 | + ALPHA - DOUBLE PRECISION. |
3631 | + On entry, ALPHA specifies the scalar alpha. |
3632 | + Unchanged on exit. |
3633 | + |
3634 | + A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is |
3635 | + k when TRANS = 'N' or 'n', and is n otherwise. |
3636 | + Before entry with TRANS = 'N' or 'n', the leading n by k |
3637 | + part of the array A must contain the matrix A, otherwise |
3638 | + the leading k by n part of the array A must contain the |
3639 | + matrix A. |
3640 | + Unchanged on exit. |
3641 | + |
3642 | + LDA - INTEGER. |
3643 | + On entry, LDA specifies the first dimension of A as declared |
3644 | + in the calling (sub) program. When TRANS = 'N' or 'n' |
3645 | + then LDA must be at least max( 1, n ), otherwise LDA must |
3646 | + be at least max( 1, k ). |
3647 | + Unchanged on exit. |
3648 | + |
3649 | + BETA - DOUBLE PRECISION. |
3650 | + On entry, BETA specifies the scalar beta. |
3651 | + Unchanged on exit. |
3652 | + |
3653 | + C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). |
3654 | + Before entry with UPLO = 'U' or 'u', the leading n by n |
3655 | + upper triangular part of the array C must contain the upper |
3656 | + triangular part of the symmetric matrix and the strictly |
3657 | + lower triangular part of C is not referenced. On exit, the |
3658 | + upper triangular part of the array C is overwritten by the |
3659 | + upper triangular part of the updated matrix. |
3660 | + Before entry with UPLO = 'L' or 'l', the leading n by n |
3661 | + lower triangular part of the array C must contain the lower |
3662 | + triangular part of the symmetric matrix and the strictly |
3663 | + upper triangular part of C is not referenced. On exit, the |
3664 | + lower triangular part of the array C is overwritten by the |
3665 | + lower triangular part of the updated matrix. |
3666 | + |
3667 | + LDC - INTEGER. |
3668 | + On entry, LDC specifies the first dimension of C as declared |
3669 | + in the calling (sub) program. LDC must be at least |
3670 | + max( 1, n ). |
3671 | + Unchanged on exit. |
3672 | + |
3673 | + |
3674 | + Level 3 Blas routine. |
3675 | + |
3676 | + -- Written on 8-February-1989. |
3677 | + Jack Dongarra, Argonne National Laboratory. |
3678 | + Iain Duff, AERE Harwell. |
3679 | + Jeremy Du Croz, Numerical Algorithms Group Ltd. |
3680 | + Sven Hammarling, Numerical Algorithms Group Ltd. |
3681 | + |
3682 | + |
3683 | + Test the input parameters. |
3684 | +*/ |
3685 | + |
3686 | + /* Parameter adjustments */ |
3687 | + a_dim1 = *lda; |
3688 | + a_offset = 1 + a_dim1 * 1; |
3689 | + a -= a_offset; |
3690 | + c_dim1 = *ldc; |
3691 | + c_offset = 1 + c_dim1 * 1; |
3692 | + c__ -= c_offset; |
3693 | + |
3694 | + /* Function Body */ |
3695 | + if (lsame_(trans, "N")) { |
3696 | + nrowa = *n; |
3697 | + } else { |
3698 | + nrowa = *k; |
3699 | + } |
3700 | + upper = lsame_(uplo, "U"); |
3701 | + |
3702 | + info = 0; |
3703 | + if (! upper && ! lsame_(uplo, "L")) { |
3704 | + info = 1; |
3705 | + } else if (! lsame_(trans, "N") && ! lsame_(trans, |
3706 | + "T") && ! lsame_(trans, "C")) { |
3707 | + info = 2; |
3708 | + } else if (*n < 0) { |
3709 | + info = 3; |
3710 | + } else if (*k < 0) { |
3711 | + info = 4; |
3712 | + } else if (*lda < max(1,nrowa)) { |
3713 | + info = 7; |
3714 | + } else if (*ldc < max(1,*n)) { |
3715 | + info = 10; |
3716 | + } |
3717 | + if (info != 0) { |
3718 | + xerbla_("DSYRK ", &info); |
3719 | + return 0; |
3720 | + } |
3721 | + |
3722 | +/* Quick return if possible. */ |
3723 | + |
3724 | + if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { |
3725 | + return 0; |
3726 | + } |
3727 | + |
3728 | +/* And when alpha.eq.zero. */ |
3729 | + |
3730 | + if (*alpha == 0.) { |
3731 | + if (upper) { |
3732 | + if (*beta == 0.) { |
3733 | + i__1 = *n; |
3734 | + for (j = 1; j <= i__1; ++j) { |
3735 | + i__2 = j; |
3736 | + for (i__ = 1; i__ <= i__2; ++i__) { |
3737 | + c__[i__ + j * c_dim1] = 0.; |
3738 | +/* L10: */ |
3739 | + } |
3740 | +/* L20: */ |
3741 | + } |
3742 | + } else { |
3743 | + i__1 = *n; |
3744 | + for (j = 1; j <= i__1; ++j) { |
3745 | + i__2 = j; |
3746 | + for (i__ = 1; i__ <= i__2; ++i__) { |
3747 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; |
3748 | +/* L30: */ |
3749 | + } |
3750 | +/* L40: */ |
3751 | + } |
3752 | + } |
3753 | + } else { |
3754 | + if (*beta == 0.) { |
3755 | + i__1 = *n; |
3756 | + for (j = 1; j <= i__1; ++j) { |
3757 | + i__2 = *n; |
3758 | + for (i__ = j; i__ <= i__2; ++i__) { |
3759 | + c__[i__ + j * c_dim1] = 0.; |
3760 | +/* L50: */ |
3761 | + } |
3762 | +/* L60: */ |
3763 | + } |
3764 | + } else { |
3765 | + i__1 = *n; |
3766 | + for (j = 1; j <= i__1; ++j) { |
3767 | + i__2 = *n; |
3768 | + for (i__ = j; i__ <= i__2; ++i__) { |
3769 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; |
3770 | +/* L70: */ |
3771 | + } |
3772 | +/* L80: */ |
3773 | + } |
3774 | + } |
3775 | + } |
3776 | + return 0; |
3777 | + } |
3778 | + |
3779 | +/* Start the operations. */ |
3780 | + |
3781 | + if (lsame_(trans, "N")) { |
3782 | + |
3783 | +/* Form C := alpha*A*A' + beta*C. */ |
3784 | + |
3785 | + if (upper) { |
3786 | + i__1 = *n; |
3787 | + for (j = 1; j <= i__1; ++j) { |
3788 | + if (*beta == 0.) { |
3789 | + i__2 = j; |
3790 | + for (i__ = 1; i__ <= i__2; ++i__) { |
3791 | + c__[i__ + j * c_dim1] = 0.; |
3792 | +/* L90: */ |
3793 | + } |
3794 | + } else if (*beta != 1.) { |
3795 | + i__2 = j; |
3796 | + for (i__ = 1; i__ <= i__2; ++i__) { |
3797 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; |
3798 | +/* L100: */ |
3799 | + } |
3800 | + } |
3801 | + i__2 = *k; |
3802 | + for (l = 1; l <= i__2; ++l) { |
3803 | + if (a[j + l * a_dim1] != 0.) { |
3804 | + temp = *alpha * a[j + l * a_dim1]; |
3805 | + i__3 = j; |
3806 | + for (i__ = 1; i__ <= i__3; ++i__) { |
3807 | + c__[i__ + j * c_dim1] += temp * a[i__ + l * |
3808 | + a_dim1]; |
3809 | +/* L110: */ |
3810 | + } |
3811 | + } |
3812 | +/* L120: */ |
3813 | + } |
3814 | +/* L130: */ |
3815 | + } |
3816 | + } else { |
3817 | + i__1 = *n; |
3818 | + for (j = 1; j <= i__1; ++j) { |
3819 | + if (*beta == 0.) { |
3820 | + i__2 = *n; |
3821 | + for (i__ = j; i__ <= i__2; ++i__) { |
3822 | + c__[i__ + j * c_dim1] = 0.; |
3823 | +/* L140: */ |
3824 | + } |
3825 | + } else if (*beta != 1.) { |
3826 | + i__2 = *n; |
3827 | + for (i__ = j; i__ <= i__2; ++i__) { |
3828 | + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; |
3829 | +/* L150: */ |
3830 | + } |
3831 | + } |
3832 | + i__2 = *k; |
3833 | + for (l = 1; l <= i__2; ++l) { |
3834 | + if (a[j + l * a_dim1] != 0.) { |
3835 | + temp = *alpha * a[j + l * a_dim1]; |
3836 | + i__3 = *n; |
3837 | + for (i__ = j; i__ <= i__3; ++i__) { |
3838 | + c__[i__ + j * c_dim1] += temp * a[i__ + l * |
3839 | + a_dim1]; |
3840 | +/* L160: */ |
3841 | + } |
3842 | + } |
3843 | +/* L170: */ |
3844 | + } |
3845 | +/* L180: */ |
3846 | + } |
3847 | + } |
3848 | + } else { |
3849 | + |
3850 | +/* Form C := alpha*A'*A + beta*C. */ |
3851 | + |
3852 | + if (upper) { |
3853 | + i__1 = *n; |
3854 | + for (j = 1; j <= i__1; ++j) { |
3855 | + i__2 = j; |
3856 | + for (i__ = 1; i__ <= i__2; ++i__) { |
3857 | + temp = 0.; |
3858 | + i__3 = *k; |
3859 | + for (l = 1; l <= i__3; ++l) { |
3860 | + temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; |
3861 | +/* L190: */ |
3862 | + } |
3863 | + if (*beta == 0.) { |
3864 | + c__[i__ + j * c_dim1] = *alpha * temp; |
3865 | + } else { |
3866 | + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ |
3867 | + i__ + j * c_dim1]; |
3868 | + } |
3869 | +/* L200: */ |
3870 | + } |
3871 | +/* L210: */ |
3872 | + } |
3873 | + } else { |
3874 | + i__1 = *n; |
3875 | + for (j = 1; j <= i__1; ++j) { |
3876 | + i__2 = *n; |
3877 | + for (i__ = j; i__ <= i__2; ++i__) { |
3878 | + temp = 0.; |
3879 | + i__3 = *k; |
3880 | + for (l = 1; l <= i__3; ++l) { |
3881 | + temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; |
3882 | +/* L220: */ |
3883 | + } |
3884 | + if (*beta == 0.) { |
3885 | + c__[i__ + j * c_dim1] = *alpha * temp; |
3886 | + } else { |
3887 | + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ |
3888 | + i__ + j * c_dim1]; |
3889 | + } |
3890 | +/* L230: */ |
3891 | + } |
3892 | +/* L240: */ |
3893 | + } |
3894 | + } |
3895 | + } |
3896 | + |
3897 | + return 0; |
3898 | + |
3899 | +/* End of DSYRK . */ |
3900 | + |
3901 | +} /* dsyrk_ */ |
3902 | + |
3903 | +/* Subroutine */ int dtrmm_(char *side, char *uplo, char *transa, char *diag, |
3904 | + integer *m, integer *n, doublereal *alpha, doublereal *a, integer * |
3905 | + lda, doublereal *b, integer *ldb) |
3906 | +{ |
3907 | + /* System generated locals */ |
3908 | + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; |
3909 | + |
3910 | + /* Local variables */ |
3911 | + static integer info; |
3912 | + static doublereal temp; |
3913 | + static integer i__, j, k; |
3914 | + static logical lside; |
3915 | + extern logical lsame_(char *, char *); |
3916 | + static integer nrowa; |
3917 | + static logical upper; |
3918 | + extern /* Subroutine */ int xerbla_(char *, integer *); |
3919 | + static logical nounit; |
3920 | + |
3921 | + |
3922 | +/* |
3923 | + Purpose |
3924 | + ======= |
3925 | + |
3926 | + DTRMM performs one of the matrix-matrix operations |
3927 | + |
3928 | + B := alpha*op( A )*B, or B := alpha*B*op( A ), |
3929 | + |
3930 | + where alpha is a scalar, B is an m by n matrix, A is a unit, or |
3931 | + non-unit, upper or lower triangular matrix and op( A ) is one of |
3932 | + |
3933 | + op( A ) = A or op( A ) = A'. |
3934 | + |
3935 | + Arguments |
3936 | + ========== |
3937 | + |
3938 | + SIDE - CHARACTER*1. |
3939 | + On entry, SIDE specifies whether op( A ) multiplies B from |
3940 | + the left or right as follows: |
3941 | + |
3942 | + SIDE = 'L' or 'l' B := alpha*op( A )*B. |
3943 | + |
3944 | + SIDE = 'R' or 'r' B := alpha*B*op( A ). |
3945 | + |
3946 | + Unchanged on exit. |
3947 | + |
3948 | + UPLO - CHARACTER*1. |
3949 | + On entry, UPLO specifies whether the matrix A is an upper or |
3950 | + lower triangular matrix as follows: |
3951 | + |
3952 | + UPLO = 'U' or 'u' A is an upper triangular matrix. |
3953 | + |
3954 | + UPLO = 'L' or 'l' A is a lower triangular matrix. |
3955 | + |
3956 | + Unchanged on exit. |
3957 | + |
3958 | + TRANSA - CHARACTER*1. |
3959 | + On entry, TRANSA specifies the form of op( A ) to be used in |
3960 | + the matrix multiplication as follows: |
3961 | + |
3962 | + TRANSA = 'N' or 'n' op( A ) = A. |
3963 | + |
3964 | + TRANSA = 'T' or 't' op( A ) = A'. |
3965 | + |
3966 | + TRANSA = 'C' or 'c' op( A ) = A'. |
3967 | + |
3968 | + Unchanged on exit. |
3969 | + |
3970 | + DIAG - CHARACTER*1. |
3971 | + On entry, DIAG specifies whether or not A is unit triangular |
3972 | + as follows: |
3973 | + |
3974 | + DIAG = 'U' or 'u' A is assumed to be unit triangular. |
3975 | + |
3976 | + DIAG = 'N' or 'n' A is not assumed to be unit |
3977 | + triangular. |
3978 | + |
3979 | + Unchanged on exit. |
3980 | + |
3981 | + M - INTEGER. |
3982 | + On entry, M specifies the number of rows of B. M must be at |
3983 | + least zero. |
3984 | + Unchanged on exit. |
3985 | + |
3986 | + N - INTEGER. |
3987 | + On entry, N specifies the number of columns of B. N must be |
3988 | + at least zero. |
3989 | + Unchanged on exit. |
3990 | + |
3991 | + ALPHA - DOUBLE PRECISION. |
3992 | + On entry, ALPHA specifies the scalar alpha. When alpha is |
3993 | + zero then A is not referenced and B need not be set before |
3994 | + entry. |
3995 | + Unchanged on exit. |
3996 | + |
3997 | + A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m |
3998 | + when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. |
3999 | + Before entry with UPLO = 'U' or 'u', the leading k by k |
4000 | + upper triangular part of the array A must contain the upper |
4001 | + triangular matrix and the strictly lower triangular part of |
4002 | + A is not referenced. |
4003 | + Before entry with UPLO = 'L' or 'l', the leading k by k |
4004 | + lower triangular part of the array A must contain the lower |
4005 | + triangular matrix and the strictly upper triangular part of |
4006 | + A is not referenced. |
4007 | + Note that when DIAG = 'U' or 'u', the diagonal elements of |
4008 | + A are not referenced either, but are assumed to be unity. |
4009 | + Unchanged on exit. |
4010 | + |
4011 | + LDA - INTEGER. |
4012 | + On entry, LDA specifies the first dimension of A as declared |
4013 | + in the calling (sub) program. When SIDE = 'L' or 'l' then |
4014 | + LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' |
4015 | + then LDA must be at least max( 1, n ). |
4016 | + Unchanged on exit. |
4017 | + |
4018 | + B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). |
4019 | + Before entry, the leading m by n part of the array B must |
4020 | + contain the matrix B, and on exit is overwritten by the |
4021 | + transformed matrix. |
4022 | + |
4023 | + LDB - INTEGER. |
4024 | + On entry, LDB specifies the first dimension of B as declared |
4025 | + in the calling (sub) program. LDB must be at least |
4026 | + max( 1, m ). |
4027 | + Unchanged on exit. |
4028 | + |
4029 | + |
4030 | + Level 3 Blas routine. |
4031 | + |
4032 | + -- Written on 8-February-1989. |
4033 | + Jack Dongarra, Argonne National Laboratory. |
4034 | + Iain Duff, AERE Harwell. |
4035 | + Jeremy Du Croz, Numerical Algorithms Group Ltd. |
4036 | + Sven Hammarling, Numerical Algorithms Group Ltd. |
4037 | + |
4038 | + |
4039 | + Test the input parameters. |
4040 | +*/ |
4041 | + |
4042 | + /* Parameter adjustments */ |
4043 | + a_dim1 = *lda; |
4044 | + a_offset = 1 + a_dim1 * 1; |
4045 | + a -= a_offset; |
4046 | + b_dim1 = *ldb; |
4047 | + b_offset = 1 + b_dim1 * 1; |
4048 | + b -= b_offset; |
4049 | + |
4050 | + /* Function Body */ |
4051 | + lside = lsame_(side, "L"); |
4052 | + if (lside) { |
4053 | + nrowa = *m; |
4054 | + } else { |
4055 | + nrowa = *n; |
4056 | + } |
4057 | + nounit = lsame_(diag, "N"); |
4058 | + upper = lsame_(uplo, "U"); |
4059 | + |
4060 | + info = 0; |
4061 | + if (! lside && ! lsame_(side, "R")) { |
4062 | + info = 1; |
4063 | + } else if (! upper && ! lsame_(uplo, "L")) { |
4064 | + info = 2; |
4065 | + } else if (! lsame_(transa, "N") && ! lsame_(transa, |
4066 | + "T") && ! lsame_(transa, "C")) { |
4067 | + info = 3; |
4068 | + } else if (! lsame_(diag, "U") && ! lsame_(diag, |
4069 | + "N")) { |
4070 | + info = 4; |
4071 | + } else if (*m < 0) { |
4072 | + info = 5; |
4073 | + } else if (*n < 0) { |
4074 | + info = 6; |
4075 | + } else if (*lda < max(1,nrowa)) { |
4076 | + info = 9; |
4077 | + } else if (*ldb < max(1,*m)) { |
4078 | + info = 11; |
4079 | + } |
4080 | + if (info != 0) { |
4081 | + xerbla_("DTRMM ", &info); |
4082 | + return 0; |
4083 | + } |
4084 | + |
4085 | +/* Quick return if possible. */ |
4086 | + |
4087 | + if (*n == 0) { |
4088 | + return 0; |
4089 | + } |
4090 | + |
4091 | +/* And when alpha.eq.zero. */ |
4092 | + |
4093 | + if (*alpha == 0.) { |
4094 | + i__1 = *n; |
4095 | + for (j = 1; j <= i__1; ++j) { |
4096 | + i__2 = *m; |
4097 | + for (i__ = 1; i__ <= i__2; ++i__) { |
4098 | + b[i__ + j * b_dim1] = 0.; |
4099 | +/* L10: */ |
4100 | + } |
4101 | +/* L20: */ |
4102 | + } |
4103 | + return 0; |
4104 | + } |
4105 | + |
4106 | +/* Start the operations. */ |
4107 | + |
4108 | + if (lside) { |
4109 | + if (lsame_(transa, "N")) { |
4110 | + |
4111 | +/* Form B := alpha*A*B. */ |
4112 | + |
4113 | + if (upper) { |
4114 | + i__1 = *n; |
4115 | + for (j = 1; j <= i__1; ++j) { |
4116 | + i__2 = *m; |
4117 | + for (k = 1; k <= i__2; ++k) { |
4118 | + if (b[k + j * b_dim1] != 0.) { |
4119 | + temp = *alpha * b[k + j * b_dim1]; |
4120 | + i__3 = k - 1; |
4121 | + for (i__ = 1; i__ <= i__3; ++i__) { |
4122 | + b[i__ + j * b_dim1] += temp * a[i__ + k * |
4123 | + a_dim1]; |
4124 | +/* L30: */ |
4125 | + } |
4126 | + if (nounit) { |
4127 | + temp *= a[k + k * a_dim1]; |
4128 | + } |
4129 | + b[k + j * b_dim1] = temp; |
4130 | + } |
4131 | +/* L40: */ |
4132 | + } |
4133 | +/* L50: */ |
4134 | + } |
4135 | + } else { |
4136 | + i__1 = *n; |
4137 | + for (j = 1; j <= i__1; ++j) { |
4138 | + for (k = *m; k >= 1; --k) { |
4139 | + if (b[k + j * b_dim1] != 0.) { |
4140 | + temp = *alpha * b[k + j * b_dim1]; |
4141 | + b[k + j * b_dim1] = temp; |
4142 | + if (nounit) { |
4143 | + b[k + j * b_dim1] *= a[k + k * a_dim1]; |
4144 | + } |
4145 | + i__2 = *m; |
4146 | + for (i__ = k + 1; i__ <= i__2; ++i__) { |
4147 | + b[i__ + j * b_dim1] += temp * a[i__ + k * |
4148 | + a_dim1]; |
4149 | +/* L60: */ |
4150 | + } |
4151 | + } |
4152 | +/* L70: */ |
4153 | + } |
4154 | +/* L80: */ |
4155 | + } |
4156 | + } |
4157 | + } else { |
4158 | + |
4159 | +/* Form B := alpha*A'*B. */ |
4160 | + |
4161 | + if (upper) { |
4162 | + i__1 = *n; |
4163 | + for (j = 1; j <= i__1; ++j) { |
4164 | + for (i__ = *m; i__ >= 1; --i__) { |
4165 | + temp = b[i__ + j * b_dim1]; |
4166 | + if (nounit) { |
4167 | + temp *= a[i__ + i__ * a_dim1]; |
4168 | + } |
4169 | + i__2 = i__ - 1; |
4170 | + for (k = 1; k <= i__2; ++k) { |
4171 | + temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; |
4172 | +/* L90: */ |
4173 | + } |
4174 | + b[i__ + j * b_dim1] = *alpha * temp; |
4175 | +/* L100: */ |
4176 | + } |
4177 | +/* L110: */ |
4178 | + } |
4179 | + } else { |
4180 | + i__1 = *n; |
4181 | + for (j = 1; j <= i__1; ++j) { |
4182 | + i__2 = *m; |
4183 | + for (i__ = 1; i__ <= i__2; ++i__) { |
4184 | + temp = b[i__ + j * b_dim1]; |
4185 | + if (nounit) { |
4186 | + temp *= a[i__ + i__ * a_dim1]; |
4187 | + } |
4188 | + i__3 = *m; |
4189 | + for (k = i__ + 1; k <= i__3; ++k) { |
4190 | + temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; |
4191 | +/* L120: */ |
4192 | + } |
4193 | + b[i__ + j * b_dim1] = *alpha * temp; |
4194 | +/* L130: */ |
4195 | + } |
4196 | +/* L140: */ |
4197 | + } |
4198 | + } |
4199 | + } |
4200 | + } else { |
4201 | + if (lsame_(transa, "N")) { |
4202 | + |
4203 | +/* Form B := alpha*B*A. */ |
4204 | + |
4205 | + if (upper) { |
4206 | + for (j = *n; j >= 1; --j) { |
4207 | + temp = *alpha; |
4208 | + if (nounit) { |
4209 | + temp *= a[j + j * a_dim1]; |
4210 | + } |
4211 | + i__1 = *m; |
4212 | + for (i__ = 1; i__ <= i__1; ++i__) { |
4213 | + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; |
4214 | +/* L150: */ |
4215 | + } |
4216 | + i__1 = j - 1; |
4217 | + for (k = 1; k <= i__1; ++k) { |
4218 | + if (a[k + j * a_dim1] != 0.) { |
4219 | + temp = *alpha * a[k + j * a_dim1]; |
4220 | + i__2 = *m; |
4221 | + for (i__ = 1; i__ <= i__2; ++i__) { |
4222 | + b[i__ + j * b_dim1] += temp * b[i__ + k * |
4223 | + b_dim1]; |
4224 | +/* L160: */ |
4225 | + } |
4226 | + } |
4227 | +/* L170: */ |
4228 | + } |
4229 | +/* L180: */ |
4230 | + } |
4231 | + } else { |
4232 | + i__1 = *n; |
4233 | + for (j = 1; j <= i__1; ++j) { |
4234 | + temp = *alpha; |
4235 | + if (nounit) { |
4236 | + temp *= a[j + j * a_dim1]; |
4237 | + } |
4238 | + i__2 = *m; |
4239 | + for (i__ = 1; i__ <= i__2; ++i__) { |
4240 | + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; |
4241 | +/* L190: */ |
4242 | + } |
4243 | + i__2 = *n; |
4244 | + for (k = j + 1; k <= i__2; ++k) { |
4245 | + if (a[k + j * a_dim1] != 0.) { |
4246 | + temp = *alpha * a[k + j * a_dim1]; |
4247 | + i__3 = *m; |
4248 | + for (i__ = 1; i__ <= i__3; ++i__) { |
4249 | + b[i__ + j * b_dim1] += temp * b[i__ + k * |
4250 | + b_dim1]; |
4251 | +/* L200: */ |
4252 | + } |
4253 | + } |
4254 | +/* L210: */ |
4255 | + } |
4256 | +/* L220: */ |
4257 | + } |
4258 | + } |
4259 | + } else { |
4260 | + |
4261 | +/* Form B := alpha*B*A'. */ |
4262 | + |
4263 | + if (upper) { |
4264 | + i__1 = *n; |
4265 | + for (k = 1; k <= i__1; ++k) { |
4266 | + i__2 = k - 1; |
4267 | + for (j = 1; j <= i__2; ++j) { |
4268 | + if (a[j + k * a_dim1] != 0.) { |
4269 | + temp = *alpha * a[j + k * a_dim1]; |
4270 | + i__3 = *m; |
4271 | + for (i__ = 1; i__ <= i__3; ++i__) { |
4272 | + b[i__ + j * b_dim1] += temp * b[i__ + k * |
4273 | + b_dim1]; |
4274 | +/* L230: */ |
4275 | + } |
4276 | + } |
4277 | +/* L240: */ |
4278 | + } |
4279 | + temp = *alpha; |
4280 | + if (nounit) { |
4281 | + temp *= a[k + k * a_dim1]; |
4282 | + } |
4283 | + if (temp != 1.) { |
4284 | + i__2 = *m; |
4285 | + for (i__ = 1; i__ <= i__2; ++i__) { |
4286 | + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; |
4287 | +/* L250: */ |
4288 | + } |
4289 | + } |
4290 | +/* L260: */ |
4291 | + } |
4292 | + } else { |
4293 | + for (k = *n; k >= 1; --k) { |
4294 | + i__1 = *n; |
4295 | + for (j = k + 1; j <= i__1; ++j) { |
4296 | + if (a[j + k * a_dim1] != 0.) { |
4297 | + temp = *alpha * a[j + k * a_dim1]; |
4298 | + i__2 = *m; |
4299 | + for (i__ = 1; i__ <= i__2; ++i__) { |
4300 | + b[i__ + j * b_dim1] += temp * b[i__ + k * |
4301 | + b_dim1]; |
4302 | +/* L270: */ |
4303 | + } |
4304 | + } |
4305 | +/* L280: */ |
4306 | + } |
4307 | + temp = *alpha; |
4308 | + if (nounit) { |
4309 | + temp *= a[k + k * a_dim1]; |
4310 | + } |
4311 | + if (temp != 1.) { |
4312 | + i__1 = *m; |
4313 | + for (i__ = 1; i__ <= i__1; ++i__) { |
4314 | + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; |
4315 | +/* L290: */ |
4316 | + } |
4317 | + } |
4318 | +/* L300: */ |
4319 | + } |
4320 | + } |
4321 | + } |
4322 | + } |
4323 | + |
4324 | + return 0; |
4325 | + |
4326 | +/* End of DTRMM . */ |
4327 | + |
4328 | +} /* dtrmm_ */ |
4329 | + |
4330 | +/* Subroutine */ int dtrmv_(char *uplo, char *trans, char *diag, integer *n, |
4331 | + doublereal *a, integer *lda, doublereal *x, integer *incx) |
4332 | +{ |
4333 | + /* System generated locals */ |
4334 | + integer a_dim1, a_offset, i__1, i__2; |
4335 | + |
4336 | + /* Local variables */ |
4337 | + static integer info; |
4338 | + static doublereal temp; |
4339 | + static integer i__, j; |
4340 | + extern logical lsame_(char *, char *); |
4341 | + static integer ix, jx, kx; |
4342 | + extern /* Subroutine */ int xerbla_(char *, integer *); |
4343 | + static logical nounit; |
4344 | + |
4345 | + |
4346 | +/* |
4347 | + Purpose |
4348 | + ======= |
4349 | + |
4350 | + DTRMV performs one of the matrix-vector operations |
4351 | + |
4352 | + x := A*x, or x := A'*x, |
4353 | + |
4354 | + where x is an n element vector and A is an n by n unit, or non-unit, |
4355 | + upper or lower triangular matrix. |
4356 | + |
4357 | + Arguments |
4358 | + ========== |
4359 | + |
4360 | + UPLO - CHARACTER*1. |
4361 | + On entry, UPLO specifies whether the matrix is an upper or |
4362 | + lower triangular matrix as follows: |
4363 | + |
4364 | + UPLO = 'U' or 'u' A is an upper triangular matrix. |
4365 | + |
4366 | + UPLO = 'L' or 'l' A is a lower triangular matrix. |
4367 | + |
4368 | + Unchanged on exit. |
4369 | + |
4370 | + TRANS - CHARACTER*1. |
4371 | + On entry, TRANS specifies the operation to be performed as |
4372 | + follows: |
4373 | + |
4374 | + TRANS = 'N' or 'n' x := A*x. |
4375 | + |
4376 | + TRANS = 'T' or 't' x := A'*x. |
4377 | + |
4378 | + TRANS = 'C' or 'c' x := A'*x. |
4379 | + |
4380 | + Unchanged on exit. |
4381 | + |
4382 | + DIAG - CHARACTER*1. |
4383 | + On entry, DIAG specifies whether or not A is unit |
4384 | + triangular as follows: |
4385 | + |
4386 | + DIAG = 'U' or 'u' A is assumed to be unit triangular. |
4387 | + |
4388 | + DIAG = 'N' or 'n' A is not assumed to be unit |
4389 | + triangular. |
4390 | + |
4391 | + Unchanged on exit. |
4392 | + |
4393 | + N - INTEGER. |
4394 | + On entry, N specifies the order of the matrix A. |
4395 | + N must be at least zero. |
4396 | + Unchanged on exit. |
4397 | + |
4398 | + A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). |
4399 | + Before entry with UPLO = 'U' or 'u', the leading n by n |
4400 | + upper triangular part of the array A must contain the upper |
4401 | + triangular matrix and the strictly lower triangular part of |
4402 | + A is not referenced. |
4403 | + Before entry with UPLO = 'L' or 'l', the leading n by n |
4404 | + lower triangular part of the array A must contain the lower |
4405 | + triangular matrix and the strictly upper triangular part of |
4406 | + A is not referenced. |
4407 | + Note that when DIAG = 'U' or 'u', the diagonal elements of |
4408 | + A are not referenced either, but are assumed to be unity. |
4409 | + Unchanged on exit. |
4410 | + |
4411 | + LDA - INTEGER. |
4412 | + On entry, LDA specifies the first dimension of A as declared |
4413 | + in the calling (sub) program. LDA must be at least |
4414 | + max( 1, n ). |
4415 | + Unchanged on exit. |
4416 | + |
4417 | + X - DOUBLE PRECISION array of dimension at least |
4418 | + ( 1 + ( n - 1 )*abs( INCX ) ). |
4419 | + Before entry, the incremented array X must contain the n |
4420 | + element vector x. On exit, X is overwritten with the |
4421 | + tranformed vector x. |
4422 | + |
4423 | + INCX - INTEGER. |
4424 | + On entry, INCX specifies the increment for the elements of |
4425 | + X. INCX must not be zero. |
4426 | + Unchanged on exit. |
4427 | + |
4428 | + |
4429 | + Level 2 Blas routine. |
4430 | + |
4431 | + -- Written on 22-October-1986. |
4432 | + Jack Dongarra, Argonne National Lab. |
4433 | + Jeremy Du Croz, Nag Central Office. |
4434 | + Sven Hammarling, Nag Central Office. |
4435 | + Richard Hanson, Sandia National Labs. |
4436 | + |
4437 | + |
4438 | + Test the input parameters. |
4439 | +*/ |
4440 | + |
4441 | + /* Parameter adjustments */ |
4442 | + a_dim1 = *lda; |
4443 | + a_offset = 1 + a_dim1 * 1; |
4444 | + a -= a_offset; |
4445 | + --x; |
4446 | + |
4447 | + /* Function Body */ |
4448 | + info = 0; |
4449 | + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { |
4450 | + info = 1; |
4451 | + } else if (! lsame_(trans, "N") && ! lsame_(trans, |
4452 | + "T") && ! lsame_(trans, "C")) { |
4453 | + info = 2; |
4454 | + } else if (! lsame_(diag, "U") && ! lsame_(diag, |
4455 | + "N")) { |
4456 | + info = 3; |
4457 | + } else if (*n < 0) { |
4458 | + info = 4; |
4459 | + } else if (*lda < max(1,*n)) { |
4460 | + info = 6; |
4461 | + } else if (*incx == 0) { |
4462 | + info = 8; |
4463 | + } |
4464 | + if (info != 0) { |
4465 | + xerbla_("DTRMV ", &info); |
4466 | + return 0; |
4467 | + } |
4468 | + |
4469 | +/* Quick return if possible. */ |
4470 | + |
4471 | + if (*n == 0) { |
4472 | + return 0; |
4473 | + } |
4474 | + |
4475 | + nounit = lsame_(diag, "N"); |
4476 | + |
4477 | +/* |
4478 | + Set up the start point in X if the increment is not unity. This |
4479 | + will be ( N - 1 )*INCX too small for descending loops. |
4480 | +*/ |
4481 | + |
4482 | + if (*incx <= 0) { |
4483 | + kx = 1 - (*n - 1) * *incx; |
4484 | + } else if (*incx != 1) { |
4485 | + kx = 1; |
4486 | + } |
4487 | + |
4488 | +/* |
4489 | + Start the operations. In this version the elements of A are |
4490 | + accessed sequentially with one pass through A. |
4491 | +*/ |
4492 | + |
4493 | + if (lsame_(trans, "N")) { |
4494 | + |
4495 | +/* Form x := A*x. */ |
4496 | + |
4497 | + if (lsame_(uplo, "U")) { |
4498 | + if (*incx == 1) { |
4499 | + i__1 = *n; |
4500 | + for (j = 1; j <= i__1; ++j) { |
4501 | + if (x[j] != 0.) { |
4502 | + temp = x[j]; |
4503 | + i__2 = j - 1; |
4504 | + for (i__ = 1; i__ <= i__2; ++i__) { |
4505 | + x[i__] += temp * a[i__ + j * a_dim1]; |
4506 | +/* L10: */ |
4507 | + } |
4508 | + if (nounit) { |
4509 | + x[j] *= a[j + j * a_dim1]; |
4510 | + } |
4511 | + } |
4512 | +/* L20: */ |
4513 | + } |
4514 | + } else { |
4515 | + jx = kx; |
4516 | + i__1 = *n; |
4517 | + for (j = 1; j <= i__1; ++j) { |
4518 | + if (x[jx] != 0.) { |
4519 | + temp = x[jx]; |
4520 | + ix = kx; |
4521 | + i__2 = j - 1; |
4522 | + for (i__ = 1; i__ <= i__2; ++i__) { |
4523 | + x[ix] += temp * a[i__ + j * a_dim1]; |
4524 | + ix += *incx; |
4525 | +/* L30: */ |
4526 | + } |
4527 | + if (nounit) { |
4528 | + x[jx] *= a[j + j * a_dim1]; |
4529 | + } |
4530 | + } |
4531 | + jx += *incx; |
4532 | +/* L40: */ |
4533 | + } |
4534 | + } |
4535 | + } else { |
4536 | + if (*incx == 1) { |
4537 | + for (j = *n; j >= 1; --j) { |
4538 | + if (x[j] != 0.) { |
4539 | + temp = x[j]; |
4540 | + i__1 = j + 1; |
4541 | + for (i__ = *n; i__ >= i__1; --i__) { |
4542 | + x[i__] += temp * a[i__ + j * a_dim1]; |
4543 | +/* L50: */ |
4544 | + } |
4545 | + if (nounit) { |
4546 | + x[j] *= a[j + j * a_dim1]; |
4547 | + } |
4548 | + } |
4549 | +/* L60: */ |
4550 | + } |
4551 | + } else { |
4552 | + kx += (*n - 1) * *incx; |
4553 | + jx = kx; |
4554 | + for (j = *n; j >= 1; --j) { |
4555 | + if (x[jx] != 0.) { |
4556 | + temp = x[jx]; |
4557 | + ix = kx; |
4558 | + i__1 = j + 1; |
4559 | + for (i__ = *n; i__ >= i__1; --i__) { |
4560 | + x[ix] += temp * a[i__ + j * a_dim1]; |
4561 | + ix -= *incx; |
4562 | +/* L70: */ |
4563 | + } |
4564 | + if (nounit) { |
4565 | + x[jx] *= a[j + j * a_dim1]; |
4566 | + } |
4567 | + } |
4568 | + jx -= *incx; |
4569 | +/* L80: */ |
4570 | + } |
4571 | + } |
4572 | + } |
4573 | + } else { |
4574 | + |
4575 | +/* Form x := A'*x. */ |
4576 | + |
4577 | + if (lsame_(uplo, "U")) { |
4578 | + if (*incx == 1) { |
4579 | + for (j = *n; j >= 1; --j) { |
4580 | + temp = x[j]; |
4581 | + if (nounit) { |
4582 | + temp *= a[j + j * a_dim1]; |
4583 | + } |
4584 | + for (i__ = j - 1; i__ >= 1; --i__) { |
4585 | + temp += a[i__ + j * a_dim1] * x[i__]; |
4586 | +/* L90: */ |
4587 | + } |
4588 | + x[j] = temp; |
4589 | +/* L100: */ |
4590 | + } |
4591 | + } else { |
4592 | + jx = kx + (*n - 1) * *incx; |
4593 | + for (j = *n; j >= 1; --j) { |
4594 | + temp = x[jx]; |
4595 | + ix = jx; |
4596 | + if (nounit) { |
4597 | + temp *= a[j + j * a_dim1]; |
4598 | + } |
4599 | + for (i__ = j - 1; i__ >= 1; --i__) { |
4600 | + ix -= *incx; |
4601 | + temp += a[i__ + j * a_dim1] * x[ix]; |
4602 | +/* L110: */ |
4603 | + } |
4604 | + x[jx] = temp; |
4605 | + jx -= *incx; |
4606 | +/* L120: */ |
4607 | + } |
4608 | + } |
4609 | + } else { |
4610 | + if (*incx == 1) { |
4611 | + i__1 = *n; |
4612 | + for (j = 1; j <= i__1; ++j) { |
4613 | + temp = x[j]; |
4614 | + if (nounit) { |
4615 | + temp *= a[j + j * a_dim1]; |
4616 | + } |
4617 | + i__2 = *n; |
4618 | + for (i__ = j + 1; i__ <= i__2; ++i__) { |
4619 | + temp += a[i__ + j * a_dim1] * x[i__]; |
4620 | +/* L130: */ |
4621 | + } |
4622 | + x[j] = temp; |
4623 | +/* L140: */ |
4624 | + } |
4625 | + } else { |
4626 | + jx = kx; |
4627 | + i__1 = *n; |
4628 | + for (j = 1; j <= i__1; ++j) { |
4629 | + temp = x[jx]; |
4630 | + ix = jx; |
4631 | + if (nounit) { |
4632 | + temp *= a[j + j * a_dim1]; |
4633 | + } |
4634 | + i__2 = *n; |
4635 | + for (i__ = j + 1; i__ <= i__2; ++i__) { |
4636 | + ix += *incx; |
4637 | + temp += a[i__ + j * a_dim1] * x[ix]; |
4638 | +/* L150: */ |
4639 | + } |
4640 | + x[jx] = temp; |
4641 | + jx += *incx; |
4642 | +/* L160: */ |
4643 | + } |
4644 | + } |
4645 | + } |
4646 | + } |
4647 | + |
4648 | + return 0; |
4649 | + |
4650 | +/* End of DTRMV . */ |
4651 | + |
4652 | +} /* dtrmv_ */ |
4653 | + |
4654 | +/* Subroutine */ int dtrsm_(char *side, char *uplo, char *transa, char *diag, |
4655 | + integer *m, integer *n, doublereal *alpha, doublereal *a, integer * |
4656 | + lda, doublereal *b, integer *ldb) |
4657 | +{ |
4658 | + /* System generated locals */ |
4659 | + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; |
4660 | + |
4661 | + /* Local variables */ |
4662 | + static integer info; |
4663 | + static doublereal temp; |
4664 | + static integer i__, j, k; |
4665 | + static logical lside; |
4666 | + extern logical lsame_(char *, char *); |
4667 | + static integer nrowa; |
4668 | + static logical upper; |
4669 | + extern /* Subroutine */ int xerbla_(char *, integer *); |
4670 | + static logical nounit; |
4671 | + |
4672 | + |
4673 | +/* |
4674 | + Purpose |
4675 | + ======= |
4676 | + |
4677 | + DTRSM solves one of the matrix equations |
4678 | + |
4679 | + op( A )*X = alpha*B, or X*op( A ) = alpha*B, |
4680 | + |
4681 | + where alpha is a scalar, X and B are m by n matrices, A is a unit, or |
4682 | + non-unit, upper or lower triangular matrix and op( A ) is one of |
4683 | + |
4684 | + op( A ) = A or op( A ) = A'. |
4685 | + |
4686 | + The matrix X is overwritten on B. |
4687 | + |
4688 | + Arguments |
4689 | + ========== |
4690 | + |
4691 | + SIDE - CHARACTER*1. |
4692 | + On entry, SIDE specifies whether op( A ) appears on the left |
4693 | + or right of X as follows: |
4694 | + |
4695 | + SIDE = 'L' or 'l' op( A )*X = alpha*B. |
4696 | + |
4697 | + SIDE = 'R' or 'r' X*op( A ) = alpha*B. |
4698 | + |
4699 | + Unchanged on exit. |
4700 | + |
4701 | + UPLO - CHARACTER*1. |
4702 | + On entry, UPLO specifies whether the matrix A is an upper or |
4703 | + lower triangular matrix as follows: |
4704 | + |
4705 | + UPLO = 'U' or 'u' A is an upper triangular matrix. |
4706 | + |
4707 | + UPLO = 'L' or 'l' A is a lower triangular matrix. |
4708 | + |
4709 | + Unchanged on exit. |
4710 | + |
4711 | + TRANSA - CHARACTER*1. |
4712 | + On entry, TRANSA specifies the form of op( A ) to be used in |
4713 | + the matrix multiplication as follows: |
4714 | + |
4715 | + TRANSA = 'N' or 'n' op( A ) = A. |
4716 | + |
4717 | + TRANSA = 'T' or 't' op( A ) = A'. |
4718 | + |
4719 | + TRANSA = 'C' or 'c' op( A ) = A'. |
4720 | + |
4721 | + Unchanged on exit. |
4722 | + |
4723 | + DIAG - CHARACTER*1. |
4724 | + On entry, DIAG specifies whether or not A is unit triangular |
4725 | + as follows: |
4726 | + |
4727 | + DIAG = 'U' or 'u' A is assumed to be unit triangular. |
4728 | + |
4729 | + DIAG = 'N' or 'n' A is not assumed to be unit |
4730 | + triangular. |
4731 | + |
4732 | + Unchanged on exit. |
4733 | + |
4734 | + M - INTEGER. |
4735 | + On entry, M specifies the number of rows of B. M must be at |
4736 | + least zero. |
4737 | + Unchanged on exit. |
4738 | + |
4739 | + N - INTEGER. |
4740 | + On entry, N specifies the number of columns of B. N must be |
4741 | + at least zero. |
4742 | + Unchanged on exit. |
4743 | + |
4744 | + ALPHA - DOUBLE PRECISION. |
4745 | + On entry, ALPHA specifies the scalar alpha. When alpha is |
4746 | + zero then A is not referenced and B need not be set before |
4747 | + entry. |
4748 | + Unchanged on exit. |
4749 | + |
4750 | + A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m |
4751 | + when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. |
4752 | + Before entry with UPLO = 'U' or 'u', the leading k by k |
4753 | + upper triangular part of the array A must contain the upper |
4754 | + triangular matrix and the strictly lower triangular part of |
4755 | + A is not referenced. |
4756 | + Before entry with UPLO = 'L' or 'l', the leading k by k |
4757 | + lower triangular part of the array A must contain the lower |
4758 | + triangular matrix and the strictly upper triangular part of |
4759 | + A is not referenced. |
4760 | + Note that when DIAG = 'U' or 'u', the diagonal elements of |
4761 | + A are not referenced either, but are assumed to be unity. |
4762 | + Unchanged on exit. |
4763 | + |
4764 | + LDA - INTEGER. |
4765 | + On entry, LDA specifies the first dimension of A as declared |
4766 | + in the calling (sub) program. When SIDE = 'L' or 'l' then |
4767 | + LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' |
4768 | + then LDA must be at least max( 1, n ). |
4769 | + Unchanged on exit. |
4770 | + |
4771 | + B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). |
4772 | + Before entry, the leading m by n part of the array B must |
4773 | + contain the right-hand side matrix B, and on exit is |
4774 | + overwritten by the solution matrix X. |
4775 | + |
4776 | + LDB - INTEGER. |
4777 | + On entry, LDB specifies the first dimension of B as declared |
4778 | + in the calling (sub) program. LDB must be at least |
4779 | + max( 1, m ). |
4780 | + Unchanged on exit. |
4781 | + |
4782 | + |
4783 | + Level 3 Blas routine. |
4784 | + |
4785 | + |
4786 | + -- Written on 8-February-1989. |
4787 | + Jack Dongarra, Argonne National Laboratory. |
4788 | + Iain Duff, AERE Harwell. |
4789 | + Jeremy Du Croz, Numerical Algorithms Group Ltd. |
4790 | + Sven Hammarling, Numerical Algorithms Group Ltd. |
4791 | + |
4792 | + |
4793 | + Test the input parameters. |
4794 | +*/ |
4795 | + |
4796 | + /* Parameter adjustments */ |
4797 | + a_dim1 = *lda; |
4798 | + a_offset = 1 + a_dim1 * 1; |
4799 | + a -= a_offset; |
4800 | + b_dim1 = *ldb; |
4801 | + b_offset = 1 + b_dim1 * 1; |
4802 | + b -= b_offset; |
4803 | + |
4804 | + /* Function Body */ |
4805 | + lside = lsame_(side, "L"); |
4806 | + if (lside) { |
4807 | + nrowa = *m; |
4808 | + } else { |
4809 | + nrowa = *n; |
4810 | + } |
4811 | + nounit = lsame_(diag, "N"); |
4812 | + upper = lsame_(uplo, "U"); |
4813 | + |
4814 | + info = 0; |
4815 | + if (! lside && ! lsame_(side, "R")) { |
4816 | + info = 1; |
4817 | + } else if (! upper && ! lsame_(uplo, "L")) { |
4818 | + info = 2; |
4819 | + } else if (! lsame_(transa, "N") && ! lsame_(transa, |
4820 | + "T") && ! lsame_(transa, "C")) { |
4821 | + info = 3; |
4822 | + } else if (! lsame_(diag, "U") && ! lsame_(diag, |
4823 | + "N")) { |
4824 | + info = 4; |
4825 | + } else if (*m < 0) { |
4826 | + info = 5; |
4827 | + } else if (*n < 0) { |
4828 | + info = 6; |
4829 | + } else if (*lda < max(1,nrowa)) { |
4830 | + info = 9; |
4831 | + } else if (*ldb < max(1,*m)) { |
4832 | + info = 11; |
4833 | + } |
4834 | + if (info != 0) { |
4835 | + xerbla_("DTRSM ", &info); |
4836 | + return 0; |
4837 | + } |
4838 | + |
4839 | +/* Quick return if possible. */ |
4840 | + |
4841 | + if (*n == 0) { |
4842 | + return 0; |
4843 | + } |
4844 | + |
4845 | +/* And when alpha.eq.zero. */ |
4846 | + |
4847 | + if (*alpha == 0.) { |
4848 | + i__1 = *n; |
4849 | + for (j = 1; j <= i__1; ++j) { |
4850 | + i__2 = *m; |
4851 | + for (i__ = 1; i__ <= i__2; ++i__) { |
4852 | + b[i__ + j * b_dim1] = 0.; |
4853 | +/* L10: */ |
4854 | + } |
4855 | +/* L20: */ |
4856 | + } |
4857 | + return 0; |
4858 | + } |
4859 | + |
4860 | +/* Start the operations. */ |
4861 | + |
4862 | + if (lside) { |
4863 | + if (lsame_(transa, "N")) { |
4864 | + |
4865 | +/* Form B := alpha*inv( A )*B. */ |
4866 | + |
4867 | + if (upper) { |
4868 | + i__1 = *n; |
4869 | + for (j = 1; j <= i__1; ++j) { |
4870 | + if (*alpha != 1.) { |
4871 | + i__2 = *m; |
4872 | + for (i__ = 1; i__ <= i__2; ++i__) { |
4873 | + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] |
4874 | + ; |
4875 | +/* L30: */ |
4876 | + } |
4877 | + } |
4878 | + for (k = *m; k >= 1; --k) { |
4879 | + if (b[k + j * b_dim1] != 0.) { |
4880 | + if (nounit) { |
4881 | + b[k + j * b_dim1] /= a[k + k * a_dim1]; |
4882 | + } |
4883 | + i__2 = k - 1; |
4884 | + for (i__ = 1; i__ <= i__2; ++i__) { |
4885 | + b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ |
4886 | + i__ + k * a_dim1]; |
4887 | +/* L40: */ |
4888 | + } |
4889 | + } |
4890 | +/* L50: */ |
4891 | + } |
4892 | +/* L60: */ |
4893 | + } |
4894 | + } else { |
4895 | + i__1 = *n; |
4896 | + for (j = 1; j <= i__1; ++j) { |
4897 | + if (*alpha != 1.) { |
4898 | + i__2 = *m; |
4899 | + for (i__ = 1; i__ <= i__2; ++i__) { |
4900 | + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] |
4901 | + ; |
4902 | +/* L70: */ |
4903 | + } |
4904 | + } |
4905 | + i__2 = *m; |
4906 | + for (k = 1; k <= i__2; ++k) { |
4907 | + if (b[k + j * b_dim1] != 0.) { |
4908 | + if (nounit) { |
4909 | + b[k + j * b_dim1] /= a[k + k * a_dim1]; |
4910 | + } |
4911 | + i__3 = *m; |
4912 | + for (i__ = k + 1; i__ <= i__3; ++i__) { |
4913 | + b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ |
4914 | + i__ + k * a_dim1]; |
4915 | +/* L80: */ |
4916 | + } |
4917 | + } |
4918 | +/* L90: */ |
4919 | + } |
4920 | +/* L100: */ |
4921 | + } |
4922 | + } |
4923 | + } else { |
4924 | + |
4925 | +/* Form B := alpha*inv( A' )*B. */ |
4926 | + |
4927 | + if (upper) { |
4928 | + i__1 = *n; |
4929 | + for (j = 1; j <= i__1; ++j) { |
4930 | + i__2 = *m; |
4931 | + for (i__ = 1; i__ <= i__2; ++i__) { |
4932 | + temp = *alpha * b[i__ + j * b_dim1]; |
4933 | + i__3 = i__ - 1; |
4934 | + for (k = 1; k <= i__3; ++k) { |
4935 | + temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; |
4936 | +/* L110: */ |
4937 | + } |
4938 | + if (nounit) { |
4939 | + temp /= a[i__ + i__ * a_dim1]; |
4940 | + } |
4941 | + b[i__ + j * b_dim1] = temp; |
4942 | +/* L120: */ |
4943 | + } |
4944 | +/* L130: */ |
4945 | + } |
4946 | + } else { |
4947 | + i__1 = *n; |
4948 | + for (j = 1; j <= i__1; ++j) { |
4949 | + for (i__ = *m; i__ >= 1; --i__) { |
4950 | + temp = *alpha * b[i__ + j * b_dim1]; |
4951 | + i__2 = *m; |
4952 | + for (k = i__ + 1; k <= i__2; ++k) { |
4953 | + temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; |
4954 | +/* L140: */ |
4955 | + } |
4956 | + if (nounit) { |
4957 | + temp /= a[i__ + i__ * a_dim1]; |
4958 | + } |
4959 | + b[i__ + j * b_dim1] = temp; |
4960 | +/* L150: */ |
4961 | + } |
4962 | +/* L160: */ |
4963 | + } |
4964 | + } |
4965 | + } |
4966 | + } else { |
4967 | + if (lsame_(transa, "N")) { |
4968 | + |
4969 | +/* Form B := alpha*B*inv( A ). */ |
4970 | + |
4971 | + if (upper) { |
4972 | + i__1 = *n; |
4973 | + for (j = 1; j <= i__1; ++j) { |
4974 | + if (*alpha != 1.) { |
4975 | + i__2 = *m; |
4976 | + for (i__ = 1; i__ <= i__2; ++i__) { |
4977 | + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] |
4978 | + ; |
4979 | +/* L170: */ |
4980 | + } |
4981 | + } |
4982 | + i__2 = j - 1; |
4983 | + for (k = 1; k <= i__2; ++k) { |
4984 | + if (a[k + j * a_dim1] != 0.) { |
4985 | + i__3 = *m; |
4986 | + for (i__ = 1; i__ <= i__3; ++i__) { |
4987 | + b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ |
4988 | + i__ + k * b_dim1]; |
4989 | +/* L180: */ |
4990 | + } |
4991 | + } |
4992 | +/* L190: */ |
4993 | + } |
4994 | + if (nounit) { |
4995 | + temp = 1. / a[j + j * a_dim1]; |
4996 | + i__2 = *m; |
4997 | + for (i__ = 1; i__ <= i__2; ++i__) { |
4998 | + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; |
4999 | +/* L200: */ |
5000 | + } |
This branch includes a "lapack lite" distribution so that nipy can build on systems where lapack is not installed. More specifically, if the setup doesn't find lapack on the system, then it builds the necessary blas/lapack routines (as translated in C from the original fortran code using f2c). A similar approach is implemented in numpy, however this implementation is completely independent.
It currently triggers run-time errors on Windows with python 2.6 due to a known issue that has necessitated a fair amount of hacks in numpy:
http:// cournape. wordpress. com/2008/ 09/02/how- to-embed- a-manifest- into-a- dll-with- mingw-tools- only/
http:// svn.scipy. org/svn/ numpy/trunk/ numpy/random/ setup.py
I feel that it would be a waste of time to develop code to work around this specific problem, given that most windows users will generally prefer to use binary installers anyway. It seems to work fine on linux, and should therefore be of some help.