1 /****************************************************************
2 Copyright (C) 1997-2001 Lucent Technologies
3 All Rights Reserved
4
5 Permission to use, copy, modify, and distribute this software and
6 its documentation for any purpose and without fee is hereby
7 granted, provided that the above copyright notice appear in all
8 copies and that both that the copyright notice and this
9 permission notice and warranty disclaimer appear in supporting
10 documentation, and that the name of Lucent or any of its entities
11 not be used in advertising or publicity pertaining to
12 distribution of the software without specific, written prior
13 permission.
14
15 LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
16 INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS.
17 IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY
18 SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
19 WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
20 IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
21 ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF
22 THIS SOFTWARE.
23 ****************************************************************/
24
25 #include "nlp.h"
26
27 int
28 #ifdef KR_headers
x0_check_ASL(asl,X)29 x0_check_ASL(asl, X) ASL_fg *asl; real *X;
30 #else
31 x0_check_ASL(ASL_fg *asl, real *X)
32 #endif
33 {
34 expr_v *V;
35 real *vscale, *Xe;
36
37 if (x0kind == ASL_first_x || memcmp(Lastx, X, x0len)) {
38 want_deriv = want_derivs;
39 memcpy(Lastx, X, x0len);
40 asl->i.nxval++;
41 V = var_e;
42 Xe = X + n_var;
43 if (vscale = asl->i.vscale)
44 while(X < Xe)
45 (V++)->v = *vscale++ * *X++;
46 else
47 while(X < Xe)
48 (V++)->v = *X++;
49 x0kind = 0;
50 if (comb)
51 comeval_ASL(asl, 0, comb);
52 return 1;
53 }
54 return 0;
55 }
56
57 void
58 #ifdef KR_headers
x1known_ASL(asl,X,nerror)59 x1known_ASL(asl, X, nerror) ASL *asl; real *X; fint *nerror;
60 #else
61 x1known_ASL(ASL *asl, real *X, fint *nerror)
62 #endif
63 {
64 Jmp_buf err_jmp0;
65 int ij;
66
67 ASL_CHECK(asl, ASL_read_fg, "x1known");
68 if (asl->i.xknown_ignore)
69 return;
70 if (nerror && *nerror >= 0) {
71 err_jmp = &err_jmp0;
72 ij = setjmp(err_jmp0.jb);
73 if (*nerror = ij)
74 goto done;
75 }
76 errno = 0; /* in case f77 set errno opening files */
77 x0_check_ASL((ASL_fg*)asl, X);
78 asl->i.x_known = 1;
79 done:
80 err_jmp = 0;
81 }
82
83 static void
84 #ifdef KR_headers
NNOBJ_chk(asl,i,who)85 NNOBJ_chk(asl, i, who) ASL *asl; int i; char *who;
86 #else
87 NNOBJ_chk(ASL *asl, int i, char *who)
88 #endif
89 {
90 ASL_CHECK(asl, ASL_read_fg, who);
91 if (i < 0 || i >= n_obj) {
92 fprintf(Stderr,
93 "objval: got NOBJ = %d; expected 0 <= NOBJ < %d\n",
94 i, n_obj);
95 exit(1);
96 }
97 }
98
99 real
100 #ifdef KR_headers
obj1val_ASL(a,i,X,nerror)101 obj1val_ASL(a, i, X, nerror) ASL *a; int i; real *X; fint *nerror;
102 #else
103 obj1val_ASL(ASL *a, int i, real *X, fint *nerror)
104 #endif
105 {
106 cde *d;
107 expr *e1;
108 real f;
109 int ij;
110 ograd **gr0;
111 ograd *gr;
112 Jmp_buf err_jmp0;
113 expr_v *V;
114 ASL_fg *asl;
115
116 NNOBJ_chk(a, i, "obj1val");
117 asl = (ASL_fg*)a;
118 if (nerror && *nerror >= 0) {
119 err_jmp = &err_jmp0;
120 ij = setjmp(err_jmp0.jb);
121 if (*nerror = ij) {
122 f = 0.;
123 goto done;
124 }
125 }
126 want_deriv = want_derivs;
127 errno = 0; /* in case f77 set errno opening files */
128 if (!asl->i.x_known)
129 x0_check_ASL(asl,X);
130 if (!asl->i.noxval)
131 asl->i.noxval = (int*)M1zapalloc(n_obj*sizeof(int));
132 co_index = -(i + 1);
133 if (!(x0kind & ASL_have_objcom)) {
134 if (ncom0 > combc)
135 comeval_ASL(asl, combc, ncom0);
136 if (comc1 < ncom1)
137 com1eval_ASL(asl, comc1, ncom1);
138 x0kind |= ASL_have_objcom;
139 }
140 d = obj_de + i;
141 gr0 = Ograd + i;
142 e1 = d->e;
143 f = (*e1->op)(e1 C_ASL);
144 asl->i.noxval[i] = asl->i.nxval;
145 gr = *gr0;
146 if (asl->i.vscale)
147 for(V = var_e; gr; gr = gr->next)
148 f += gr->coef * V[gr->varno].v;
149 else
150 for(; gr; gr = gr->next)
151 f += gr->coef * X[gr->varno];
152 done:
153 err_jmp = 0;
154 return f;
155 }
156
157 void
158 #ifdef KR_headers
obj1grd_ASL(a,i,X,G,nerror)159 obj1grd_ASL(a, i, X, G, nerror) ASL *a; int i; real *X, *G; fint *nerror;
160 #else
161 obj1grd_ASL(ASL *a, int i, real *X, real *G, fint *nerror)
162 #endif
163 {
164 cde *d;
165 ograd *gr, **gr0;
166 real *Adjoints, *vscale;
167 Jmp_buf err_jmp0;
168 int L, ij, xksave, *z;
169 fint ne0;
170 ASL_fg *asl;
171 static char who[] = "obj1grd";
172
173 NNOBJ_chk(a, i, who);
174 asl = (ASL_fg*)a;
175 if (!want_derivs)
176 No_derivs_ASL(who);
177 ne0 = -1;
178 if (nerror && (ne0 = *nerror) >= 0) {
179 err_jmp = &err_jmp0;
180 ij = setjmp(err_jmp0.jb);
181 if (*nerror = ij)
182 goto done;
183 }
184 errno = 0; /* in case f77 set errno opening files */
185 if (!asl->i.x_known)
186 x0_check_ASL(asl,X);
187 if (!asl->i.noxval || asl->i.noxval[i] != asl->i.nxval) {
188 xksave = asl->i.x_known;
189 asl->i.x_known = 1;
190 obj1val_ASL(a, i, X, nerror);
191 asl->i.x_known = xksave;
192 if (ne0 >= 0 && *nerror)
193 goto done;
194 }
195 if (f_b)
196 funnelset_ASL(asl, f_b);
197 if (f_o)
198 funnelset_ASL(asl, f_o);
199 Adjoints = adjoints;
200 d = obj_de + i;
201 gr0 = Ograd + i;
202 for(gr = *gr0; gr; gr = gr->next)
203 Adjoints[gr->varno] = gr->coef;
204 if (L = d->zaplen) {
205 memset(adjoints_nv1, 0, L);
206 derprop(d->d);
207 }
208 if (zerograds) { /* sparse gradients */
209 z = zerograds[i];
210 while((i = *z++) >= 0)
211 G[i] = 0;
212 }
213 gr = *gr0;
214 if (vscale = asl->i.vscale)
215 for(; gr; gr = gr->next) {
216 i = gr->varno;
217 G[i] = Adjoints[i] * vscale[i];
218 }
219 else
220 for(; gr; gr = gr->next) {
221 i = gr->varno;
222 G[i] = Adjoints[i];
223 }
224 done:
225 err_jmp = 0;
226 }
227