1 /****************************************************************
2 Copyright (C) 1997-1998 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 /* sample funcadd, K&R C variant */
26
27 #ifndef KR_headers
28 #define KR_headers
29 #endif
30
31 #include "math.h" /* for sqrt */
32 #include "funcadd.h" /* includes stdio1.h */
33
34 char *ix_details_ASL[] = {0}; /* no -i command-line option */
35
36 static AmplExports *AMPL_Exp; /* for fprintf and strtod */
37
38 static real
ginv(al)39 ginv(al) arglist *al; /* generalized inverse of a single argument */
40 {
41 real x = al->ra[0];
42 x = x ? 1./x : 0.;
43 if (al->derivs)
44 *(real *)al->derivs = -x*x;
45 return x;
46 }
47
48 static real
myhypot(al)49 myhypot(al) arglist *al; /* sqrt(x*x + y*y) */
50 {
51 real *d, rv, x, x0, y, y0;
52
53 x = x0 = al->ra[0];
54 y = y0 = al->ra[1];
55
56 if (x < 0.)
57 x = -x;
58 if (y < 0.)
59 y = -y;
60 rv = x;
61 if (x < y) {
62 rv = y;
63 y = x;
64 x = rv;
65 }
66 if (rv) {
67 y /= x;
68 rv = x * sqrt(1. + y*y);
69 if (d = (real *)al->derivs) {
70 d[0] = x0 / rv;
71 d[1] = y0 / rv;
72 }
73 }
74 else if (d = (real *)al->derivs)
75 d[0] = d[1] = 0;
76 return rv;
77 }
78
79 static real
mean(al)80 mean(al) arglist *al; /* mean of arbitrarily many arguments */
81 {
82 real x, z;
83 real *d, *de, *ra;
84 int *at, i, j, n;
85 char *se, *sym;
86 AmplExports *ae = al->AE; /* for fprintf and strtod */
87
88 if ((n = al->n) <= 0)
89 return 0;
90 at = al->at;
91 ra = al->ra;
92 d = de = (real *)al->derivs;
93 x = 0.;
94 for(i = 0; i < n;)
95 if ((j = at[i++]) >= 0) {
96 x += ra[j];
97 ++de;
98 }
99 else {
100 x += strtod(sym = al->sa[-(j+1)], &se);
101 if (*se) {
102 fprintf(Stderr,
103 "mean treating arg %d = \"%s\" as 0\n",
104 i, sym);
105 fflush(Stderr);
106 }
107 }
108 if (d) {
109 z = 1. / n;
110 while(d < de)
111 *d++ = z;
112 }
113 return x / n;
114 }
115
116 void
funcadd(ae)117 funcadd(ae) AmplExports *ae;
118 {
119 AMPL_Exp = ae;
120 /* Insert calls on addfunc here... */
121 /* Arg 3, called argtype, can be 0 or 1:
122 * 0 ==> force all arguments to be numeric
123 * 1 ==> pass both symbolic and numeric arguments.
124 *
125 * Arg 4, called nargs, is interpretted as follows:
126 * >= 0 ==> the function has exactly nargs arguments
127 * <= -1 ==> the function has >= -(nargs+1) arguments.
128 *
129 * Arg 5, funcinfo, is passed to the functions in struct arglist;
130 * it is not used in these examples, so we just pass 0.
131 */
132
133 addfunc("ginv", (ufunc*)ginv, 0, 1, 0);
134 addfunc("hypot", (ufunc*)myhypot, 0, 2, 0);
135 addfunc("mean", (ufunc*)mean, 1, -1, 0);
136 }
137