1 #include "asl.h"
2
3 static real *
4 #ifdef KR_headers
ones(asl,n)5 ones(asl, n) ASL *asl; int n;
6 #else
7 ones(ASL *asl, int n)
8 #endif
9 {
10 real *x, *x0, *xe;
11
12 x = x0 = (real*)mem_ASL(asl, n*sizeof(real));
13 xe = x + n;
14 while(x < xe)
15 *x++ = 1.;
16 return x0;
17 }
18
19 static int
20 #ifdef KR_headers
zcheck(asl,i,s,n,ierror,who)21 zcheck(asl, i, s, n, ierror, who) ASL *asl; real s; int i, n; fint *ierror; char *who;
22 #else
23 zcheck(ASL *asl, int i, real s, int n, fint *ierror, char *who)
24 #endif
25 {
26 #undef Word0
27 #ifdef IEEE_MC68k
28 #define Word0(x) ((Long*)&(x))[0]
29 #endif
30 #ifdef IEEE_8087
31 #define Word0(x) ((Long*)&(x))[1]
32 #endif
33 #ifdef Word0
34 #define Inftest(z) ((Word0(z)&0x7ff00000) == 0x7ff00000)
35 #else
36 #define Inftest(z) (z <= negInfinity || z >= Infinity)
37 #endif
38 if (n >= 0 && (i < 0 || i >= n)
39 || s == 0.
40 || Inftest(s)) {
41 if (ierror && *ierror >= 0) {
42 *ierror = 1;
43 return 1;
44 }
45 fprintf(Stderr, "%s(", who);
46 if (n >= 0)
47 fprintf(Stderr, "%d, ", i);
48 fprintf(Stderr, "%.g, nerror): bad argument\n", s);
49 fflush(Stderr);
50 if (err_jmp1)
51 longjmp(err_jmp1->jb, 1);
52 exit(1);
53 }
54 if (ierror && *ierror >= 0)
55 *ierror = 0;
56 cur_ASL = asl;
57 return 0;
58 }
59
60 static void
61 #ifdef KR_headers
scaleadj(s,i,m,scale,L,U,x)62 scaleadj(s, i, m, scale, L, U, x) int i, m; real s, *scale, *L, *U, *x;
63 #else
64 scaleadj(real s, int i, int m, real *scale, real *L, real *U, real *x)
65 #endif
66 {
67 real u, v;
68
69 scale += i;
70 if (x)
71 x[i] /= s;
72 if (!U) {
73 U = L + 1;
74 i <<= 1;
75 }
76 L += i;
77 U += i;
78 *scale *= s;
79 if (s > 0.) {
80 if (*L > negInfinity)
81 if (m)
82 *L *= s;
83 else
84 *L /= s;
85 if (*U < Infinity)
86 if (m)
87 *U *= s;
88 else
89 *U /= s;
90 }
91 else {
92 u = -*L;
93 v = -*U;
94 if (u < Infinity)
95 if (m)
96 u = *L * s;
97 else
98 u = *L / s;
99 if (v > negInfinity)
100 if (m)
101 v = *U * s;
102 else
103 v = *U / s;
104 *L = v;
105 *U = u;
106 }
107 }
108
109 void
110 #ifdef KR_headers
conscale_ASL(asl,i,s,ierror)111 conscale_ASL(asl, i, s, ierror) ASL *asl; int i; real s; fint *ierror;
112 #else
113 conscale_ASL(ASL *asl, int i, real s, fint *ierror)
114 #endif
115 {
116 static char who[] = "conscale";
117
118 if (!asl
119 || asl->i.ASLtype < ASL_read_fg
120 || asl->i.ASLtype > ASL_read_pfgh)
121 badasl_ASL(asl, ASL_read_fg, who);
122 if (zcheck(asl, i, s, n_con, ierror, who))
123 return;
124 if (!asl->i.cscale)
125 asl->i.lscale = asl->i.cscale = ones(asl, n_con);
126 scaleadj(s, i, 1, asl->i.cscale, LUrhs, Urhsx, pi0);
127 if (asl->i.lscale != asl->i.cscale)
128 asl->i.lscale[i] *= s;
129 }
130
131 void
132 #ifdef KR_headers
varscale_ASL(asl,i,s,ierror)133 varscale_ASL(asl, i, s, ierror) ASL *asl; int i; real s; fint *ierror;
134 #else
135 varscale_ASL(ASL *asl, int i, real s, fint *ierror)
136 #endif
137 {
138 static char who[] = "varscale";
139
140 if (!asl
141 || asl->i.ASLtype < ASL_read_fg
142 || asl->i.ASLtype > ASL_read_pfgh)
143 badasl_ASL(asl, ASL_read_fg, who);
144 if (zcheck(asl, i, s, n_var, ierror, who))
145 return;
146 if (!asl->i.vscale)
147 asl->i.vscale = ones(asl, n_var);
148 scaleadj(s, i, 0, asl->i.vscale, LUv, Uvx, X0);
149 }
150
151 void
152 #ifdef KR_headers
lagscale_ASL(asl,s,ierror)153 lagscale_ASL(asl, s, ierror) ASL *asl; real s; fint *ierror;
154 #else
155 lagscale_ASL(ASL *asl, real s, fint *ierror)
156 #endif
157 {
158 static char who[] = "lagscale";
159 real *c, *ce, *l;
160
161 if (!asl
162 || asl->i.ASLtype != ASL_read_pfgh
163 && asl->i.ASLtype != ASL_read_fgh)
164 badasl_ASL(asl, ASL_read_pfgh, who);
165 if (zcheck(asl, 0, s, -1, ierror, who))
166 return;
167 if (s == 1. && asl->i.lscale == asl->i.cscale)
168 return;
169 if (!asl->i.cscale)
170 asl->i.lscale = asl->i.cscale = ones(asl, n_con);
171 if (asl->i.lscale == asl->i.cscale)
172 asl->i.lscale = (real*)mem_ASL(asl, n_con*sizeof(real));
173 l = asl->i.lscale;
174 c = asl->i.cscale;
175 ce = c + n_con;
176 while(c < ce)
177 *l++ = s * *c++;
178 }
179