1 /****************************************************************
2 Copyright (C) 1997, 1999, 2000 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 void
28 #ifdef KR_headers
con2val_ASL(a,X,F,nerror)29 con2val_ASL(a, X, F, nerror) ASL *a; real *X; real *F; fint *nerror;
30 #else
31 con2val_ASL(ASL *a, real *X, real *F, fint *nerror)
32 #endif
33 {
34 cde *d, *dend;
35 expr *e1;
36 expr_v *V;
37 real *cscale, f;
38 int i;
39 cgrad *gr, **gr0;
40 Jmp_buf err_jmp0;
41 ASL_fgh *asl;
42
43 ASL_CHECK(a, ASL_read_fgh, "con2val");
44 asl = (ASL_fgh*)a;
45 if (nerror && *nerror >= 0) {
46 err_jmp = &err_jmp0;
47 i = setjmp(err_jmp0.jb);
48 if (*nerror = i)
49 goto done;
50 }
51 want_deriv = want_derivs;
52 errno = 0; /* in case f77 set errno opening files */
53 if (!asl->i.x_known)
54 x2_check_ASL(asl,X);
55 if (!(x0kind & ASL_have_concom)) {
56 if (comb < combc)
57 com2eval_ASL(asl, comb, combc);
58 if (comc1)
59 com21eval_ASL(asl, 0,comc1);
60 x0kind |= ASL_have_concom;
61 }
62 x0kind |= ASL_have_conval;
63 d = con_de;
64 dend = d + n_conjac[1];
65 co_index = i = n_conjac[0];
66 d += i;
67 if (cscale = asl->i.cscale)
68 cscale += i;
69 for(gr0 = Cgrad + i; d < dend; d++, gr0++, co_index++) {
70 e1 = d->e;
71 f = (*e1->op)(e1 C_ASL);
72 gr = *gr0;
73 if (asl->i.vscale)
74 for(V = var_e; gr; gr = gr->next)
75 f += V[gr->varno].v * gr->coef;
76 else
77 for(; gr; gr = gr->next)
78 f += X[gr->varno] * gr->coef;
79 if (F)
80 *F++ = cscale ? *cscale++ * f : f;
81 }
82 done:
83 err_jmp = 0;
84 }
85
86 void
87 #ifdef KR_headers
jac2val_ASL(a,X,G,nerror)88 jac2val_ASL(a, X, G, nerror) ASL *a; real *X; real *G; fint *nerror;
89 #else
90 jac2val_ASL(ASL *a, real *X, real *G, fint *nerror)
91 #endif
92 {
93 cde *d, *dend;
94 cgrad **gr0;
95 cgrad *gr;
96 real *Adjoints, *cscale, t, *vscale;
97 Jmp_buf err_jmp0;
98 int L, xksave;
99 fint ne0;
100 ASL_fgh *asl;
101 static char who[] = "jac2val";
102
103 ASL_CHECK(a, ASL_read_fgh, who);
104 asl = (ASL_fgh *)a;
105 if (!want_derivs)
106 No_derivs_ASL(who);
107 ne0 = -1;
108 if (nerror && (ne0 = *nerror) >= 0) {
109 err_jmp = &err_jmp0;
110 L = setjmp(err_jmp0.jb);
111 if (*nerror = L)
112 goto done;
113 }
114 errno = 0; /* in case f77 set errno opening files */
115 if (!asl->i.x_known && x2_check_ASL(asl,X)
116 || !(x0kind & ASL_have_conval)) {
117 xksave = asl->i.x_known;
118 asl->i.x_known = 1;
119 con2val_ASL(a, X, 0, nerror);
120 asl->i.x_known = xksave;
121 if (ne0 >= 0 && *nerror)
122 goto done;
123 }
124 Adjoints = adjoints;
125 d = con_de;
126 dend = d + n_conjac[1];
127 d += L = n_conjac[0];
128 if (cscale = asl->i.cscale)
129 cscale += n_conjac[0];
130 if (f_b)
131 fun2set_ASL(asl, f_b);
132 if (f_c)
133 fun2set_ASL(asl, f_c);
134 vscale = asl->i.vscale;
135 for(gr0 = Cgrad + L; d < dend; d++, gr0++) {
136 for(gr = *gr0; gr; gr = gr->next)
137 Adjoints[gr->varno] = gr->coef;
138 if (L = d->zaplen) {
139 memset(adjoints_nv1, 0, L);
140 derprop(d->d);
141 }
142 if (vscale)
143 for(gr = *gr0; gr; gr = gr->next) {
144 L = gr->varno;
145 Adjoints[L] *= vscale[L];
146 }
147 gr = *gr0;
148 if (cscale)
149 for(t = *cscale++; gr; gr = gr->next)
150 G[gr->goff] = t*Adjoints[gr->varno];
151 else
152 for(; gr; gr = gr->next)
153 G[gr->goff] = Adjoints[gr->varno];
154 }
155 done:
156 err_jmp = 0;
157 }
158
159 int
160 #ifdef KR_headers
jac2dim_ASL(asl,stub,M,N,NO,NZ,MXROW,MXCOL,stub_len)161 jac2dim_ASL(asl, stub, M, N, NO, NZ, MXROW, MXCOL, stub_len)
162 ASL *asl; char *stub;
163 fint *M, *N, *NO, *NZ, *MXROW, *MXCOL;
164 ftnlen stub_len;
165 #else
166 jac2dim_ASL(ASL *asl, char *stub, fint *M, fint *N, fint *NO, fint *NZ,
167 fint *MXROW, fint *MXCOL, ftnlen stub_len)
168 #endif
169 {
170 FILE *nl;
171
172 nl = jac_dim_ASL(asl, stub, M, N, NO, NZ, MXROW, MXCOL, stub_len);
173 if (!nl)
174 return ASL_readerr_nofile;
175 X0 = (real *)M1alloc(n_var*sizeof(real));
176 return pfgh_read_ASL(asl, nl, ASL_return_read_err);
177 }
178