Skip to content

Commit 692b14c

Browse files
wernsaarwernsaar
committed
rewrote rotmg.c instead of modifying very old code
1 parent 322a178 commit 692b14c

File tree

1 file changed

+198
-175
lines changed

1 file changed

+198
-175
lines changed

‎interface/rotmg.c

+198-175
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,37 @@
1+
/***************************************************************************
2+
Copyright (c) 2013, The OpenBLAS Project
3+
All rights reserved.
4+
Redistribution and use in source and binary forms, with or without
5+
modification, are permitted provided that the following conditions are
6+
met:
7+
1. Redistributions of source code must retain the above copyright
8+
notice, this list of conditions and the following disclaimer.
9+
2. Redistributions in binary form must reproduce the above copyright
10+
notice, this list of conditions and the following disclaimer in
11+
the documentation and/or other materials provided with the
12+
distribution.
13+
3. Neither the name of the OpenBLAS project nor the names of
14+
its contributors may be used to endorse or promote products
15+
derived from this software without specific prior written permission.
16+
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
17+
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
18+
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
19+
ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE
20+
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
21+
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22+
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
23+
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
24+
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
25+
USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
26+
*****************************************************************************/
27+
28+
/**************************************************************************************
29+
* 2014/02/28 Saar
30+
* Test with lapack-3.5.0 : OK
31+
*
32+
**************************************************************************************/
33+
34+
135
#include "common.h"
236
#ifdef FUNCTION_PROFILE
337
#include "functable.h"
@@ -7,6 +41,8 @@
741
#define GAMSQ 16777216.e0
842
#define RGAMSQ 5.9604645e-8
943

