1 /*
2
3 BLIS
4 An object-based framework for developing high-performance BLAS-like
5 libraries.
6
7 Copyright (C) 2014, The University of Texas at Austin
8
9 Redistribution and use in source and binary forms, with or without
10 modification, are permitted provided that the following conditions are
11 met:
12 - Redistributions of source code must retain the above copyright
13 notice, this list of conditions and the following disclaimer.
14 - Redistributions in binary form must reproduce the above copyright
15 notice, this list of conditions and the following disclaimer in the
16 documentation and/or other materials provided with the distribution.
17 - Neither the name(s) of the copyright holder(s) nor the names of its
18 contributors may be used to endorse or promote products derived
19 from this software without specific prior written permission.
20
21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
27 LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28 DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29 THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
31 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33 */
34
35 #include "blis.h"
36
37 #ifdef BLIS_ENABLE_BLAS
38
39 /* srotmg.f -- translated by f2c (version 19991025).
40 You must link the resulting object file with the libraries:
41 -lf2c -lm (in that order)
42 */
43
PASTEF77(s,rotmg)44 /* Subroutine */ int PASTEF77(s,rotmg)(bla_real *sd1, bla_real *sd2, bla_real *sx1, const bla_real *sy1, bla_real *sparam)
45 {
46 /* Initialized data */
47
48 static bla_real zero = 0.f;
49 static bla_real one = 1.f;
50 static bla_real two = 2.f;
51 static bla_real gam = 4096.f;
52 static bla_real gamsq = 16777200.f;
53 static bla_real rgamsq = 5.96046e-8f;
54
55 /* Format strings */
56
57 /* System generated locals */
58 bla_real r__1;
59
60 /* Local variables */
61 bla_real sflag, stemp, su, sp1, sp2, sq2, sq1,
62 sh11 = 0.f, sh21 = 0.f, sh12 = 0.f, sh22 = 0.f;
63 bla_integer igo;
64
65 /* Assigned format variables */
66
67
68 /* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */
69 /* THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)* */
70 /* SY2)**T. */
71 /* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
72
73 /* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */
74
75 /* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */
76 /* H=( ) ( ) ( ) ( ) */
77 /* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */
78 /* LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 */
79 /* RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE */
80 /* VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) */
81
82 /* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */
83 /* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */
84 /* OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */
85
86
87 /* Parameter adjustments */
88 --sparam;
89
90 /* Function Body */
91 if (! (*sd1 < zero)) {
92 goto L10;
93 }
94 /* GO ZERO-H-D-AND-SX1.. */
95 goto L60;
96 L10:
97 /* CASE-SD1-NONNEGATIVE */
98 sp2 = *sd2 * *sy1;
99 if (! (sp2 == zero)) {
100 goto L20;
101 }
102 sflag = -two;
103 goto L260;
104 /* REGULAR-CASE.. */
105 L20:
106 sp1 = *sd1 * *sx1;
107 sq2 = sp2 * *sy1;
108 sq1 = sp1 * *sx1;
109
110 if (! (bli_fabs(sq1) > bli_fabs(sq2))) {
111 goto L40;
112 }
113 sh21 = -(*sy1) / *sx1;
114 sh12 = sp2 / sp1;
115
116 su = one - sh12 * sh21;
117
118 if (! (su <= zero)) {
119 goto L30;
120 }
121 /* GO ZERO-H-D-AND-SX1.. */
122 goto L60;
123 L30:
124 sflag = zero;
125 *sd1 /= su;
126 *sd2 /= su;
127 *sx1 *= su;
128 /* GO SCALE-CHECK.. */
129 goto L100;
130 L40:
131 if (! (sq2 < zero)) {
132 goto L50;
133 }
134 /* GO ZERO-H-D-AND-SX1.. */
135 goto L60;
136 L50:
137 sflag = one;
138 sh11 = sp1 / sp2;
139 sh22 = *sx1 / *sy1;
140 su = one + sh11 * sh22;
141 stemp = *sd2 / su;
142 *sd2 = *sd1 / su;
143 *sd1 = stemp;
144 *sx1 = *sy1 * su;
145 /* GO SCALE-CHECK */
146 goto L100;
147 /* PROCEDURE..ZERO-H-D-AND-SX1.. */
148 L60:
149 sflag = -one;
150 sh11 = zero;
151 sh12 = zero;
152 sh21 = zero;
153 sh22 = zero;
154
155 *sd1 = zero;
156 *sd2 = zero;
157 *sx1 = zero;
158 /* RETURN.. */
159 goto L220;
160 /* PROCEDURE..FIX-H.. */
161 L70:
162 if (! (sflag >= zero)) {
163 goto L90;
164 }
165
166 if (! (sflag == zero)) {
167 goto L80;
168 }
169 sh11 = one;
170 sh22 = one;
171 sflag = -one;
172 goto L90;
173 L80:
174 sh21 = -one;
175 sh12 = one;
176 sflag = -one;
177 L90:
178 switch (igo) {
179 case 0: goto L120;
180 case 1: goto L150;
181 case 2: goto L180;
182 case 3: goto L210;
183 }
184 /* PROCEDURE..SCALE-CHECK */
185 L100:
186 L110:
187 if (! (*sd1 <= rgamsq)) {
188 goto L130;
189 }
190 if (*sd1 == zero) {
191 goto L160;
192 }
193 igo = 0;
194 /* FIX-H.. */
195 goto L70;
196 L120:
197 /* Computing 2nd power */
198 r__1 = gam;
199 *sd1 *= r__1 * r__1;
200 *sx1 /= gam;
201 sh11 /= gam;
202 sh12 /= gam;
203 goto L110;
204 L130:
205 L140:
206 if (! (*sd1 >= gamsq)) {
207 goto L160;
208 }
209 igo = 1;
210 /* FIX-H.. */
211 goto L70;
212 L150:
213 /* Computing 2nd power */
214 r__1 = gam;
215 *sd1 /= r__1 * r__1;
216 *sx1 *= gam;
217 sh11 *= gam;
218 sh12 *= gam;
219 goto L140;
220 L160:
221 L170:
222 if (! (bli_fabs(*sd2) <= rgamsq)) {
223 goto L190;
224 }
225 if (*sd2 == zero) {
226 goto L220;
227 }
228 igo = 2;
229 /* FIX-H.. */
230 goto L70;
231 L180:
232 /* Computing 2nd power */
233 r__1 = gam;
234 *sd2 *= r__1 * r__1;
235 sh21 /= gam;
236 sh22 /= gam;
237 goto L170;
238 L190:
239 L200:
240 if (! (bli_fabs(*sd2) >= gamsq)) {
241 goto L220;
242 }
243 igo = 3;
244 /* FIX-H.. */
245 goto L70;
246 L210:
247 /* Computing 2nd power */
248 r__1 = gam;
249 *sd2 /= r__1 * r__1;
250 sh21 *= gam;
251 sh22 *= gam;
252 goto L200;
253 L220:
254 if (sflag < 0.f) {
255 goto L250;
256 } else if (sflag == 0) {
257 goto L230;
258 } else {
259 goto L240;
260 }
261 L230:
262 sparam[3] = sh21;
263 sparam[4] = sh12;
264 goto L260;
265 L240:
266 sparam[2] = sh11;
267 sparam[5] = sh22;
268 goto L260;
269 L250:
270 sparam[2] = sh11;
271 sparam[3] = sh21;
272 sparam[4] = sh12;
273 sparam[5] = sh22;
274 L260:
275 sparam[1] = sflag;
276 return 0;
277 } /* srotmg_ */
278
279 /* drotmg.f -- translated by f2c (version 19991025).
280 You must link the resulting object file with the libraries:
281 -lf2c -lm (in that order)
282 */
283
PASTEF77(d,rotmg)284 /* Subroutine */ int PASTEF77(d,rotmg)(bla_double *dd1, bla_double *dd2, bla_double *dx1, const bla_double *dy1, bla_double *dparam)
285 {
286 /* Initialized data */
287
288 static bla_double zero = 0.;
289 static bla_double one = 1.;
290 static bla_double two = 2.;
291 static bla_double gam = 4096.;
292 static bla_double gamsq = 16777216.;
293 static bla_double rgamsq = 5.9604645e-8;
294
295 /* Format strings */
296
297 /* System generated locals */
298 bla_double d__1;
299
300 /* Local variables */
301 bla_double dflag, dtemp, du, dp1, dp2, dq2, dq1,
302 dh11 = 0.f, dh21 = 0.f, dh12 = 0.f, dh22 = 0.f;
303 bla_integer igo;
304
305 /* Assigned format variables */
306
307
308 /* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */
309 /* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* */
310 /* DY2)**T. */
311 /* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
312
313 /* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */
314
315 /* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */
316 /* H=( ) ( ) ( ) ( ) */
317 /* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */
318 /* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 */
319 /* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE */
320 /* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) */
321
322 /* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */
323 /* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */
324 /* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */
325
326
327 /* Parameter adjustments */
328 --dparam;
329
330 /* Function Body */
331 if (! (*dd1 < zero)) {
332 goto L10;
333 }
334 /* GO ZERO-H-D-AND-DX1.. */
335 goto L60;
336 L10:
337 /* CASE-DD1-NONNEGATIVE */
338 dp2 = *dd2 * *dy1;
339 if (! (dp2 == zero)) {
340 goto L20;
341 }
342 dflag = -two;
343 goto L260;
344 /* REGULAR-CASE.. */
345 L20:
346 dp1 = *dd1 * *dx1;
347 dq2 = dp2 * *dy1;
348 dq1 = dp1 * *dx1;
349
350 if (! (bli_fabs(dq1) > bli_fabs(dq2))) {
351 goto L40;
352 }
353 dh21 = -(*dy1) / *dx1;
354 dh12 = dp2 / dp1;
355
356 du = one - dh12 * dh21;
357
358 if (! (du <= zero)) {
359 goto L30;
360 }
361 /* GO ZERO-H-D-AND-DX1.. */
362 goto L60;
363 L30:
364 dflag = zero;
365 *dd1 /= du;
366 *dd2 /= du;
367 *dx1 *= du;
368 /* GO SCALE-CHECK.. */
369 goto L100;
370 L40:
371 if (! (dq2 < zero)) {
372 goto L50;
373 }
374 /* GO ZERO-H-D-AND-DX1.. */
375 goto L60;
376 L50:
377 dflag = one;
378 dh11 = dp1 / dp2;
379 dh22 = *dx1 / *dy1;
380 du = one + dh11 * dh22;
381 dtemp = *dd2 / du;
382 *dd2 = *dd1 / du;
383 *dd1 = dtemp;
384 *dx1 = *dy1 * du;
385 /* GO SCALE-CHECK */
386 goto L100;
387 /* PROCEDURE..ZERO-H-D-AND-DX1.. */
388 L60:
389 dflag = -one;
390 dh11 = zero;
391 dh12 = zero;
392 dh21 = zero;
393 dh22 = zero;
394
395 *dd1 = zero;
396 *dd2 = zero;
397 *dx1 = zero;
398 /* RETURN.. */
399 goto L220;
400 /* PROCEDURE..FIX-H.. */
401 L70:
402 if (! (dflag >= zero)) {
403 goto L90;
404 }
405
406 if (! (dflag == zero)) {
407 goto L80;
408 }
409 dh11 = one;
410 dh22 = one;
411 dflag = -one;
412 goto L90;
413 L80:
414 dh21 = -one;
415 dh12 = one;
416 dflag = -one;
417 L90:
418 switch (igo) {
419 case 0: goto L120;
420 case 1: goto L150;
421 case 2: goto L180;
422 case 3: goto L210;
423 }
424 /* PROCEDURE..SCALE-CHECK */
425 L100:
426 L110:
427 if (! (*dd1 <= rgamsq)) {
428 goto L130;
429 }
430 if (*dd1 == zero) {
431 goto L160;
432 }
433 igo = 0;
434 /* FIX-H.. */
435 goto L70;
436 L120:
437 /* Computing 2nd power */
438 d__1 = gam;
439 *dd1 *= d__1 * d__1;
440 *dx1 /= gam;
441 dh11 /= gam;
442 dh12 /= gam;
443 goto L110;
444 L130:
445 L140:
446 if (! (*dd1 >= gamsq)) {
447 goto L160;
448 }
449 igo = 1;
450 /* FIX-H.. */
451 goto L70;
452 L150:
453 /* Computing 2nd power */
454 d__1 = gam;
455 *dd1 /= d__1 * d__1;
456 *dx1 *= gam;
457 dh11 *= gam;
458 dh12 *= gam;
459 goto L140;
460 L160:
461 L170:
462 if (! (bli_fabs(*dd2) <= rgamsq)) {
463 goto L190;
464 }
465 if (*dd2 == zero) {
466 goto L220;
467 }
468 igo = 2;
469 /* FIX-H.. */
470 goto L70;
471 L180:
472 /* Computing 2nd power */
473 d__1 = gam;
474 *dd2 *= d__1 * d__1;
475 dh21 /= gam;
476 dh22 /= gam;
477 goto L170;
478 L190:
479 L200:
480 if (! (bli_fabs(*dd2) >= gamsq)) {
481 goto L220;
482 }
483 igo = 3;
484 /* FIX-H.. */
485 goto L70;
486 L210:
487 /* Computing 2nd power */
488 d__1 = gam;
489 *dd2 /= d__1 * d__1;
490 dh21 *= gam;
491 dh22 *= gam;
492 goto L200;
493 L220:
494 if (dflag < 0.) {
495 goto L250;
496 } else if (dflag == 0) {
497 goto L230;
498 } else {
499 goto L240;
500 }
501 L230:
502 dparam[3] = dh21;
503 dparam[4] = dh12;
504 goto L260;
505 L240:
506 dparam[2] = dh11;
507 dparam[5] = dh22;
508 goto L260;
509 L250:
510 dparam[2] = dh11;
511 dparam[3] = dh21;
512 dparam[4] = dh12;
513 dparam[5] = dh22;
514 L260:
515 dparam[1] = dflag;
516 return 0;
517 } /* drotmg_ */
518
519 #endif
520
521