| 1 |
/* |
| 2 |
* User Packages |
| 3 |
* by Kirk Abbott |
| 4 |
* Created: July 4, 1994 |
| 5 |
* |
| 6 |
* This file is part of the Ascend Language Interpreter. |
| 7 |
* |
| 8 |
* Copyright (C) 1990, 1993, 1994 Thomas Guthrie Epperly, Kirk Abbott. |
| 9 |
* |
| 10 |
* The Ascend Language Interpreter is free software; you can redistribute |
| 11 |
* it and/or modify it under the terms of the GNU General Public License as |
| 12 |
* published by the Free Software Foundation; either version 2 of the |
| 13 |
* License, or (at your option) any later version. |
| 14 |
* |
| 15 |
* The Ascend Language Interpreter is distributed in hope that it will be |
| 16 |
* useful, but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 17 |
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| 18 |
* General Public License for more details. |
| 19 |
* |
| 20 |
* You should have received a copy of the GNU General Public License |
| 21 |
* along with the program; if not, write to the Free Software Foundation, |
| 22 |
* Inc., 675 Mass Ave, Cambridge, MA 02139 USA. Check the file named |
| 23 |
* COPYING. |
| 24 |
* |
| 25 |
* Last rev in old CVS: 1.14 ballan 1998/03/06 15:47:14 |
| 26 |
*/ |
| 27 |
|
| 28 |
/** |
| 29 |
Code to support dynamic and static loading of user packages. |
| 30 |
|
| 31 |
The default state is to have packages. As such it takes an explicit |
| 32 |
definition of NO_PACKAGES, if packages are not to be handled. |
| 33 |
An explicit definition of STATIC_PACKAGES or DYNAMIC_PACKAGES is also |
| 34 |
required. |
| 35 |
*/ |
| 36 |
#ifndef DYNAMIC_PACKAGES |
| 37 |
# error "WHERE IS THE DYNAMICS PACKAGES #DEF?!" |
| 38 |
#endif |
| 39 |
|
| 40 |
#include <math.h> |
| 41 |
#include <ctype.h> /* was compiler/actype.h */ |
| 42 |
#include "utilities/ascConfig.h" |
| 43 |
#include "compiler/compiler.h" |
| 44 |
#include "utilities/ascMalloc.h" |
| 45 |
#include "general/list.h" |
| 46 |
#include "compiler/symtab.h" |
| 47 |
#include "compiler/fractions.h" |
| 48 |
#include "compiler/dimen.h" |
| 49 |
#include "compiler/functype.h" |
| 50 |
#include "compiler/types.h" |
| 51 |
#include "compiler/extcall.h" |
| 52 |
#include "compiler/mathinst.h" |
| 53 |
#include "compiler/instance_enum.h" |
| 54 |
#include "compiler/instquery.h" |
| 55 |
#include "compiler/atomvalue.h" |
| 56 |
#include "compiler/find.h" |
| 57 |
#include "compiler/relation_type.h" |
| 58 |
#include "compiler/relation.h" |
| 59 |
#include "compiler/safe.h" |
| 60 |
#include "compiler/relation_util.h" |
| 61 |
#include "compiler/extfunc.h" |
| 62 |
#include "packages/sensitivity.h" |
| 63 |
#include "packages/ascFreeAllVars.h" |
| 64 |
#include "compiler/module.h" |
| 65 |
#include "compiler/packages.h" |
| 66 |
|
| 67 |
/* |
| 68 |
Initialise the slv data structures used when calling external fns |
| 69 |
*/ |
| 70 |
void Init_Slv_Interp(struct Slv_Interp *slv_interp) |
| 71 |
{ |
| 72 |
if (slv_interp){ |
| 73 |
slv_interp->nodestamp = 0; |
| 74 |
slv_interp->status = calc_all_ok; |
| 75 |
slv_interp->user_data = NULL; |
| 76 |
slv_interp->first_call = (unsigned)0; |
| 77 |
slv_interp->last_call = (unsigned)0; |
| 78 |
slv_interp->check_args = (unsigned)0; |
| 79 |
slv_interp->recalculate = (unsigned)0; |
| 80 |
slv_interp->func_eval = (unsigned)0; |
| 81 |
slv_interp->deriv_eval = (unsigned)0; |
| 82 |
slv_interp->single_step = (unsigned)0; |
| 83 |
} |
| 84 |
} |
| 85 |
|
| 86 |
/* |
| 87 |
@deprecated, @see packages.h |
| 88 |
*/ |
| 89 |
symchar *MakeArchiveLibraryName(CONST char *prefix) |
| 90 |
{ |
| 91 |
char *buffer; |
| 92 |
int len; |
| 93 |
symchar *result; |
| 94 |
|
| 95 |
len = strlen(prefix); |
| 96 |
buffer = (char *)ascmalloc(len+40); |
| 97 |
|
| 98 |
#ifdef __WIN32__ |
| 99 |
sprintf(buffer,"%s.dll",prefix); |
| 100 |
#elif defined(linux) |
| 101 |
sprintf(buffer,"lib%s.so",prefix); /* changed from .o to .so -- JP */ |
| 102 |
#elif defined(sun) || defined(solaris) |
| 103 |
sprintf(buffer,"%s.so.1.0",prefix); |
| 104 |
#elif defined(__hpux) |
| 105 |
sprintf(buffer,"%s.sl",prefix); |
| 106 |
#elif defined(_SGI_SOURCE) |
| 107 |
sprintf(buffer,"%s.so",prefix); |
| 108 |
#else |
| 109 |
sprintf(buffer,"%s.so.1.0",prefix); |
| 110 |
#endif |
| 111 |
|
| 112 |
result = AddSymbol(buffer); /* the main symbol table */ |
| 113 |
ascfree(buffer); |
| 114 |
return result; /* owns the string */ |
| 115 |
} |
| 116 |
|
| 117 |
/*--------------------------------------------- |
| 118 |
BUILT-IN PACKAGES... |
| 119 |
*/ |
| 120 |
|
| 121 |
/** |
| 122 |
Load builtin packages, unless NO_PACKAGES. |
| 123 |
|
| 124 |
@return 0 if success, 1 if failure. |
| 125 |
*/ |
| 126 |
static |
| 127 |
int Builtins_Init(void) |
| 128 |
{ |
| 129 |
int result = 0; |
| 130 |
|
| 131 |
#ifdef NO_PACKAGES |
| 132 |
ERROR_REPORTER_HERE(ASC_USER_WARNING,"Builtins_Init: DISABLED at compile-time"); |
| 133 |
#else |
| 134 |
ERROR_REPORTER_DEBUG("Builtins_Init: Loading function asc_free_all_variables\n"); |
| 135 |
result = CreateUserFunction("asc_free_all_variables" |
| 136 |
,(ExtEvalFunc *)NULL |
| 137 |
,(ExtEvalFunc **)Asc_FreeAllVars |
| 138 |
,(ExtEvalFunc **)NULL |
| 139 |
,(ExtEvalFunc **)NULL |
| 140 |
,1, 0, "Unset 'fixed' flag of all items of type 'solver_var'"); |
| 141 |
#endif |
| 142 |
return result; |
| 143 |
} |
| 144 |
|
| 145 |
/*--------------------------------------------- |
| 146 |
DYNAMIC_PACKAGES code only... |
| 147 |
*/ |
| 148 |
# ifdef DYNAMIC_PACKAGES |
| 149 |
static char path_var[PATH_MAX]; |
| 150 |
|
| 151 |
/** |
| 152 |
Search the archive library path for a file matching the given |
| 153 |
(platform specific, with extension?) library filename. |
| 154 |
|
| 155 |
@return a pointer to a string space holding the full path |
| 156 |
name of the file to be opened. The returned pointer may be NULL |
| 157 |
|
| 158 |
@TODO won't work correctly on windows |
| 159 |
@deprecated { see packages.h } |
| 160 |
*/ |
| 161 |
static |
| 162 |
char *SearchArchiveLibraryPath(CONST char *name, char *dpath, char *envv) |
| 163 |
{ |
| 164 |
register char *path,*result; |
| 165 |
register CONST char *t; |
| 166 |
register unsigned length; |
| 167 |
register FILE *f; |
| 168 |
/* ERROR_REPORTER_HERE(ASC_PROG_NOTE,"Env var for user packages is '%s'\n",envv); */ |
| 169 |
/* ERROR_REPORTER_HERE(ASC_PROG_NOTE,"Search path for user packages is '%s'\n",getenv(envv)); */ |
| 170 |
if ((path=getenv(envv))==NULL) |
| 171 |
path=dpath; |
| 172 |
while(isspace(*path)) path++; |
| 173 |
while(*path!='\0'){ |
| 174 |
if (*path==':') path++; |
| 175 |
else{ |
| 176 |
length = 0; |
| 177 |
/* copy next directory into array */ |
| 178 |
while((*path!=':')&&(*path!='\0')&&(!isspace(*path))) |
| 179 |
path_var[length++] = *(path++); |
| 180 |
if (path_var[length-1]!='/') |
| 181 |
path_var[length++]='/'; |
| 182 |
|
| 183 |
/* copy file name into array */ |
| 184 |
for(t=name;*t!='\0';){ |
| 185 |
path_var[length++] = *(t++); |
| 186 |
} |
| 187 |
path_var[length]='\0'; |
| 188 |
|
| 189 |
/* ERROR_REPORTER_HERE(ASC_PROG_NOTE,"Searching for for '%s' at '%s'\n",name, path_var); */ |
| 190 |
|
| 191 |
if ((f= fopen(path_var,"r"))!=NULL){ |
| 192 |
result = path_var; |
| 193 |
fclose(f); |
| 194 |
return result; |
| 195 |
} |
| 196 |
} |
| 197 |
while(isspace(*path)) path++; |
| 198 |
} |
| 199 |
return NULL; |
| 200 |
} |
| 201 |
#endif /* DYNAMIC_PACKAGES */ |
| 202 |
/* |
| 203 |
END of DYNAMIC_PACKAGES-specific code |
| 204 |
------------------------------------------*/ |
| 205 |
|
| 206 |
int LoadArchiveLibrary(CONST char *name, CONST char *initfunc) |
| 207 |
{ |
| 208 |
#ifdef NO_PACKAGES |
| 209 |
/** avoid compiler warnings on params: */ |
| 210 |
(void) name; (void) initfunc; |
| 211 |
|
| 212 |
ERROR_REPORTER_HERE(ASC_PROG_ERROR,"LoadArchiveLibrary disabled: NO_PACKAGES"); |
| 213 |
return 1; |
| 214 |
|
| 215 |
#elif defined(DYNAMIC_PACKAGES) |
| 216 |
|
| 217 |
symchar *name_with_extn; |
| 218 |
|
| 219 |
int result; |
| 220 |
char *default_path = "."; |
| 221 |
char *env = PATHENVIRONMENTVAR; |
| 222 |
char *full_file_name = NULL; |
| 223 |
extern int Asc_DynamicLoad(CONST char *,CONST char *); |
| 224 |
|
| 225 |
char initfunc_generated_name[255]; |
| 226 |
|
| 227 |
name_with_extn = MakeArchiveLibraryName(name); |
| 228 |
|
| 229 |
full_file_name = SearchArchiveLibraryPath(name_with_extn,default_path,env); |
| 230 |
if (!full_file_name) { |
| 231 |
ERROR_REPORTER_NOLINE(ASC_USER_ERROR,"The named library '%s' was not found in the search path",name_with_extn); |
| 232 |
return 1; |
| 233 |
} |
| 234 |
|
| 235 |
if(initfunc==NULL){ |
| 236 |
CONSOLE_DEBUG("GENERATING NAME OF INITFUNC"); |
| 237 |
CONSOLE_DEBUG("NAME STEM = %s",name); |
| 238 |
sprintf(initfunc_generated_name,"%s",name); |
| 239 |
strcat(initfunc_generated_name,"_register"); |
| 240 |
CONSOLE_DEBUG("GENERATED NAME = %s",initfunc_generated_name); |
| 241 |
result = Asc_DynamicLoad(full_file_name,initfunc_generated_name); |
| 242 |
}else{ |
| 243 |
result = Asc_DynamicLoad(full_file_name,initfunc); |
| 244 |
} |
| 245 |
|
| 246 |
if (result) { |
| 247 |
return 1; |
| 248 |
} |
| 249 |
if(initfunc==NULL){ |
| 250 |
ERROR_REPORTER_DEBUG("Successfully ran '%s' from dynamic package '%s'\n",initfunc_generated_name,name); |
| 251 |
}else{ |
| 252 |
ERROR_REPORTER_DEBUG("Successfully ran '%s' from dynamic package '%s'\n",initfunc,name); |
| 253 |
} |
| 254 |
return 0; |
| 255 |
|
| 256 |
#elif defined(STATIC_PACKAGES) |
| 257 |
|
| 258 |
/* avoid compiler warnings on params: */ |
| 259 |
(void) name; (void) initfunc; |
| 260 |
|
| 261 |
ERROR_REPORTER_HERE(ASC_PROG_NOTE,"LoadArchiveLibrary disabled: STATIC_PACKAGES, no need to load dynamically.\n"); |
| 262 |
return 0; |
| 263 |
|
| 264 |
#else /* unknown flags */ |
| 265 |
|
| 266 |
# error "Invalid package linking flags" |
| 267 |
(void) name; (void) initfunc; |
| 268 |
return 1; |
| 269 |
|
| 270 |
#endif |
| 271 |
} |
| 272 |
|
| 273 |
/*--------------------------------------------- |
| 274 |
STATIC_PACKAGES code only... |
| 275 |
|
| 276 |
Declare the functions which we are expected to be able to call. |
| 277 |
*/ |
| 278 |
#ifndef NO_PACKAGES |
| 279 |
# ifdef STATIC_PACKAGES |
| 280 |
|
| 281 |
/* kvalues.c */ |
| 282 |
extern int kvalues_preslv(struct Slv_Interp *,struct Instance *, struct gl_list_t *); |
| 283 |
extern int kvalues_fex(struct Slv_Interp *, int, int, double *, double *, double *); |
| 284 |
|
| 285 |
/* bisect.c */ |
| 286 |
extern int do_set_values_eval(struct Slv_Interp *,struct Instance *, struct gl_list_t *); |
| 287 |
extern int do_bisection_eval(struct Slv_Interp *,struct Instance *,struct gl_list_t *); |
| 288 |
|
| 289 |
/* sensitivity.c */ |
| 290 |
extern int do_sensitivity_eval(struct Slv_Interp *,struct Instance *, struct gl_list_t *); |
| 291 |
|
| 292 |
# endif |
| 293 |
#endif |
| 294 |
|
| 295 |
#ifdef STATIC_PACKAGES |
| 296 |
/** |
| 297 |
Load all statically-linked packages |
| 298 |
|
| 299 |
@return 0 on success, >0 if any CreateUserFunction calls failed. |
| 300 |
*/ |
| 301 |
static |
| 302 |
int StaticPackages_Init(void) |
| 303 |
{ |
| 304 |
int result = 0; |
| 305 |
|
| 306 |
char sensitivity_help[] = |
| 307 |
"This function does sensitivity analysis dy/dx. It requires 4 args:\n" |
| 308 |
" 1. name: name of a reference instance or SELF.\n" |
| 309 |
" 2. x: x, where x is an array of > solver_var.\n" |
| 310 |
" 3. y: where y is an array of > solver_var.\n" |
| 311 |
" 4. dy/dx: which dy_dx[1..n_y][1..n_x]."; |
| 312 |
|
| 313 |
result = CreateUserFunction("do_solve", |
| 314 |
(ExtEvalFunc *)NULL, |
| 315 |
(ExtEvalFunc **)do_solve_eval, |
| 316 |
(ExtEvalFunc **)NULL, |
| 317 |
(ExtEvalFunc **)NULL, |
| 318 |
2,0,NULL); |
| 319 |
result += CreateUserFunction("do_finite_difference", |
| 320 |
(ExtEvalFunc *)NULL, |
| 321 |
(ExtEvalFunc **)do_finite_diff_eval, |
| 322 |
(ExtEvalFunc **)NULL, |
| 323 |
(ExtEvalFunc **)NULL, |
| 324 |
4,0,NULL); |
| 325 |
result += CreateUserFunction("do_sensitivity", |
| 326 |
(ExtEvalFunc *)NULL, |
| 327 |
(ExtEvalFunc **)do_sensitivity_eval, |
| 328 |
(ExtEvalFunc **)NULL, |
| 329 |
(ExtEvalFunc **)NULL, |
| 330 |
4,0,sensitivity_help); |
| 331 |
result += CreateUserFunction("do_sensitivity_all", |
| 332 |
(ExtEvalFunc *)NULL, |
| 333 |
(ExtEvalFunc **)do_sensitivity_eval_all, |
| 334 |
(ExtEvalFunc **)NULL, |
| 335 |
(ExtEvalFunc **)NULL, |
| 336 |
4,0,"See do_sensitivity for details"); |
| 337 |
|
| 338 |
return result; |
| 339 |
} |
| 340 |
#endif |
| 341 |
|
| 342 |
/** |
| 343 |
This is a general purpose function that will load whatever user |
| 344 |
functions are required according to the compile-time settings. |
| 345 |
|
| 346 |
If NO_PACKAGES, nothing will be loaded. If DYNAMIC_PACKAGES, then |
| 347 |
just the builtin packages will be loaded. If STATIC_PACKAGES then |
| 348 |
builtin plus those called in 'StaticPackages_Init' will be loaded. |
| 349 |
*/ |
| 350 |
void AddUserFunctions(void) |
| 351 |
{ |
| 352 |
#ifdef NO_PACKAGES |
| 353 |
# ifdef __GNUC__ |
| 354 |
# warning "EXTERNAL PACKAGES ARE BEING DISABLED" |
| 355 |
# endif |
| 356 |
ERROR_REPORTER_NOLINE(ASC_PROG_NOTE,"AddUserFunctions disabled at compile-time."); |
| 357 |
#else |
| 358 |
|
| 359 |
/* Builtins are always statically linked */ |
| 360 |
if (Builtins_Init()) { |
| 361 |
ERROR_REPORTER_NOLINE(ASC_PROG_WARNING,"Problem in Builtins_Init: Some user functions not created"); |
| 362 |
} |
| 363 |
|
| 364 |
# ifdef DYNAMIC_PACKAGES |
| 365 |
/* do nothing */ |
| 366 |
|
| 367 |
# elif defined(STATIC_PACKAGES) |
| 368 |
# ifdef __GNUC__ |
| 369 |
# warning "STATIC PACKAGES" |
| 370 |
# endif |
| 371 |
|
| 372 |
/*The following need to be reimplemented but are basically useful as is. */ |
| 373 |
if (StaticPackages_Init()) { |
| 374 |
ERROR_REPORTER_NOLINE(ASC_PROG_WARNING,"Problem in StaticPackages_Init(): Some user functions not created"); |
| 375 |
} |
| 376 |
|
| 377 |
# endif |
| 378 |
#endif |
| 379 |
} |
| 380 |
|
| 381 |
/*--------------------------------------- |
| 382 |
TESTING FUNCTIONS |
| 383 |
|
| 384 |
The following functions may be called someone desirous of testing |
| 385 |
an external relation provided as a package. They are here |
| 386 |
for convenience, and should be really in a separate file. |
| 387 |
*/ |
| 388 |
|
| 389 |
/** |
| 390 |
What's this do? -- JP |
| 391 |
*/ |
| 392 |
static void LoadInputVector(struct gl_list_t *arglist, |
| 393 |
double *inputs, |
| 394 |
unsigned ninputs, |
| 395 |
unsigned long n_input_args) |
| 396 |
{ |
| 397 |
struct Instance *inst; |
| 398 |
struct gl_list_t *input_list; |
| 399 |
unsigned long c,len; |
| 400 |
|
| 401 |
input_list = LinearizeArgList(arglist,1,n_input_args); |
| 402 |
|
| 403 |
if(!input_list)return; |
| 404 |
|
| 405 |
len = gl_length(input_list); |
| 406 |
|
| 407 |
if(len!=ninputs)return; /* somehow we had inconsistent data */ |
| 408 |
|
| 409 |
for (c=1;c<=len;c++) { |
| 410 |
inst = (struct Instance *)gl_fetch(input_list,c); |
| 411 |
inputs[c-1] = RealAtomValue(inst); |
| 412 |
} |
| 413 |
gl_destroy(input_list); |
| 414 |
} |
| 415 |
|
| 416 |
/** |
| 417 |
What's a black box, and what's a glass box? -- JP |
| 418 |
*/ |
| 419 |
int CallBlackBox(struct Instance *inst, |
| 420 |
CONST struct relation *rel) |
| 421 |
{ |
| 422 |
struct Instance *data; |
| 423 |
|
| 424 |
struct Slv_Interp slv_interp; |
| 425 |
struct ExternalFunc *efunc; |
| 426 |
struct ExtCallNode *ext; |
| 427 |
struct gl_list_t *arglist; |
| 428 |
unsigned long n_input_args, n_output_args; |
| 429 |
int nok = 0; |
| 430 |
|
| 431 |
unsigned long ninputs, noutputs; |
| 432 |
double *inputs = NULL, *outputs = NULL; |
| 433 |
double *jacobian = NULL; |
| 434 |
|
| 435 |
/* All these desperately need a typedef in a header someplace */ |
| 436 |
/* now typedefs in solver/extfunc.h - 1/22/2006 - jds |
| 437 |
int (*init_func) (struct Slv_Interp *, |
| 438 |
struct Instance *, |
| 439 |
struct gl_list_t *); |
| 440 |
|
| 441 |
int (*eval_func)(struct Slv_Interp *, |
| 442 |
int, // n_inputs |
| 443 |
int, // n_outputs |
| 444 |
double *, // inputs |
| 445 |
double * , // outputs |
| 446 |
double * ); // jacobian |
| 447 |
|
| 448 |
int (*deriv_func)(struct Slv_Interp *, |
| 449 |
int, // n_inputs |
| 450 |
int , // n_outputs |
| 451 |
double *, // inputs |
| 452 |
double * , // outputs |
| 453 |
double * ); // jacobian |
| 454 |
*/ |
| 455 |
ExtBBoxInitFunc *init_func; |
| 456 |
ExtBBoxFunc *eval_func; |
| 457 |
ExtBBoxFunc *deriv_func; |
| 458 |
|
| 459 |
/*------------------------------ |
| 460 |
After this point everything should be ok. |
| 461 |
<-- says who? when? -- JP |
| 462 |
*/ |
| 463 |
|
| 464 |
/* Visual C doesn't like this before the func ptr defs. */ |
| 465 |
UNUSED_PARAMETER(inst); |
| 466 |
|
| 467 |
ext = BlackBoxExtCall(rel); |
| 468 |
arglist = ExternalCallArgList(ext); |
| 469 |
data = ExternalCallDataInstance(ext); |
| 470 |
efunc = ExternalCallExtFunc(ext); |
| 471 |
init_func = GetInitFunc(efunc); |
| 472 |
eval_func = GetValueFunc(efunc); |
| 473 |
deriv_func = GetDerivFunc(efunc); |
| 474 |
|
| 475 |
if (init_func && eval_func) { |
| 476 |
|
| 477 |
/* set up the interpreter. */ |
| 478 |
Init_Slv_Interp(&slv_interp); |
| 479 |
slv_interp.check_args = (unsigned)1; |
| 480 |
slv_interp.first_call = (unsigned)1; |
| 481 |
slv_interp.last_call = (unsigned)0; |
| 482 |
slv_interp.nodestamp = ExternalCallNodeStamp(ext); |
| 483 |
n_input_args = NumberInputArgs(efunc); |
| 484 |
n_output_args = NumberOutputArgs(efunc); |
| 485 |
ninputs = CountNumberOfArgs(arglist,1,n_input_args); |
| 486 |
noutputs = CountNumberOfArgs(arglist,n_input_args + 1, |
| 487 |
n_input_args+n_output_args); |
| 488 |
|
| 489 |
/* Create the work vectors. Load the input vector from the instance tree. */ |
| 490 |
inputs = (double *)asccalloc(ninputs,sizeof(double)); |
| 491 |
outputs = (double *)asccalloc(ninputs,sizeof(double)); |
| 492 |
jacobian = (double *)asccalloc(ninputs*noutputs,sizeof(double)); |
| 493 |
LoadInputVector(arglist,inputs,ninputs,n_input_args); |
| 494 |
|
| 495 |
/* |
| 496 |
* Call the init function. |
| 497 |
*/ |
| 498 |
nok = (*init_func)(&slv_interp,data,arglist); |
| 499 |
if (nok) goto error; |
| 500 |
/* |
| 501 |
* Call the evaluation function. |
| 502 |
*/ |
| 503 |
nok = (*eval_func)(&slv_interp,ninputs,noutputs, |
| 504 |
inputs,outputs,jacobian); |
| 505 |
if (nok) goto error; |
| 506 |
/* |
| 507 |
* Call the derivative routine. |
| 508 |
*/ |
| 509 |
if (deriv_func) { |
| 510 |
nok = (*deriv_func)(&slv_interp,ninputs,noutputs, |
| 511 |
inputs,outputs,jacobian); |
| 512 |
if (nok) goto error; |
| 513 |
} |
| 514 |
/* |
| 515 |
* Call the init function to shut down |
| 516 |
*/ |
| 517 |
slv_interp.first_call = (unsigned)0; |
| 518 |
slv_interp.last_call = (unsigned)1; |
| 519 |
nok = (*init_func)(&slv_interp,data,arglist); |
| 520 |
if (nok) goto error; |
| 521 |
} |
| 522 |
else{ |
| 523 |
FPRINTF(ASCERR,"External function not loaded\n"); |
| 524 |
return 1; |
| 525 |
} |
| 526 |
|
| 527 |
error: |
| 528 |
if (inputs) ascfree((char *)inputs); |
| 529 |
if (outputs) ascfree((char *)outputs); |
| 530 |
if (jacobian) ascfree((char *)outputs); |
| 531 |
if (nok) |
| 532 |
return 1; |
| 533 |
else |
| 534 |
return 0; |
| 535 |
} |
| 536 |
|
| 537 |
/** |
| 538 |
When glassbox are registered, they must register a pointer |
| 539 |
to their function jump table. In other words, they must |
| 540 |
register a pointer to an 'array of pointers to functions'. |
| 541 |
This typedef just makes life a little cleaner. |
| 542 |
|
| 543 |
<-- what typedef?? -- JP |
| 544 |
*/ |
| 545 |
int CallGlassBox(struct Instance *relinst, CONST struct relation *rel) |
| 546 |
{ |
| 547 |
CONST struct gl_list_t *incidence; |
| 548 |
struct Instance *var; |
| 549 |
struct ExternalFunc *efunc; |
| 550 |
int index; |
| 551 |
long i; |
| 552 |
double *f, *x, *g; |
| 553 |
int m,mode,result; |
| 554 |
int n; |
| 555 |
|
| 556 |
ExtEvalFunc **evaltable, *eval_func; |
| 557 |
ExtEvalFunc **derivtable, *deriv_func; |
| 558 |
|
| 559 |
(void) relinst; |
| 560 |
incidence = RelationVarList(rel); |
| 561 |
if (!incidence) { |
| 562 |
FPRINTF(ASCERR,"Incidence list is empty -- nothing to evaluate\n"); |
| 563 |
return 0; |
| 564 |
} |
| 565 |
index = GlassBoxRelIndex(rel); |
| 566 |
efunc = GlassBoxExtFunc(rel); |
| 567 |
evaltable = GetValueJumpTable(efunc); |
| 568 |
eval_func = evaltable[index]; |
| 569 |
derivtable = GetDerivJumpTable(efunc); |
| 570 |
deriv_func = derivtable[index]; |
| 571 |
|
| 572 |
m = 0; /* FIX not sure what this should be !!! */ |
| 573 |
n = gl_length(incidence); |
| 574 |
f = (double *)asccalloc((1 + 2*n),sizeof(double)); |
| 575 |
x = &f[1]; |
| 576 |
g = &f[n+1]; |
| 577 |
|
| 578 |
for (i=0;i<n;i++) { |
| 579 |
var = (struct Instance *)gl_fetch(incidence,i+1); |
| 580 |
x[i] = RealAtomValue(var); |
| 581 |
} |
| 582 |
result = (*eval_func)(&mode,&m,&n,x,NULL,f,g); |
| 583 |
result += (*deriv_func)(&mode,&m,&n,x,NULL,f,g); |
| 584 |
|
| 585 |
ascfree((char *)f); |
| 586 |
return result; |
| 587 |
} |
| 588 |
|
| 589 |
/** |
| 590 |
No idea what this does. It's referenced in 'interface.c' only, so it |
| 591 |
appears to be defunct -- JP |
| 592 |
*/ |
| 593 |
int CallExternalProcs(struct Instance *inst) |
| 594 |
{ |
| 595 |
CONST struct relation *rel; |
| 596 |
enum Expr_enum reltype; |
| 597 |
|
| 598 |
if (inst==NULL){ |
| 599 |
FPRINTF(ASCERR,"Instance does not exist for callprocs\n"); |
| 600 |
return 1; |
| 601 |
} |
| 602 |
if (InstanceKind(inst)!=REL_INST){ |
| 603 |
FPRINTF(ASCERR,"Instance is not a relation\n"); |
| 604 |
return 1; |
| 605 |
} |
| 606 |
rel = GetInstanceRelation(inst,&reltype); |
| 607 |
if (!rel) { |
| 608 |
FPRINTF(ASCERR,"Relation structure is NULL\n"); |
| 609 |
return 1; |
| 610 |
} |
| 611 |
switch (reltype) { |
| 612 |
case e_blackbox: |
| 613 |
return CallBlackBox(inst,rel); |
| 614 |
case e_glassbox: |
| 615 |
return CallGlassBox(inst,rel); |
| 616 |
default: |
| 617 |
FPRINTF(ASCERR,"Invalid relation type in CallExternalProc\n"); |
| 618 |
return 1; |
| 619 |
} |
| 620 |
} |
Parent Directory
| 
Revision Log