44+
#define TWO 2.e0
45+
1046
#ifdef DOUBLE
1147
#define ABS(x) fabs(x)
1248
#else
@@ -25,181 +61,168 @@ void CNAME(FLOAT *dd1, FLOAT *dd2, FLOAT *dx1, FLOAT dy1, FLOAT *dparam){
2561

2662
#endif
2763

28-
FLOAT du, dp1, dp2, dq2, dq1, dh11, dh21, dh12, dh22;
29-
int igo, flag;
30-
FLOAT dtemp;
31-
32-
#ifndef CBLAS
33-
PRINT_DEBUG_NAME;
34-
#else
35-
PRINT_DEBUG_CNAME;
36-
#endif
37-
38-
dh11 = ZERO;
39-
dh12 = ZERO;
40-
dh21 = ZERO;
41-
dh22 = ZERO;
42-
43-
if (*dd1 < ZERO) goto L60;
44-
45-
dp2 = *dd2 * dy1;
46-
47-
if (dp2 == ZERO) {
48-
flag = -2;
49-
goto L260;
50-
}
51-
52-
dp1 = *dd1 * *dx1;
53-
dq2 = dp2 * dy1;
54-
dq1 = dp1 * *dx1;
55-
56-
if (! (ABS(dq1) > ABS(dq2))) goto L40;
57-
58-
dh21 = -(dy1) / *dx1;
59-
dh12 = dp2 / dp1;
60-
61-
du = ONE - dh12 * dh21;
62-
63-
if (du <= ZERO) goto L60;
64-
65-
flag = 0;
66-
*dd1 /= du;
67-
*dd2 /= du;
68-
*dx1 *= du;
69-
70-
goto L100;
71-
72-
L40:
73-
if (dq2 < ZERO) goto L60;
74-
75-
flag = 1;
76-
dh11 = dp1 / dp2;
77-
dh22 = *dx1 / dy1;
78-
du = ONE + dh11 * dh22;
79-
dtemp = *dd2 / du;
80-
*dd2 = *dd1 / du;
81-
*dd1 = dtemp;
82-
*dx1 = dy1 * du;
83-
goto L100;
84-
85-
L60:
86-
flag = -1;
87-
dh11 = ZERO;
88-
dh12 = ZERO;
89-
dh21 = ZERO;
90-
dh22 = ZERO;
91-
92-
*dd1 = ZERO;
93-
*dd2 = ZERO;
94-
*dx1 = ZERO;
95-
goto L220;
96-
97-
98-
L70:
99-
if (flag < 0) goto L90;
100-
101-
if (flag > 0) goto L80;
102-
103-
dh11 = ONE;
104-
dh22 = ONE;
105-
flag = -1;
106-
goto L90;
107-
108-
L80:
109-
dh21 = -ONE;
110-
dh12 = ONE;
111-
flag = -1;
112-
113-
L90:
114-
switch (igo) {
115-
case 0: goto L120;
116-
case 1: goto L150;
117-
case 2: goto L180;
118-
case 3: goto L210;
119-
}
120-
121-
L100:
122-
if (!(*dd1 <= RGAMSQ)) goto L130;
123-
if (*dd1 == ZERO) goto L160;
124-
igo = 0;
125-
goto L70;
126-
127-
L120:
128-
*dd1 *= GAM * GAM;
129-
*dx1 /= GAM;
130-
dh11 /= GAM;
131-
dh12 /= GAM;
132-
goto L100;
133-
134-
L130:
135-
if (! (*dd1 >= GAMSQ)) {
136-
goto L160;
137-
}
138-
igo = 1;
139-
goto L70;
140-
141-
L150:
142-
*dd1 /= GAM * GAM;
143-
*dx1 *= GAM;
144-
dh11 *= GAM;
145-
dh12 *= GAM;
146-
goto L130;
147-
148-
L160:
149-
if (! (ABS(*dd2) <= RGAMSQ)) {
150-
goto L190;
151-
}
152-
if (*dd2 == ZERO) {
153-
goto L220;
154-
}
155-
igo = 2;
156-
goto L70;
157-
158-
L180:
159-
/* Computing 2nd power */
160-
*dd2 *= GAM * GAM;
161-
dh21 /= GAM;
162-
dh22 /= GAM;
163-
goto L160;
164-
165-
L190:
166-
if (! (ABS(*dd2) >= GAMSQ)) {
167-
goto L220;
168-
}
169-
igo = 3;
170-
goto L70;
171-
172-
L210:
173-
/* Computing 2nd power */
174-
*dd2 /= GAM * GAM;
175-
dh21 *= GAM;
176-
dh22 *= GAM;
177-
goto L190;
178-
179-
L220:
180-
if (flag < 0) {
181-
goto L250;
182-
} else if (flag == 0) {
183-
goto L230;
184-
} else {
185-
goto L240;
186-
}
187-
L230:
188-
dparam[2] = dh21;
189-
dparam[3] = dh12;
190-
goto L260;
191-
L240:
192-
dparam[2] = dh11;
193-
dparam[4] = dh22;
194-
goto L260;
195-
L250:
196-
dparam[1] = dh11;
197-
dparam[2] = dh21;
198-
dparam[3] = dh12;
199-
dparam[4] = dh22;
200-
L260:
201-
dparam[0] = (FLOAT) flag;
202-
return;
64+
FLOAT du, dp1, dp2, dq2, dq1, dh11, dh21, dh12, dh22, dflag, dtemp;
65+
66+
if(*dd1 < ZERO)
67+
{
68+
dflag = -ONE;
69+
dh11 = ZERO;
70+
dh12 = ZERO;
71+
dh21 = ZERO;
72+
dh22 = ZERO;
73+
74+
*dd1 = ZERO;
75+
*dd2 = ZERO;
76+
*dx1 = ZERO;
77+
}
78+
else
79+
{
80+
dp2 = *dd2 * dy1;
81+
if(dp2 == ZERO)
82+
{
83+
dflag = -TWO;
84+
dparam[0] = dflag;
85+
return;
86+
}
87+
dp1 = *dd1 * *dx1;
88+
dq2 = dp2 * dy1;
89+
dq1 = dp1 * *dx1;
90+
if(ABS(dq1) > ABS(dq2))
91+
{
92+
dh21 = - dy1 / *dx1;
93+
dh12 = dp2 / dp1;
94+
95+
du = ONE - dh12 * dh21;
96+
if(du > ZERO)
97+
{
98+
dflag = ZERO;
99+
*dd1 = *dd1 / du;
100+
*dd2 = *dd2 / du;
101+
*dx1 = *dx1 * du;
102+
103+
}
104+
}
105+
else
106+
{
107+
if(dq2 < ZERO)
108+
{
109+
dflag = -ONE;
110+
111+
dh11 = ZERO;
112+
dh12 = ZERO;
113+
dh21 = ZERO;
114+
dh22 = ZERO;
115+
116+
*dd1 = ZERO;
117+
*dd2 = ZERO;
118+
*dx1 = ZERO;
119+
}
120+
else
121+
{
122+
dflag = ONE;
123+
124+
dh11 = dp1 / dp2;
125+
dh22 = *dx1 / dy1;
126+
du = ONE + dh11 * dh22;
127+
dtemp = *dd2 / du;
128+
129+
*dd2 = *dd1 / du;
130+
*dd1 = dtemp;
131+
*dx1 = dy1 * du;
132+
}
133+
}
134+
135+
136+
if(*dd1 != ZERO)
137+
{
138+
while( (*dd1 <= RGAMSQ) || (*dd1 >= GAMSQ) )
139+
{
140+
if(dflag == ZERO)
141+
{
142+
dh11 = ONE;
143+
dh22 = ONE;
144+
dflag = -ONE;
145+
}
146+
else
147+
{
148+
dh21 = -ONE;
149+
dh12 = ONE;
150+
dflag = -ONE;
151+
}
152+
if( *dd1 <= RGAMSQ )
153+
{
154+
*dd1 = *dd1 * (GAM * GAM);
155+
*dx1 = *dx1 / GAM;
156+
dh11 = dh11 / GAM;
157+
dh12 = dh12 / GAM;
158+
}
159+
else
160+
{
161+
*dd1 = *dd1 / (GAM * GAM);
162+
*dx1 = *dx1 * GAM;
163+
dh11 = dh11 * GAM;
164+
dh12 = dh12 * GAM;
165+
}
166+
}
167+
}
168+
169+
if(*dd2 != ZERO)
170+
{
171+
while( (ABS(*dd2) <= RGAMSQ) || (ABS(*dd2) >= GAMSQ) )
172+
{
173+
if(dflag == ZERO)
174+
{
175+
dh11 = ONE;
176+
dh22 = ONE;
177+
dflag = -ONE;
178+
}
179+
else
180+
{
181+
dh21 = -ONE;
182+
dh12 = ONE;
183+
dflag = -ONE;
184+
}
185+
if( ABS(*dd2) <= RGAMSQ )
186+
{
187+
*dd2 = *dd2 * (GAM * GAM);
188+
dh21 = dh21 / GAM;
189+
dh22 = dh22 / GAM;
190+
}
191+
else
192+
{
193+
*dd2 = *dd2 / (GAM * GAM);
194+
dh21 = dh21 * GAM;
195+
dh22 = dh22 * GAM;
196+
}
197+
}
198+
}
199+
200+
}
201+
202+
if(dflag < ZERO)
203+
{
204+
dparam[1] = dh11;
205+
dparam[2] = dh21;
206+
dparam[3] = dh12;
207+
dparam[4] = dh22;
208+
}
209+
else
210+
{
211+
if(dflag == ZERO)
212+
{
213+
dparam[2] = dh21;
214+
dparam[3] = dh12;
215+
}
216+
else
217+
{
218+
dparam[1] = dh11;
219+
dparam[4] = dh22;
220+
}
221+
}
222+
223+
224+
dparam[0] = dflag;
225+
return;
203226
}
204227

205228

0 commit comments

Comments
 (0)