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 "jac2dim.h"
26
27 extern int x2_check_ASL ANSI((ASL_fgh*, real *));
28 #define x2_check(x) x2_check_ASL(asl,x)
29
30 static void
31 #ifdef KR_headers
NNOBJ_chk(asl,i,who)32 NNOBJ_chk(asl, i, who) ASL *asl; int i; char *who;
33 #else
34 NNOBJ_chk(ASL *asl, int i, char *who)
35 #endif
36 {
37 ASL_CHECK(asl, ASL_read_fgh, who);
38 if (i < 0 || i >= n_obj) {
39 fprintf(Stderr,
40 "objval: got NOBJ = %d; expected 0 <= NOBJ < %d\n",
41 i, n_obj);
42 exit(1);
43 }
44 }
45
46 real
47 #ifdef KR_headers
obj2val_ASL(a,i,X,nerror)48 obj2val_ASL(a, i, X, nerror) ASL *a; int i; real *X; fint *nerror;
49 #else
50 obj2val_ASL(ASL *a, int i, real *X, fint *nerror)
51 #endif
52 {
53 cde *d;
54 expr *e1;
55 expr_v *V;
56 real f;
57 int ij;
58 ograd *gr, **gr0;
59 Jmp_buf err_jmp0;
60 ASL_fgh *asl;
61
62 NNOBJ_chk(a, i, "obj2val");
63 asl = (ASL_fgh*)a;
64 if (nerror && *nerror >= 0) {
65 err_jmp = &err_jmp0;
66 ij = setjmp(err_jmp0.jb);
67 if (*nerror = ij) {
68 f = 0.;
69 goto done;
70 }
71 }
72 want_deriv = want_derivs;
73 errno = 0; /* in case f77 set errno opening files */
74 x2_check(X);
75 if (!asl->i.noxval)
76 asl->i.noxval = (int*)M1zapalloc(n_obj*sizeof(int));
77 co_index = -(i + 1);
78 if (!(x0kind & ASL_have_objcom)) {
79 if (ncom0 > combc)
80 comeval(asl, combc, ncom0);
81 x0kind |= ASL_have_objcom;
82 }
83 d = obj_de + i;
84 if (d->n_com1)
85 com1eval(asl, d->com11, d->n_com1);
86 gr0 = Ograd + i;
87 e1 = d->e;
88 f = (*e1->op)(e1 C_ASL);
89 asl->i.noxval[i] = asl->i.nxval;
90 gr = *gr0;
91 if (asl->i.vscale)
92 for(V = var_e; gr; gr = gr->next)
93 f += gr->coef * V[gr->varno].v;
94 else
95 for(; gr; gr = gr->next)
96 f += gr->coef * X[gr->varno];
97 done:
98 err_jmp = 0;
99 return f;
100 }
101
102 void
103 #ifdef KR_headers
obj2grd_ASL(a,i,X,G,nerror)104 obj2grd_ASL(a, i, X, G, nerror) ASL *a; int i; real *X; real *G; fint *nerror;
105 #else
106 obj2grd_ASL(ASL *a, int i, real *X, real *G, fint *nerror)
107 #endif
108 {
109 cde *d;
110 ograd *gr, **gr0;
111 real *Adjoints, *vscale;
112 Jmp_buf err_jmp0;
113 int L, ij, xksave, *z;
114 fint ne0;
115 ASL_fgh *asl;
116 static char who[] = "obj2grd";
117
118 NNOBJ_chk(a, i, who);
119 asl = (ASL_fgh*)a;
120 if (!want_derivs)
121 No_derivs_ASL(who);
122 ne0 = -1;
123 if (nerror && (ne0 = *nerror) >= 0) {
124 err_jmp = &err_jmp0;
125 ij = setjmp(err_jmp0.jb);
126 if (*nerror = ij)
127 goto done;
128 }
129 errno = 0; /* in case f77 set errno opening files */
130 if (!asl->i.x_known)
131 x2_check(X);
132 if (!asl->i.noxval || asl->i.noxval[i] != asl->i.nxval) {
133 xksave = asl->i.x_known;
134 asl->i.x_known = 1;
135 obj2val_ASL(a, i, X, nerror);
136 asl->i.x_known = xksave;
137 if (ne0 >= 0 && *nerror)
138 goto done;
139 }
140 if (f_b)
141 funnelset(asl, f_b);
142 if (f_o)
143 funnelset(asl, f_o);
144 Adjoints = adjoints;
145 d = obj_de + i;
146 gr0 = Ograd + i;
147 for(gr = *gr0; gr; gr = gr->next)
148 Adjoints[gr->varno] = gr->coef;
149 if (L = d->zaplen) {
150 memset(adjoints_nv1, 0, L);
151 derprop(d->d);
152 }
153 if (zerograds) { /* sparse gradients */
154 z = zerograds[i];
155 while((i = *z++) >= 0)
156 G[i] = 0;
157 }
158 gr = *gr0;
159 if (vscale = asl->i.vscale)
160 for(; gr; gr = gr->next) {
161 i = gr->varno;
162 G[i] = vscale[i] * Adjoints[i];
163 }
164 else
165 for(; gr; gr = gr->next) {
166 i = gr->varno;
167 G[i] = Adjoints[i];
168 }
169 done:
170 err_jmp = 0;
171 }
172