/[ascend]/trunk/tcltk/generic/interface/SolverProc.c
ViewVC logotype

Contents of /trunk/tcltk/generic/interface/SolverProc.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1576 - (show annotations) (download) (as text)
Sun Aug 5 09:44:07 2007 UTC (12 years, 6 months ago) by jpye
File MIME type: text/x-csrc
File size: 83313 byte(s)
Fixed Tcl/Tk interface for new non-contiguous solver numbering.
1 /*
2 * SolverProc.c
3 * by Kirk Abbott and Ben Allan
4 * Created: 1/94
5 * Version: $Revision: 1.65 $
6 * Version control file: $RCSfile: SolverProc.c,v $
7 * Date last modified: $Date: 2003/08/23 18:43:08 $
8 * Last modified by: $Author: ballan $
9 *
10 * This file is part of the ASCEND Tcl/Tk interface
11 *
12 * Copyright 1997, Carnegie Mellon University
13 *
14 * The ASCEND Tcl/Tk interface is free software; you can redistribute
15 * it and/or modify it under the terms of the GNU General Public License as
16 * published by the Free Software Foundation; either version 2 of the
17 * License, or (at your option) any later version.
18 *
19 * The ASCEND Tcl/Tk interface is distributed in hope that it will be
20 * useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
21 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
22 * General Public License for more details.
23 *
24 * You should have received a copy of the GNU General Public License
25 * along with the program; if not, write to the Free Software Foundation,
26 * Inc., 675 Mass Ave, Cambridge, MA 02139 USA. Check the file named
27 * COPYING. COPYING is found in ../compiler.
28 */
29
30 #define ASC_BUILDING_INTERFACE
31
32 #include <math.h>
33 #include <tcl.h>
34 #include <tk.h>
35
36 #include "SolverProc.h"
37
38 #include <utilities/config.h>
39 #ifdef ASC_SIGNAL_TRAPS
40 # include <utilities/ascSignal.h>
41 #endif
42
43 #include <utilities/ascConfig.h>
44 #include <utilities/ascMalloc.h>
45 #include <general/tm_time.h>
46 #include <general/list.h>
47 #include <general/dstring.h>
48
49 #include <compiler/instance_enum.h>
50 #include <compiler/symtab.h>
51 #include <compiler/instance_io.h>
52 #include <compiler/expr_types.h>
53 #include <compiler/find.h>
54 #include <compiler/rel_blackbox.h>
55 #include <compiler/vlist.h>
56 #include <compiler/relation.h>
57 #include <compiler/functype.h>
58 #include <compiler/func.h>
59 #include <compiler/safe.h>
60 #include <compiler/simlist.h>
61 #include <compiler/relation_util.h>
62 #include <compiler/pending.h>
63 #include <compiler/instance_name.h>
64 #include <compiler/instquery.h>
65 #include <compiler/parentchild.h>
66 #include <compiler/check.h>
67 #include <compiler/stattypes.h>
68 #include <compiler/instantiate.h>
69 #include <compiler/watchpt.h>
70
71 #include <linear/mtx.h>
72
73 #include <system/slv_server.h> /* KHACK: not sure if this should be here */
74 #include <system/system.h>
75 #include <system/cond_config.h>
76 #include <solver/slv_interface.h>
77 #include <solver/solver.h>
78
79 #include "old_utils.h"
80 #include "HelpProc.h"
81 #include "SolverGlobals.h"
82 #include "DisplayProc.h"
83 #include "Commands.h"
84 #include "Qlfdid.h"
85 #include "SimsProc.h"
86 #include "BrowserProc.h"
87 #include "BrowserQuery.h"
88 #include "UnitsProc.h" /* KHACK: not sure if this should be here */
89 #include "ScriptProc.h"
90 #include "Driver.h"
91
92 #define QLFDID_LENGTH 1023
93 #define YORN(b) ((b) ? "YES" : "NO")
94 #define ONEORZERO(b) ((b) ? "1" : "0")
95 #define SNULL (char *)NULL
96 #define SP_DEBUG FALSE
97 /* if true, prints out extra error messages */
98
99 /* global variables: */
100
101 int g_solvinst_ndx, g_solvinst_limit;
102 extern unsigned long g_unresolved_count;
103
104 struct Instance *g_solvinst_root=NULL, /* root instan (child of simulation) */
105 *g_solvinst_cur=NULL; /* top model instance to be solved */
106
107 slv_system_t g_solvsys_cur=NULL; /* a pointer to slv_system_structure */
108 slv_system_t g_browsys_cur=NULL; /* a pointer to slv_system_structure */
109
110 void Asc_SolvMemoryCleanup()
111 {
112 system_free_reused_mem();
113 }
114
115 #ifdef ASC_SIGNAL_TRAPS
116 static
117 void slv_trap_int(int sigval)
118 {
119 Tcl_Interp *interp = g_interp; /* a local ptr to the global interp ptr */
120
121 (void)sigval; /* stop gcc whine about unused parameter */
122
123 FPRINTF(stdout,"\nascend4: SIGINT caught.\n");
124 Solv_C_CheckHalt_Flag = 1; /* need to set the tcl var */
125 Tcl_SetVar2(interp,"ascSolvStatVect","menubreak","1",TCL_GLOBAL_ONLY);
126 Asc_ScriptInterrupt = 1;
127 Asc_SetMethodUserInterrupt(1);
128 FPRINTF(stdout,"Type 'exit', or click Toolbox/exit/Confirm to quit.\n");
129 Asc_SignalRecover(0);
130 Asc_Prompt(interp,0);
131 }
132
133 int Asc_SolvTrapFP(ClientData cdata, Tcl_Interp *interp,
134 int argc, CONST84 char *argv[])
135 {
136
137 UNUSED_PARAMETER(cdata);
138 (void)interp; /* stop gcc whine about unused parameter */
139 (void)argc; /* stop gcc whine about unused parameter */
140 (void)argv; /* stop gcc whine about unused parameter */
141
142 ASCUSE;
143 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
144 Asc_SignalHandlerPush(SIGINT,slv_trap_int);
145 return TCL_OK;
146 }
147
148 int Asc_SolvUnTrapFP(ClientData cdata, Tcl_Interp *interp,
149 int argc, CONST84 char *argv[])
150 {
151 UNUSED_PARAMETER(cdata);
152 (void)interp; /* stop gcc whine about unused parameter */
153 (void)argc; /* stop gcc whine about unused parameter */
154 (void)argv; /* stop gcc whine about unused parameter */
155
156 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
157 return TCL_OK;
158 }
159
160 int Asc_SolvTrapINT(ClientData cdata, Tcl_Interp *interp,
161 int argc, CONST84 char *argv[])
162 {
163
164 UNUSED_PARAMETER(cdata);
165 (void)interp; /* stop gcc whine about unused parameter */
166 (void)argc; /* stop gcc whine about unused parameter */
167 (void)argv; /* stop gcc whine about unused parameter */
168
169 ASCUSE;
170 Asc_SignalHandlerPush(SIGINT,slv_trap_int);
171 return TCL_OK;
172 }
173
174 int Asc_SolvUnTrapINT(ClientData cdata, Tcl_Interp *interp,
175 int argc, CONST84 char *argv[])
176 {
177 UNUSED_PARAMETER(cdata);
178 (void)interp; /* stop gcc whine about unused parameter */
179 (void)argc; /* stop gcc whine about unused parameter */
180 (void)argv; /* stop gcc whine about unused parameter */
181
182 Asc_SignalHandlerPop(SIGINT,slv_trap_int);
183 return TCL_OK;
184 }
185 #endif /* ASC_SIGNAL_TRAPS */
186
187 int Asc_SolvGetModKids(ClientData cdata, Tcl_Interp *interp,
188 int argc, CONST84 char *argv[])
189 {
190 char tmps[QLFDID_LENGTH+1];
191 struct Instance *modinst_root=NULL; /* model instance */
192 struct Instance *aryinst_root=NULL; /* possible model instance */
193 struct Instance *aryinst=NULL; /* possible model instance kid*/
194 struct InstanceName rec;
195 enum inst_t ikind,aikind;
196 unsigned long len,c,aryc,arylen;
197 int status;
198
199 UNUSED_PARAMETER(cdata);
200
201 if ( argc != 2 ) {
202 Tcl_SetResult(interp, "expected get_model_children <qlfdid>", TCL_STATIC);
203 return TCL_ERROR;
204 }
205
206 status = Asc_QlfdidSearch3(argv[1],0);
207 if (status==0) {
208 modinst_root = g_search_inst; /* catch inst ptr */
209 } else {
210 Tcl_AppendResult(interp,"get_model_children: QlfdidSearch error: ",
211 argv[1], " not found",SNULL);
212 return TCL_ERROR;
213 }
214
215 /* check that instance is model */
216 ikind=InstanceKind(modinst_root);
217 if (ikind!=MODEL_INST && ikind!=ARRAY_INT_INST && ikind!= ARRAY_ENUM_INST) {
218 FPRINTF(ASCERR, "Instance specified is not a model or array.\n");
219 Tcl_SetResult(interp,
220 "Only MODEL and ARRAY instances may have model children.",
221 TCL_STATIC);
222 return TCL_ERROR;
223 }
224
225 len=NumberChildren(modinst_root);
226 for (c=1;c<=len;c++) {
227 ikind=InstanceKind(InstanceChild(modinst_root,c));
228 switch (ikind) {
229 case MODEL_INST:
230 Tcl_AppendElement(interp,
231 (char *)InstanceNameStr(ChildName(modinst_root,c)));
232 break;
233 case ARRAY_INT_INST:
234 case ARRAY_ENUM_INST: /*dumpary names*/
235 aryinst_root=InstanceChild(modinst_root,c);
236 arylen=NumberChildren(aryinst_root);
237 for (aryc=1;aryc<=arylen;aryc++) {
238 aryinst=InstanceChild(aryinst_root,aryc);
239 aikind=InstanceKind(aryinst);
240 switch (aikind) {
241 case MODEL_INST:
242 case ARRAY_INT_INST: /* write array names in case any children */
243 case ARRAY_ENUM_INST: /* are models */
244 rec=ChildName(aryinst_root,aryc);
245 Asc_BrowWriteNameRec(&tmps[0],&rec);
246 Tcl_AppendResult(interp," {",
247 InstanceNameStr(ChildName(modinst_root,c)),&tmps[0],"}",SNULL);
248 default: /*write nothing */
249 break;
250 }
251 }
252 break;
253 default: /* write nothing if its not a model or ary child */
254 break;
255 }
256 }
257 return TCL_OK;
258 }
259
260 int Asc_SolvIncompleteSim(ClientData cdata, Tcl_Interp *interp,
261 int argc, CONST84 char *argv[])
262 {
263 unsigned long pendings;
264
265 UNUSED_PARAMETER(cdata);
266
267 if ( argc != 2 ) {
268 FPRINTF(ASCERR, "call is: slv_checksim <simname>\n");
269 Tcl_SetResult(interp, "error in call to slv_checksim", TCL_STATIC);
270 return TCL_ERROR;
271 }
272
273
274 g_solvinst_root = Asc_FindSimulationRoot(AddSymbol(argv[1]));
275
276
277 if (!g_solvinst_root) {
278 FPRINTF(ASCERR, "Solve called with NULL root instance.\n");
279 Tcl_SetResult(interp, "Simulation specified not found.", TCL_STATIC);
280 return TCL_ERROR;
281 }
282 pendings = NumberPendingInstances(g_solvinst_root);
283 if (pendings>0) {
284 FPRINTF(ASCERR,"Found %lu pendings.",pendings);
285 Tcl_SetResult(interp, "1", TCL_STATIC);
286 } else {
287 Tcl_SetResult(interp, "0", TCL_STATIC);
288 }
289 return TCL_OK;
290 }
291
292 int Asc_SolvCheckSys(ClientData cdata, Tcl_Interp *interp,
293 int argc, CONST84 char *argv[])
294 {
295 UNUSED_PARAMETER(cdata);
296 (void)argc; /* stop gcc whine about unused parameter */
297 (void)argv; /* stop gcc whine about unused parameter */
298
299 if (g_solvsys_cur != NULL) {
300 Tcl_SetResult(interp, "1", TCL_STATIC);
301 } else {
302 Tcl_SetResult(interp, "0", TCL_STATIC);
303 }
304 return TCL_OK;
305 }
306
307 int Asc_SolvGetObjList(ClientData cdata, Tcl_Interp *interp,
308 int argc, CONST84 char *argv[])
309 {
310 int32 *rip=NULL;
311 char tmps[MAXIMUM_NUMERIC_LENGTH];
312 int i,dev,status;
313 FILE *fp;
314
315 UNUSED_PARAMETER(cdata);
316
317 if ( argc != 2 ) {
318 FPRINTF(ASCERR, "call is: slv_get_obj_list <out>\n");
319 Tcl_SetResult(interp, "slv_get_obj_list wants output device.", TCL_STATIC);
320 return TCL_ERROR;
321 }
322 if (g_solvsys_cur==NULL) {
323 FPRINTF(ASCERR, "slv_get_obj_list called with NULL pointer\n");
324 Tcl_SetResult(interp, "slv_get_obj_list called without slv_system",
325 TCL_STATIC);
326 return TCL_ERROR;
327 }
328 /* get io option */
329 i=3;
330 status=Tcl_GetInt(interp,argv[1],&i);
331 if (i<0 || i >2) {
332 status=TCL_ERROR;
333 }
334 if (status!=TCL_OK) {
335 FPRINTF(ASCERR,"slv_get_obj_list: first arg is 0,1, or 2\n");
336 Tcl_ResetResult(interp);
337 Tcl_SetResult(interp, "slv_get_obj_list: invalid output dev #",TCL_STATIC);
338 return status;
339 } else {
340 dev=i;
341 }
342 switch (dev) {
343 case 0: fp=stdout;
344 break;
345 case 1: fp=ASCERR;
346 break;
347 case 2: fp=NULL;
348 break;
349 default : /* should never be here */
350 FPRINTF(ASCERR,"slv_get_obj_list called with strange i/o option\n");
351 return TCL_ERROR;
352 }
353 if (slv_obj_select_list(g_solvsys_cur,&rip)) {
354 switch (dev) {
355 case 0:
356 case 1:
357 FPRINTF(fp,"Objective indices:\n");
358 for (i=0;rip[i]>-1;i++) {
359 FPRINTF(fp,"%d\n",rip[i]);
360 }
361 break;
362 case 2:
363 Tcl_AppendResult(interp,"{",SNULL);
364 for (i=0;rip[i]>-1;i++) {
365 sprintf(tmps,"%d ",rip[i]);
366 Tcl_AppendResult(interp,tmps,SNULL);
367 }
368 Tcl_AppendResult(interp,"}",SNULL);
369 break;
370 default:
371 FPRINTF(ASCERR,"wierdness in i/o!");
372 break;
373 }
374 ascfree(rip);
375 } else {
376 Tcl_SetResult(interp, "{}", TCL_STATIC);
377 }
378 return TCL_OK;
379 }
380
381 int Asc_SolvSetObjByNum(ClientData cdata, Tcl_Interp *interp,
382 int argc, CONST84 char *argv[])
383 {
384 int32 i,status,len;
385 struct rel_relation **rlist=NULL;
386
387 UNUSED_PARAMETER(cdata);
388
389 if ( argc != 2 ) {
390 FPRINTF(ASCERR, "call is: slv_set_obj_by_num <num>\n");
391 Tcl_SetResult(interp, "slv_set_obj_by_num wants objective number.",
392 TCL_STATIC);
393 return TCL_ERROR;
394 }
395 if (g_solvsys_cur==NULL) {
396 FPRINTF(ASCERR, "slv_set_obj_by_num called with NULL pointer\n");
397 Tcl_SetResult(interp, "slv_set_obj_by_num called without slv_system",
398 TCL_STATIC);
399 return TCL_ERROR;
400 }
401 /* get io option */
402 i=0;
403 status=Tcl_GetInt(interp,argv[1],&i);
404 len = slv_get_num_solvers_objs(g_solvsys_cur);
405
406 if (i == -1) { /* remove objective and return */
407 slv_set_obj_relation(g_solvsys_cur,NULL);
408 return TCL_OK;
409 }
410 if (i<0 || i >= len) {
411 status=TCL_ERROR;
412 }
413 if (status!=TCL_OK) {
414 FPRINTF(ASCERR,"slv_set_obj_by_num: invalid objective number\n");
415 Tcl_ResetResult(interp);
416 Tcl_SetResult(interp, "slv_set_obj_by_num: invalid objective number",
417 TCL_STATIC);
418 return status;
419 } else {
420 rlist = slv_get_solvers_obj_list(g_solvsys_cur);
421 slv_set_obj_relation(g_solvsys_cur,rlist[i]);
422 }
423 return TCL_OK;
424 }
425
426 STDHLF(Asc_SolvGetObjNumCmd,(Asc_SolvGetObjNumCmdHL,HLFSTOP));
427 int Asc_SolvGetObjNumCmd(ClientData cdata, Tcl_Interp *interp,
428 int argc, CONST84 char *argv[])
429 {
430 char tmps[MAXIMUM_NUMERIC_LENGTH];
431 int num,i,dev,status;
432 FILE *fp;
433
434 ASCUSE; /* see if first arg is -help */
435
436 UNUSED_PARAMETER(cdata);
437
438 if ( argc != 2 ) {
439 FPRINTF(ASCERR, "call is: slv_get_obj_num <out>\n");
440 Tcl_SetResult(interp, "slv_get_obj_num wants output device.", TCL_STATIC);
441 return TCL_ERROR;
442 }
443 if (g_solvsys_cur==NULL) {
444 FPRINTF(ASCERR, "slv_get_obj_num called with NULL pointer\n");
445 Tcl_SetResult(interp, "slv_get_obj_num called without slv_system",
446 TCL_STATIC);
447 return TCL_ERROR;
448 }
449 /* get io option */
450 i=3;
451 status=Tcl_GetInt(interp,argv[1],&i);
452 if (i<0 || i >2) {
453 status=TCL_ERROR;
454 }
455 if (status!=TCL_OK) {
456 FPRINTF(ASCERR,"slv_get_obj_num: first arg is 0,1, or 2\n");
457 Tcl_ResetResult(interp);
458 Tcl_SetResult(interp, "slv_get_obj_num: invalid output dev #",TCL_STATIC);
459 return status;
460 } else {
461 dev=i;
462 }
463 switch (dev) {
464 case 0: fp=stdout;
465 break;
466 case 1: fp=ASCERR;
467 break;
468 case 2: fp=NULL;
469 break;
470 default : /* should never be here */
471 FPRINTF(ASCERR,"slv_get_obj_num called with strange i/o option\n");
472 return TCL_ERROR;
473 }
474 num = slv_get_obj_num(g_solvsys_cur);
475 switch (dev) {
476 case 0:
477 case 1:
478 FPRINTF(fp,"Objective index: ");
479 FPRINTF(fp,"%d\n",num);
480 break;
481 case 2:
482 sprintf(tmps,"%d ",num);
483 Tcl_AppendResult(interp,tmps,SNULL);
484 break;
485 default:
486 FPRINTF(ASCERR,"weirdness in i/o!");
487 break;
488 }
489 return TCL_OK;
490 }
491
492 int Asc_SolvGetSlvParmsNew(ClientData cdata, Tcl_Interp *interp,
493 int argc, CONST84 char *argv[])
494 {
495 slv_parameters_t p;
496 char *tmps = NULL;
497 int solver;
498 int status=TCL_OK;
499 int i,j;
500 p.num_parms = 0;
501 p.parms = NULL;
502
503 UNUSED_PARAMETER(cdata);
504
505 if ( argc != 2 ) {
506 FPRINTF(ASCERR, "call is: slv_get_parmsnew <solver number>\n");
507 Tcl_SetResult(interp, "error in call to slv_get_parmsnew", TCL_STATIC);
508 return TCL_ERROR;
509 }
510 status=Tcl_GetInt(interp, argv[1], &solver);
511 if(!solver_engine(solver) || (status==TCL_ERROR)) {
512 FPRINTF(ASCERR, "slv_get_parmsnew: solver unknown!\n");
513 Tcl_ResetResult(interp);
514 Tcl_SetResult(interp, "slv_get_parmsnew: solver number unknown",
515 TCL_STATIC);
516 return TCL_ERROR;
517 }
518
519 slv_get_default_parameters(solver,&p);
520 tmps=ASC_NEW_ARRAY(char,MAXIMUM_NUMERIC_LENGTH+1);
521
522 for (i = 0; i < p.num_parms; i++) {
523 Tcl_AppendElement(interp,"New_Parm");
524 switch (p.parms[i].type) {
525 case int_parm:
526 Tcl_AppendElement(interp,"int_parm");
527 break;
528 case bool_parm:
529 Tcl_AppendElement(interp,"bool_parm");
530 break;
531 case real_parm:
532 Tcl_AppendElement(interp,"real_parm");
533 break;
534 case char_parm:
535 Tcl_AppendElement(interp,"char_parm");
536 break;
537 default:
538 Tcl_AppendElement(interp,"error");
539 continue;
540 }
541
542 Tcl_AppendElement(interp,p.parms[i].name);
543 Tcl_AppendElement(interp,p.parms[i].interface_label);
544
545 switch (p.parms[i].type) {
546 case int_parm:
547 sprintf(tmps,"%d",p.parms[i].info.i.value);
548 Tcl_AppendElement(interp,tmps);
549 sprintf(tmps,"%d",p.parms[i].info.i.high);
550 Tcl_AppendElement(interp,tmps);
551 sprintf(tmps,"%d",p.parms[i].info.i.low);
552 Tcl_AppendElement(interp,tmps);
553 break;
554 case bool_parm:
555 sprintf(tmps,"%d",p.parms[i].info.b.value);
556 Tcl_AppendElement(interp,tmps);
557 sprintf(tmps,"%d",p.parms[i].info.b.high);
558 Tcl_AppendElement(interp,tmps);
559 sprintf(tmps,"%d",p.parms[i].info.b.low);
560 Tcl_AppendElement(interp,tmps);
561 break;
562 case real_parm:
563 sprintf(tmps,"%.6e",p.parms[i].info.r.value);
564 Tcl_AppendElement(interp,tmps);
565 sprintf(tmps,"%.6e",p.parms[i].info.r.high);
566 Tcl_AppendElement(interp,tmps);
567 sprintf(tmps,"%.6e",p.parms[i].info.r.low);
568 Tcl_AppendElement(interp,tmps);
569 break;
570 case char_parm:
571 Tcl_AppendElement(interp,p.parms[i].info.c.value);
572 sprintf(tmps,"%d",p.parms[i].info.c.high);
573 Tcl_AppendElement(interp,tmps);
574 for (j = 0; j < p.parms[i].info.c.high; j++) {
575 Tcl_AppendElement(interp,p.parms[i].info.c.argv[j]);
576 }
577 break;
578 default:
579 FPRINTF(ASCERR, "slv_get_parmsnew found unrecognized");
580 FPRINTF(ASCERR, " parameter type\n");
581 break;
582 }
583 sprintf(tmps,"%d",p.parms[i].display);
584 Tcl_AppendElement(interp,tmps);
585 Tcl_AppendElement(interp,p.parms[i].description);
586 }
587 slv_destroy_parms(&p);
588 ascfree(tmps);
589 return TCL_OK;
590 }
591
592
593 int Asc_SolvSetSlvParmsNew(ClientData cdata, Tcl_Interp *interp,
594 int argc, CONST84 char *argv[])
595 {
596 slv_parameters_t p;
597 int tmp_int =0, solver,i,j;
598 double tmp_double = 0.1;
599
600 UNUSED_PARAMETER(cdata);
601
602 if (g_solvsys_cur==NULL) {
603 FPRINTF(ASCERR, "set_slv_parms called with NULL pointer\n");
604 Tcl_SetResult(interp,"set_slv_parms called without slv_system",TCL_STATIC);
605 return TCL_ERROR;
606 }
607
608 solver=0;
609 if (Tcl_GetInt(interp,argv[1],&solver)==TCL_ERROR) {
610 Tcl_ResetResult(interp);
611 Tcl_SetResult(interp, "set_slv_parms: arg 1 invalid type", TCL_STATIC);
612 return TCL_ERROR;
613 }
614 Tcl_ResetResult(interp);
615 i = slv_get_selected_solver(g_solvsys_cur);
616
617 if ( solver != i ) {
618 /* THIS WHOLE CONTROL STRUCTURE IS SCREWED UP AT BOTH THE
619 * C AND THE TCL LEVEL!!!
620 */
621 CONSOLE_DEBUG("...");
622 slv_select_solver(g_solvsys_cur,solver);
623 /* FPRINTF(ASCERR,"Warning: Solv_Set_Slv_Parms called ");
624 * FPRINTF(ASCERR,"with solver other than current solver\n");
625 * return TCL_OK;
626 */
627 }
628 slv_get_parameters(g_solvsys_cur,&p);
629
630 if ((argc - 2) != (p.num_parms)) {
631 /* calling function in slot 0 and solver number in slot 1 */
632 Tcl_SetResult(interp, "set_slv_parms called with wrong number of args.",
633 TCL_STATIC);
634 FPRINTF(ASCERR,
635 "set_slv_parms expected %d args for %s\n",(p.num_parms + 1),
636 slv_solver_name(p.whose));
637 FPRINTF(ASCERR, "actual argument count: %d\n", (argc - 1));
638 FPRINTF(ASCERR, "expected argument count: %d\n", (p.num_parms + 1));
639 return TCL_ERROR;
640 }
641
642 for (j = 2,i = 0; i < p.num_parms; j++,i++) {
643 switch (p.parms[i].type) {
644 case int_parm:
645 if (Tcl_GetInt(interp,argv[j],&tmp_int)==TCL_ERROR) {
646 Tcl_ResetResult(interp);
647 FPRINTF(ASCERR,"set_slv_parms: arg %d of invalid type",j);
648 Tcl_SetResult(interp, "set_slv_parms called with invalid type",
649 TCL_STATIC);
650 return TCL_ERROR;
651 }
652 p.parms[i].info.i.value = tmp_int;
653 break;
654
655 case bool_parm:
656 if (Tcl_GetInt(interp,argv[j],&tmp_int)==TCL_ERROR) {
657 Tcl_ResetResult(interp);
658 FPRINTF(ASCERR,"set_slv_parms: arg %d of invalid type",j);
659 Tcl_SetResult(interp, "set_slv_parms called with invalid type",
660 TCL_STATIC);
661 return TCL_ERROR;
662 }
663 p.parms[i].info.b.value = tmp_int;
664 break;
665
666 case real_parm:
667 if (Tcl_GetDouble(interp,argv[j],&tmp_double)==TCL_ERROR) {
668 Tcl_ResetResult(interp);
669 FPRINTF(ASCERR,"set_slv_parms: arg %d of invalid type",j);
670 Tcl_SetResult(interp, "set_slv_parms called with invalid type",
671 TCL_STATIC);
672 return TCL_ERROR;
673 }
674 p.parms[i].info.r.value = tmp_double;
675 break;
676
677 case char_parm:
678 slv_set_char_parameter(&(p.parms[i].info.c.value),(CONST char *)argv[j]);
679 break;
680 default:
681 FPRINTF(ASCERR, "slv_get_parmsnew found unrecognized");
682 FPRINTF(ASCERR, " parameter type\n");
683 }
684 }
685 slv_set_parameters(g_solvsys_cur,&p);
686 return TCL_OK;
687 }
688
689
690 /* NBP is the number of basic parameters in the slv_parameters_t plus 1
691 that we mess with in Asc_SolvGetSlvParms, Asc_SolvSetSlvParms.
692 If you add a parameter to this that is handled here, up NBP */
693 #undef NBP
694 #define NBP 15
695 int Asc_SolvGetSlvParms(ClientData cdata, Tcl_Interp *interp,
696 int argc, CONST84 char *argv[])
697 {
698 slv_parameters_t p;
699 char *tmps = NULL;
700 int cursolver;
701 int solver;
702 int status=TCL_OK;
703 int i,n;
704
705 UNUSED_PARAMETER(cdata);
706
707 if ( argc != 2 ) {
708 ERROR_REPORTER_HERE(ASC_PROG_ERR,"call is: slv_get_parms <solver number>\n");
709 Tcl_SetResult(interp, "error in call to slv_get_parms", TCL_STATIC);
710 return TCL_ERROR;
711 }
712 if (g_solvsys_cur==NULL) {
713 ERROR_REPORTER_HERE(ASC_PROG_ERR,"called with NULL pointer\n");
714 Tcl_SetResult(interp,"slv_get_parms called without slv_system",TCL_STATIC);
715 return TCL_ERROR;
716 }
717 status=Tcl_GetInt(interp, argv[1], &solver);
718
719 if(!solver_engine(solver) || status==TCL_ERROR){
720 ERROR_REPORTER_HERE(ASC_PROG_ERR,"solver '%d' unknown!\n",solver);
721 Tcl_ResetResult(interp);
722 Tcl_SetResult(interp, "slv_get_parms: solver number unknown", TCL_STATIC);
723 return TCL_ERROR;
724 }
725
726 /* get parameters for solver*/
727 cursolver=slv_get_selected_solver(g_solvsys_cur);
728 CONSOLE_DEBUG("...");
729 slv_select_solver(g_solvsys_cur,solver);
730 slv_get_parameters(g_solvsys_cur,&p);
731 tmps= (char *)ascmalloc((MAXIMUM_NUMERIC_LENGTH+1)*sizeof(char));
732
733 sprintf(tmps,"%d", p.whose);
734 Tcl_AppendElement(interp,tmps);
735 sprintf(tmps,"%.16g", p.time_limit);
736 Tcl_AppendElement(interp,tmps);
737 sprintf(tmps,"%d", p.iteration_limit);
738 Tcl_AppendElement(interp,tmps);
739 sprintf(tmps,"%.16g", p.tolerance.termination);
740 Tcl_AppendElement(interp,tmps);
741 sprintf(tmps,"%.16g", p.tolerance.feasible);
742 Tcl_AppendElement(interp,tmps);
743 sprintf(tmps,"%.16g", p.tolerance.pivot);
744 Tcl_AppendElement(interp,tmps);
745 sprintf(tmps,"%.16g", p.tolerance.singular);
746 Tcl_AppendElement(interp,tmps);
747 sprintf(tmps,"%.16g", p.tolerance.stationary);
748 Tcl_AppendElement(interp,tmps);
749 sprintf(tmps,"%.16g", p.rho);
750 Tcl_AppendElement(interp,tmps);
751 sprintf(tmps,"%s", ONEORZERO(p.partition));
752 Tcl_AppendElement(interp,tmps);
753 sprintf(tmps,"%s", ONEORZERO(p.ignore_bounds));
754 Tcl_AppendElement(interp,tmps);
755 sprintf(tmps,"%s", ONEORZERO(p.output.more_important!= NULL));
756 Tcl_AppendElement(interp,tmps);
757 sprintf(tmps,"%s", ONEORZERO(p.output.less_important!= NULL));
758 Tcl_AppendElement(interp,tmps);
759 sprintf(tmps,"%d", p.factor_option);
760 Tcl_AppendElement(interp,tmps);
761
762 if (p.sp.iap) {
763 n = p.sp.ilen;
764 } else {
765 n = 0;
766 }
767 for (i=0;i<n;i++) {
768 sprintf(tmps,"%d",p.sp.iap[i]);
769 Tcl_AppendElement(interp,tmps);
770 }
771 if (p.sp.rap) {
772 n = p.sp.rlen;
773 } else {
774 n = 0;
775 }
776 for (i=0;i<n;i++) {
777 sprintf(tmps,"%.16g",p.sp.rap[i]);
778 Tcl_AppendElement(interp,tmps);
779 }
780 if (p.sp.cap) {
781 n = p.sp.clen;
782 } else {
783 n = 0;
784 }
785 for (i=0;i<n;i++) {
786 Tcl_AppendElement(interp,p.sp.cap[i]);
787 }
788 ascfree(tmps);
789 CONSOLE_DEBUG("...");
790 slv_select_solver(g_solvsys_cur,cursolver);
791 return TCL_OK;
792 }
793
794 int Asc_SolvSetSlvParms(ClientData cdata, Tcl_Interp *interp,
795 int argc, CONST84 char *argv[])
796 {
797 slv_parameters_t p;
798 int tmpbool =0, solver,i,nia,nra;
799
800 int nca = 0; /* modified by CWS 5/95 -
801 have one character subparameter too */
802
803 int32 tmplong =100;
804 double tmpdouble = 0.1;
805 char *tmpchar;
806
807 UNUSED_PARAMETER(cdata);
808
809 if (g_solvsys_cur==NULL) {
810 FPRINTF(ASCERR, "set_slv_parms called with NULL pointer\n");
811 Tcl_SetResult(interp,"set_slv_parms called without slv_system",TCL_STATIC);
812 return TCL_ERROR;
813 }
814
815 if (argc < NBP) {
816 FPRINTF(ASCERR, "call is: set_slv_parms <%d args>\n",NBP-1);
817 FPRINTF(ASCERR, "args are:\n");
818 FPRINTF(ASCERR, "solver number\n");
819 FPRINTF(ASCERR, "time_limit(sec)\n");
820 FPRINTF(ASCERR, "iteration_limit\n");
821
822 FPRINTF(ASCERR, "termination tolerance\n");
823 FPRINTF(ASCERR, "feasible tolerance\n");
824 FPRINTF(ASCERR, "pivot tolerance\n");
825 FPRINTF(ASCERR, "singular tolerance\n");
826 FPRINTF(ASCERR, "stationary tolerance\n");
827 FPRINTF(ASCERR, "rho\n");
828
829 FPRINTF(ASCERR, "partitioning enabled\n");
830 FPRINTF(ASCERR, "ignore bounds\n");
831 FPRINTF(ASCERR, "display more important messages\n");
832 FPRINTF(ASCERR, "display less important messages\n");
833 FPRINTF(ASCERR, "factor_option number\n");
834 FPRINTF(ASCERR, "plus engine specific int and real parms\n");
835
836 FFLUSH(ASCERR);
837 Tcl_SetResult(interp, "in set_slv_parms call", TCL_STATIC);
838 return TCL_ERROR;
839 }
840 solver=0;
841 if (Tcl_GetInt(interp,argv[1],&solver)==TCL_ERROR) {
842 Tcl_ResetResult(interp);
843 Tcl_SetResult(interp, "set_slv_parms: arg 1 invalid type", TCL_STATIC);
844 return TCL_ERROR;
845 }
846 Tcl_ResetResult(interp);
847 i=slv_get_selected_solver(g_solvsys_cur);
848
849 if ( solver != i ) {
850 /* THIS WHOLE CONTROL STRUCTURE IS SCREWED UP AT BOTH THE
851 C AND THE TCL LEVEL!!! */
852 CONSOLE_DEBUG("...");
853 slv_select_solver(g_solvsys_cur,solver);
854 /* FPRINTF(ASCERR,"Warning: Solv_Set_Slv_Parms called ");
855 FPRINTF(ASCERR,"with solver other than current solver\n");
856 return TCL_OK;*/
857 }
858 slv_get_parameters(g_solvsys_cur,&p);
859
860 /* if (p.whose!=solver) return TCL_OK; *//* fail quietly, user is an idiot */
861
862 /* determine number of total parameters we need from user */
863 if (p.sp.iap) {
864 nia = p.sp.ilen;
865 } else {
866 nia = 0;
867 }
868 if (p.sp.rap) {
869 nra = p.sp.rlen;
870 } else {
871 nra = 0;
872 }
873 if (p.sp.cap) {
874 nca = p.sp.clen;
875 } else {
876 nca = 0;
877 }
878 if (argc != (NBP+nia+nra+nca)) { /*args 0 to NBP-1 are the slv0 standard */
879 Tcl_SetResult(interp, "set_slv_parms called with wrong number of args.",
880 TCL_STATIC);
881 FPRINTF(ASCERR,
882 "set_slv_parms expected %d args for %s\n",(NBP -1+nia+nra+nca),
883 slv_solver_name(p.whose));
884 FPRINTF(ASCERR, "actual argument count: %d\n", argc);
885 FPRINTF(ASCERR, "expected argument count: %d\n", NBP+nia+nra+nca);
886 FPRINTF(ASCERR, "basic: %d\n", NBP-1);
887 FPRINTF(ASCERR, "integer: %d\n", nia);
888 FPRINTF(ASCERR, "double: %d\n", nra);
889 FPRINTF(ASCERR, "string: %d\n", nca);
890 return TCL_ERROR;
891 }
892
893 tmpdouble=p.time_limit;
894 if( Tcl_GetDouble(interp,argv[2],&tmpdouble)==TCL_ERROR) {
895 Tcl_ResetResult(interp);
896 Tcl_SetResult(interp, "set_slv_parms: arg 2 invalid type", TCL_STATIC);
897 return TCL_ERROR;
898 }
899 p.time_limit=fabs(tmpdouble);
900
901 tmplong=p.iteration_limit;
902 if (Tcl_GetInt(interp,argv[3],&tmplong)==TCL_ERROR) {
903 Tcl_ResetResult(interp);
904 Tcl_SetResult(interp, "set_slv_parms: arg 3 invalid type", TCL_STATIC);
905 return TCL_ERROR;
906 }
907 p.iteration_limit = abs(tmplong);
908
909 tmpdouble=p.tolerance.termination;
910 if(Tcl_GetDouble(interp,argv[4],&tmpdouble)==TCL_ERROR) {
911 Tcl_ResetResult(interp);
912 Tcl_SetResult(interp, "set_slv_parms: arg 4 invalid type", TCL_STATIC);
913 return TCL_ERROR;
914 }
915 p.tolerance.termination =fabs(tmpdouble);
916
917 tmpdouble=p.tolerance.feasible;
918 if (Tcl_GetDouble(interp,argv[5],&tmpdouble)==TCL_ERROR) {
919 Tcl_ResetResult(interp);
920 Tcl_SetResult(interp, "set_slv_parms: arg 5 invalid type", TCL_STATIC);
921 return TCL_ERROR;
922 }
923 p.tolerance.feasible =fabs(tmpdouble);
924
925 tmpdouble=p.tolerance.pivot;
926 if (Tcl_GetDouble(interp,argv[6],&tmpdouble)==TCL_ERROR) {
927 Tcl_ResetResult(interp);
928 Tcl_SetResult(interp, "set_slv_parms: arg 6 invalid type", TCL_STATIC);
929 return TCL_ERROR;
930 }
931 p.tolerance.pivot =fabs(tmpdouble);
932
933 tmpdouble=p.tolerance.singular;
934 if (Tcl_GetDouble(interp,argv[7],&tmpdouble)==TCL_ERROR) {
935 Tcl_ResetResult(interp);
936 Tcl_SetResult(interp, "set_slv_parms: arg 7 invalid type", TCL_STATIC);
937 return TCL_ERROR;
938 }
939 p.tolerance.singular =fabs(tmpdouble);
940
941 tmpdouble=p.tolerance.stationary;
942 if (Tcl_GetDouble(interp,argv[8],&tmpdouble)==TCL_ERROR) {
943 Tcl_ResetResult(interp);
944 Tcl_SetResult(interp, "set_slv_parms: arg 8 invalid type", TCL_STATIC);
945 return TCL_ERROR;
946 }
947 p.tolerance.stationary =fabs(tmpdouble);
948
949 tmpdouble=p.rho;
950 if (Tcl_GetDouble(interp,argv[9],&tmpdouble)==TCL_ERROR) {
951 Tcl_ResetResult(interp);
952 Tcl_SetResult(interp, "set_slv_parms: arg 9 invalid type", TCL_STATIC);
953 return TCL_ERROR;
954 }
955 p.rho =fabs(tmpdouble);
956
957 tmpbool=p.partition;
958 if(Tcl_ExprBoolean(interp,argv[10],&tmpbool)==TCL_ERROR) {
959 Tcl_ResetResult(interp);
960 Tcl_SetResult(interp, "set_slv_parms: arg 10 invalid type", TCL_STATIC);
961 return TCL_ERROR;
962 }
963 p.partition=tmpbool;
964
965 tmpbool=p.ignore_bounds;
966 if ( Tcl_ExprBoolean(interp,argv[11],&tmpbool)==TCL_ERROR) {
967 Tcl_ResetResult(interp);
968 Tcl_SetResult(interp, "set_slv_parms: arg 11 invalid type", TCL_STATIC);
969 return TCL_ERROR;
970 }
971 p.ignore_bounds=tmpbool;
972
973 if (Tcl_ExprBoolean(interp,argv[12],&tmpbool)==TCL_ERROR) {
974 Tcl_ResetResult(interp);
975 Tcl_SetResult(interp, "set_slv_parms: arg 12 invalid type", TCL_STATIC);
976 return TCL_ERROR;
977 }
978 if (tmpbool) {
979 p.output.more_important=ASCERR;
980 } else {
981 p.output.more_important=NULL;
982 }
983
984 if (Tcl_ExprBoolean(interp,argv[13],&tmpbool)==TCL_ERROR) {
985 Tcl_ResetResult(interp);
986 Tcl_SetResult(interp, "set_slv_parms: arg 13 invalid type", TCL_STATIC);
987 return TCL_ERROR;
988 }
989 if (tmpbool) {
990 p.output.less_important=ASCERR;
991 } else {
992 p.output.less_important=NULL;
993 }
994
995 tmplong=p.factor_option;
996 if (Tcl_GetInt(interp,argv[14],&tmplong)==TCL_ERROR) {
997 Tcl_ResetResult(interp);
998 Tcl_SetResult(interp, "set_slv_parms: arg 14 invalid type", TCL_STATIC);
999 return TCL_ERROR;
1000 }
1001 p.factor_option = abs(tmplong);
1002
1003 for (i=0;i<nia;i++) {
1004 tmpbool=p.sp.iap[i];
1005 if (Tcl_GetInt(interp,argv[i+NBP],&tmpbool)==TCL_ERROR) {
1006 Tcl_ResetResult(interp);
1007 Tcl_SetResult(interp, "set_slv_parms: integer array arg of invalid type",
1008 TCL_STATIC);
1009 FPRINTF(ASCERR,"int sub-parameter %d (%s) invalid\n",i,argv[i+NBP]);
1010 return TCL_ERROR;
1011 }
1012 p.sp.iap[i]=tmpbool;
1013 }
1014
1015 for (i=0;i<nra;i++) {
1016 tmpdouble=p.sp.rap[i];
1017 if (Tcl_GetDouble(interp,argv[i+NBP+nia],&tmpdouble)==TCL_ERROR) {
1018 Tcl_ResetResult(interp);
1019 Tcl_SetResult(interp, "set_slv_parms: real array arg of invalid type",
1020 TCL_STATIC);
1021 FPRINTF(ASCERR,"real sub-parameter %d (%s) invalid\n",
1022 i,argv[i+nia+NBP]);
1023 return TCL_ERROR;
1024 }
1025 p.sp.rap[i]=tmpdouble;
1026 }
1027
1028 /* modified by CWS 5/95
1029 Loop through and copy the strings from TCL land
1030 to the C side of things. The strings are deallocated
1031 in slvI_destroy (slv6_destroy in this case).
1032 */
1033
1034 for (i=0;i<nca;i++) {
1035 tmpchar =
1036 Asc_MakeInitString(strlen(argv[i+NBP+nia+nra])); /* allocate mem */
1037 strcpy(tmpchar, argv[i+NBP+nia+nra]); /* make a copy of string */
1038 if (p.sp.cap[i] != NULL) {
1039 ascfree(p.sp.cap[i]);
1040 }
1041 /* deallocate old, if any */
1042 p.sp.cap[i] = tmpchar; /* save pointer */
1043 }
1044
1045
1046 slv_set_parameters(g_solvsys_cur,&p);
1047 return TCL_OK;
1048 }
1049 #undef NBP
1050
1051 int Asc_SolvGetInstType(ClientData cdata, Tcl_Interp *interp,
1052 int argc, CONST84 char *argv[])
1053 {
1054 char * it;
1055
1056 UNUSED_PARAMETER(cdata);
1057 (void)argv; /* stop gcc whine about unused parameter */
1058
1059 if ( argc != 1 ) {
1060 FPRINTF(ASCERR, "call is: slv_get_insttype <no args>\n");
1061 Tcl_SetResult(interp, "error in call to slv_get_insttype", TCL_STATIC);
1062 return TCL_ERROR;
1063 }
1064 if (g_solvsys_cur==NULL) {
1065 /* FPRINTF(ASCERR, "slv_get_insttype called with NULL pointer\n");
1066 */
1067 Tcl_SetResult(interp, "slv_get_insttype called without slv_system",
1068 TCL_STATIC);
1069 return TCL_ERROR;
1070 }
1071 if (g_solvinst_cur==NULL) {
1072 /* FPRINTF(ASCERR, "slv_get_insttype called with NULL instance\n");
1073 */
1074 Tcl_SetResult(interp, "slv_get_insttype called without instance",
1075 TCL_STATIC);
1076 return TCL_ERROR;
1077 }
1078 it=(char *)InstanceType(g_solvinst_cur);
1079 Tcl_AppendElement(interp,it);
1080 return TCL_OK;
1081 }
1082
1083 int Asc_SolvGetSlvStatPage(ClientData cdata, Tcl_Interp *interp,
1084 int argc, CONST84 char *argv[])
1085 {
1086 slv_status_t s;
1087 char * tmps=NULL;
1088
1089 UNUSED_PARAMETER(cdata);
1090 (void)argv; /* stop gcc whine about unused parameter */
1091
1092 if ( argc != 1 ) {
1093 FPRINTF(ASCERR, "call is: slv_get_stat_page <no args>\n");
1094 Tcl_SetResult(interp, "error in call to slv_get_stat_page", TCL_STATIC);
1095 return TCL_ERROR;
1096 }
1097 if (g_solvsys_cur==NULL) {
1098 FPRINTF(ASCERR, "slv_get_stat_page called with NULL pointer\n");
1099 Tcl_SetResult(interp, "slv_get_stat_page called without slv_system",
1100 TCL_STATIC);
1101 return TCL_ERROR;
1102 }
1103
1104 slv_get_status(g_solvsys_cur,&s);
1105
1106 tmps= (char *)ascmalloc((MAXIMUM_NUMERIC_LENGTH+1)*sizeof(char));
1107 /*system status */
1108 sprintf(tmps,"%d",s.ok);
1109 Tcl_AppendElement(interp,tmps);
1110 sprintf(tmps,"%d",s.over_defined);
1111 Tcl_AppendElement(interp,tmps);
1112 sprintf(tmps,"%d",s.under_defined);
1113 Tcl_AppendElement(interp,tmps);
1114 sprintf(tmps,"%d",s.struct_singular);
1115 Tcl_AppendElement(interp,tmps);
1116 sprintf(tmps,"%d",s.ready_to_solve);
1117 Tcl_AppendElement(interp,tmps);
1118 sprintf(tmps,"%d",s.converged);
1119 Tcl_AppendElement(interp,tmps);
1120 sprintf(tmps,"%d",s.diverged);
1121 Tcl_AppendElement(interp,tmps);
1122 sprintf(tmps,"%d",s.inconsistent);
1123 Tcl_AppendElement(interp,tmps);
1124 sprintf(tmps,"%d",s.calc_ok);
1125 Tcl_AppendElement(interp,tmps);
1126 sprintf(tmps,"%d",s.iteration_limit_exceeded);
1127 Tcl_AppendElement(interp,tmps);
1128 sprintf(tmps,"%d",s.time_limit_exceeded);
1129 Tcl_AppendElement(interp,tmps);
1130 sprintf(tmps,"%d",s.iteration);
1131 Tcl_AppendElement(interp,tmps);
1132 sprintf(tmps,"%.16g",s.cpu_elapsed);
1133 Tcl_AppendElement(interp,tmps);
1134
1135 /*block status*/
1136 sprintf(tmps,"%d",s.block.number_of);
1137 Tcl_AppendElement(interp,tmps);
1138 sprintf(tmps,"%d",s.block.current_block);
1139 Tcl_AppendElement(interp,tmps);
1140 sprintf(tmps,"%d",s.block.current_size);
1141 Tcl_AppendElement(interp,tmps);
1142 sprintf(tmps,"%d",s.block.previous_total_size);
1143 Tcl_AppendElement(interp,tmps);
1144 sprintf(tmps,"%d",s.block.iteration);
1145 Tcl_AppendElement(interp,tmps);
1146 sprintf(tmps,"%.10g",s.block.cpu_elapsed);
1147 Tcl_AppendElement(interp,tmps);
1148 sprintf(tmps,"%.10g",s.block.residual);
1149 Tcl_AppendElement(interp,tmps);
1150 ascfree(tmps);
1151 return TCL_OK;
1152 }
1153 int Asc_SolvGetSlvCostPage(ClientData cdata, Tcl_Interp *interp,
1154 int argc, CONST84 char *argv[])
1155 {
1156 slv_status_t s;
1157 int i;
1158
1159 UNUSED_PARAMETER(cdata);
1160 (void)argv; /* stop gcc whine about unused parameter */
1161
1162 if ( argc != 1 ) {
1163 FPRINTF(ASCERR, "call is: slv_get_cost_page <no args>\n");
1164 Tcl_SetResult(interp, "error in call to slv_get_cost_page", TCL_STATIC);
1165 return TCL_ERROR;
1166 }
1167 if (g_solvsys_cur==NULL) {
1168 FPRINTF(ASCERR, "slv_get_cost_page called with NULL pointer\n");
1169 Tcl_SetResult(interp, "slv_get_cost_page called without slv_system",
1170 TCL_STATIC);
1171 return TCL_ERROR;
1172 }
1173
1174 slv_get_status(g_solvsys_cur,&s);
1175
1176 if (s.cost) {
1177 char * tmps=NULL;
1178 tmps= (char *)ascmalloc((MAXIMUM_NUMERIC_LENGTH+1)*sizeof(char));
1179 sprintf(tmps,"%s","\0");
1180 for (i=0;i<s.costsize;i++) {
1181 if (!i) {
1182 sprintf(tmps,"{%d ",s.cost[i].size);
1183 } else {
1184 sprintf(tmps," {%d ",s.cost[i].size);
1185 }
1186 Tcl_AppendResult(interp,tmps,SNULL);
1187 sprintf(tmps, "%d ",s.cost[i].iterations);
1188 Tcl_AppendResult(interp,tmps,SNULL);
1189 sprintf(tmps, "%d ",s.cost[i].funcs);
1190 Tcl_AppendResult(interp,tmps,SNULL);
1191 sprintf(tmps, "%d ",s.cost[i].jacs);
1192 Tcl_AppendResult(interp,tmps,SNULL);
1193 sprintf(tmps, "%.8g ",s.cost[i].time);
1194 Tcl_AppendResult(interp,tmps,SNULL);
1195 sprintf(tmps, "%.16g ",s.cost[i].resid);
1196 Tcl_AppendResult(interp,tmps,SNULL);
1197 sprintf(tmps, "%.8g ",s.cost[i].functime);
1198 Tcl_AppendResult(interp,tmps,SNULL);
1199 sprintf(tmps, "%.8g}",s.cost[i].jactime);
1200 Tcl_AppendResult(interp,tmps,SNULL);
1201 }
1202 ascfree(tmps);
1203 }
1204 return TCL_OK;
1205 }
1206
1207 int Asc_SolvGetObjectiveVal(ClientData cdata, Tcl_Interp *interp,
1208 int argc, CONST84 char *argv[])
1209 {
1210 struct rel_relation *obj;
1211
1212 UNUSED_PARAMETER(cdata);
1213 (void)argv; /* stop gcc whine about unused parameter */
1214
1215 if ( argc != 1 ) {
1216 FPRINTF(ASCERR, "call is: slv_get_objval <no args>\n");
1217 Tcl_SetResult(interp, "error in call to slv_get_objval", TCL_STATIC);
1218 return TCL_ERROR;
1219 }
1220 if (g_solvsys_cur==NULL) {
1221 FPRINTF(ASCERR, "slv_get_objval called with NULL pointer\n");
1222 Tcl_SetResult(interp, "slv_get_objval called without slv_system",
1223 TCL_STATIC);
1224 return TCL_ERROR;
1225 }
1226
1227 obj= slv_get_obj_relation(g_solvsys_cur);
1228 if( obj == NULL ) {
1229 Tcl_SetResult(interp, "none", TCL_STATIC);
1230 } else {
1231 /* expect the solver to have updated the objects list valeus */
1232 Tcl_AppendResult(interp,Asc_UnitValue(rel_instance(obj)),SNULL);
1233 #if 0
1234 tmps= (char *)ascmalloc((MAXIMUM_NUMERIC_LENGTH+1)*sizeof(char));
1235 val = relman_eval(obj,&calc_ok,1);
1236 sprintf(&tmps[0],"%.16g",val);
1237 Tcl_AppendElement(interp,&tmps[0]);
1238 ascfree(tmps);
1239 /* old code */
1240 val = exprman_eval(NULL/*bug*/,obj); /* broken */
1241 if (obj->negate) {
1242 val=-val;
1243 }
1244 /* obj->negate set TRUE by system_build */
1245 sprintf(&tmps[0],"%.16g",val);
1246 Tcl_AppendElement(interp,&tmps[0]);
1247 #endif
1248 }
1249 return TCL_OK;
1250 }
1251
1252 int Asc_SolvGetInstName(ClientData cdata, Tcl_Interp *interp,
1253 int argc, CONST84 char *argv[])
1254 {
1255 char *name=NULL;
1256
1257 UNUSED_PARAMETER(cdata);
1258 (void)argv; /* stop gcc whine about unused parameter */
1259
1260 if ( argc != 1 ) {
1261 FPRINTF(ASCERR,"call is: slv_get_instname\n");
1262 Tcl_SetResult(interp, "slv_get_instname wants 0 args", TCL_STATIC);
1263 return TCL_ERROR;
1264 }
1265 if (g_solvinst_cur==NULL || g_solvinst_root==NULL) {
1266 #if SP_DEBUG
1267 FPRINTF(ASCERR, "slv_get_instname called with NULL pointer\n");
1268 #endif
1269 Tcl_SetResult(interp, "none", TCL_STATIC);
1270 return TCL_OK;
1271 }
1272 if (g_solvinst_cur==g_solvinst_root) {
1273 Tcl_SetResult(interp, "&", TCL_STATIC);
1274 return TCL_OK;
1275 }
1276 name=WriteInstanceNameString(g_solvinst_cur,g_solvinst_root);
1277 Tcl_AppendResult(interp,name,SNULL);
1278 if (name) {
1279 ascfree(name);
1280 }
1281 return TCL_OK;
1282 }
1283
1284 int Asc_SolvGetPathName(ClientData cdata, Tcl_Interp *interp,
1285 int argc, CONST84 char *argv[])
1286 {
1287 char *name=NULL;
1288
1289 UNUSED_PARAMETER(cdata);
1290 (void)argv; /* stop gcc whine about unused parameter */
1291
1292 if ( argc != 1 ) {
1293 FPRINTF(ASCERR,"call is: slv_get_pathname\n");
1294 Tcl_SetResult(interp, "slv_get_pathname wants 0 args", TCL_STATIC);
1295 return TCL_ERROR;
1296 }
1297 if (g_solvinst_cur==NULL || g_solvinst_root==NULL) {
1298 #if SP_DEBUG
1299 FPRINTF(ASCERR, "slv_get_pathname called with NULL pointer\n");
1300 #endif
1301 Tcl_SetResult(interp, "none", TCL_STATIC);
1302 return TCL_OK;
1303 }
1304 name = (char *)SCP(Asc_SimsFindSimulationName(g_solvinst_root));
1305 Tcl_AppendResult(interp,name,SNULL);
1306 name=NULL;
1307 if (g_solvinst_cur!=g_solvinst_root) {
1308 name=WriteInstanceNameString(g_solvinst_cur,g_solvinst_root);
1309 Tcl_AppendResult(interp,".",name,SNULL);
1310 if (name) {
1311 ascfree(name);
1312 }
1313 }
1314 return TCL_OK;
1315 }
1316
1317
1318 #if 0
1319 /*
1320 * Solves g_curinst with solver specified.
1321 * This is for commandline use only.
1322 * Just a wrapper of slv_interface.c Solve() for now.
1323 * no proper type checking yet, sincle solve will trap it (usually)
1324 * though there should be by 1-14-94
1325 */
1326 int Asc_SolvCurInst(ClientData cdata, Tcl_Interp *interp,
1327 int argc, CONST84 char *argv[])
1328 {
1329 UNUSED_PARAMETER(cdata);
1330 (void)argv; /* stop gcc whine about unused parameter */
1331
1332 if ( argc != 2 ) {
1333 FPRINTF(ASCERR, "call is: solve\n");
1334 Tcl_SetResult(interp, "solvers available: 0:SLV, 1:MINOS", TCL_STATIC);
1335 return TCL_ERROR;
1336 }
1337 if (!g_curinst) {
1338 FPRINTF(ASCERR, "Solve called with NULL current instance.\n");
1339 Tcl_SetResult(interp, "NULL pointer received from Browser.", TCL_STATIC);
1340 return TCL_ERROR;
1341 }
1342 g_solvinst_cur=g_curinst;
1343 FPRINTF(ASCERR,"Windows will not update until you leave Solve>.\n");
1344 Solve(g_solvinst_cur);
1345 return TCL_OK;
1346 }
1347 #endif
1348
1349 int Asc_SolvGetVRCounts(ClientData cdata, Tcl_Interp *interp,
1350 int argc, CONST84 char *argv[])
1351 {
1352 int solver;
1353 int status=TCL_OK;
1354 char * tmps=NULL;
1355 int tmpi;
1356 var_filter_t vfilter;
1357 rel_filter_t rfilter;
1358
1359 UNUSED_PARAMETER(cdata);
1360
1361 tmps= (char *)ascmalloc((MAXIMUM_NUMERIC_LENGTH+1)*sizeof(char));
1362
1363 if ( argc != 2 ) {
1364 FPRINTF(ASCERR, "call is: solve_get_vr <solver number> \n");
1365 Tcl_SetResult(interp, "call is: solve_get_vr <solver number>", TCL_STATIC);
1366 return TCL_ERROR;
1367 }
1368 status=Tcl_GetInt(interp, argv[1], &solver);
1369 if (status!=TCL_OK) {
1370 FPRINTF(ASCERR, "solve_get_vr called with bad solver number.\n");
1371 Tcl_ResetResult(interp);
1372 Tcl_SetResult(interp, "solve_get_vr called with bad solver number.",
1373 TCL_STATIC);
1374 return TCL_ERROR;
1375 }
1376 if(!solver_engine(solver)){
1377 FPRINTF(ASCERR, "unknown solver (%d). Not selected!\n",solver);
1378 Tcl_SetResult(interp, "Solver not available.", TCL_STATIC);
1379 return TCL_ERROR;
1380 }
1381 if (!g_solvsys_cur) {
1382 FPRINTF(ASCERR, "solve_get_vr called with NULL system.\n");
1383 Tcl_SetResult(interp, "solve_get_vr: called with NULL system.",
1384 TCL_STATIC);
1385 return TCL_ERROR;
1386 }
1387
1388 /*get total relation count totrels */
1389 tmpi = slv_get_num_solvers_rels(g_solvsys_cur);
1390 sprintf(tmps,"%d",tmpi);
1391 Tcl_AppendElement(interp,tmps);
1392
1393 /*get active relation count rels */
1394 rfilter.matchbits = (REL_ACTIVE);
1395 rfilter.matchvalue = (REL_ACTIVE);
1396 tmpi=slv_count_solvers_rels(g_solvsys_cur,&rfilter);
1397 sprintf(tmps,"%d",tmpi);
1398 Tcl_AppendElement(interp,tmps);
1399
1400 /*get included relation count inc_rels */
1401 rfilter.matchbits = (REL_INCLUDED);
1402 rfilter.matchvalue = (REL_INCLUDED);
1403 tmpi=slv_count_solvers_rels(g_solvsys_cur,&rfilter);
1404 sprintf(tmps,"%d",tmpi);
1405 Tcl_AppendElement(interp,tmps);
1406
1407 /*get total variable count totvars */
1408 tmpi = slv_get_num_solvers_vars(g_solvsys_cur);
1409 sprintf(tmps,"%d",tmpi);
1410 Tcl_AppendElement(interp,tmps);
1411
1412 /*get active variable count vars*/
1413 vfilter.matchbits = (VAR_ACTIVE);
1414 vfilter.matchvalue = (VAR_ACTIVE);
1415 tmpi=slv_count_solvers_vars(g_solvsys_cur,&vfilter);
1416 sprintf(tmps,"%d",tmpi);
1417 Tcl_AppendElement(interp,tmps);
1418
1419 /*get currently used (free & incident & active) variable count free_vars*/
1420 vfilter.matchbits = (VAR_FIXED | VAR_INCIDENT | VAR_ACTIVE);
1421 vfilter.matchvalue = (VAR_INCIDENT | VAR_ACTIVE);
1422 tmpi=slv_count_solvers_vars(g_solvsys_cur,&vfilter);
1423 sprintf(tmps,"%d",tmpi);
1424 Tcl_AppendElement(interp,tmps);
1425
1426 /*get active equality count eqals*/
1427 rfilter.matchbits = (REL_EQUALITY | REL_ACTIVE);
1428 rfilter.matchvalue = (REL_EQUALITY | REL_ACTIVE);
1429 tmpi=slv_count_solvers_rels(g_solvsys_cur,&rfilter);
1430 sprintf(tmps,"%d",tmpi);
1431 Tcl_AppendElement(interp,tmps);
1432
1433 /*get used (included and active equalities) relation count inc_eqals*/
1434 rfilter.matchbits = (REL_INCLUDED | REL_EQUALITY | REL_ACTIVE);
1435 rfilter.matchvalue = (REL_INCLUDED | REL_EQUALITY | REL_ACTIVE);
1436 tmpi=slv_count_solvers_rels(g_solvsys_cur,&rfilter);
1437 sprintf(tmps,"%d",tmpi);
1438 Tcl_AppendElement(interp,tmps);
1439
1440 /*get inequality count ineqals*/
1441 rfilter.matchbits = (REL_EQUALITY | REL_ACTIVE);
1442 rfilter.matchvalue = (REL_ACTIVE);
1443 tmpi = slv_count_solvers_rels(g_solvsys_cur,&rfilter);
1444 sprintf(tmps,"%d",tmpi);
1445 Tcl_AppendElement(interp,tmps);
1446
1447 /*get included inequality count inc_ineqals*/
1448 rfilter.matchbits = (REL_INCLUDED | REL_EQUALITY | REL_ACTIVE);
1449 rfilter.matchvalue = (REL_INCLUDED | REL_ACTIVE);
1450 tmpi = slv_count_solvers_rels(g_solvsys_cur,&rfilter);
1451 sprintf(tmps,"%d",tmpi);
1452 Tcl_AppendElement(interp,tmps);
1453
1454 /* get unused (included and inactive equalities) relation count
1455 * in_inc_eqals
1456 */
1457 rfilter.matchbits = (REL_INCLUDED | REL_EQUALITY | REL_ACTIVE);
1458 rfilter.matchvalue = (REL_INCLUDED | REL_EQUALITY);
1459 tmpi=slv_count_solvers_rels(g_solvsys_cur,&rfilter);
1460 sprintf(tmps,"%d",tmpi);
1461 Tcl_AppendElement(interp,tmps);
1462
1463 /*get included inactive inequality count in_inc_ineqals*/
1464 rfilter.matchbits = (REL_INCLUDED | REL_EQUALITY | REL_ACTIVE);
1465 rfilter.matchvalue = (REL_INCLUDED);
1466 tmpi = slv_count_solvers_rels(g_solvsys_cur,&rfilter);
1467 sprintf(tmps,"%d",tmpi);
1468 Tcl_AppendElement(interp,tmps);
1469
1470 /*get unincluded relation count uninc_rels */
1471 rfilter.matchbits = (REL_INCLUDED);
1472 rfilter.matchvalue = 0;
1473 tmpi=slv_count_solvers_rels(g_solvsys_cur,&rfilter);
1474 sprintf(tmps,"%d",tmpi);
1475 Tcl_AppendElement(interp,tmps);
1476
1477 /*get fixed and incident count fixed_vars*/
1478 vfilter.matchbits = (VAR_FIXED | VAR_INCIDENT | VAR_ACTIVE);
1479 vfilter.matchvalue = (VAR_FIXED | VAR_INCIDENT | VAR_ACTIVE);
1480 tmpi=slv_count_solvers_vars(g_solvsys_cur,&vfilter);
1481 sprintf(tmps,"%d",tmpi);
1482 Tcl_AppendElement(interp,tmps);
1483
1484 /*get free and inactive incident count in_free_vars*/
1485 vfilter.matchbits = (VAR_FIXED | VAR_INCIDENT | VAR_ACTIVE);
1486 vfilter.matchvalue = (VAR_INCIDENT);
1487 tmpi=slv_count_solvers_vars(g_solvsys_cur,&vfilter);
1488 sprintf(tmps,"%d",tmpi);
1489 Tcl_AppendElement(interp,tmps);
1490
1491 /*get fixed and inactive incident count in_fixed_vars*/
1492 vfilter.matchbits = (VAR_FIXED | VAR_INCIDENT | VAR_ACTIVE);
1493 vfilter.matchvalue = (VAR_FIXED | VAR_INCIDENT);
1494 tmpi=slv_count_solvers_vars(g_solvsys_cur,&vfilter);
1495 sprintf(tmps,"%d",tmpi);
1496 Tcl_AppendElement(interp,tmps);
1497
1498 /*get active unattached count un_vars */
1499 vfilter.matchbits = (VAR_ACTIVE);
1500 vfilter.matchvalue = (VAR_ACTIVE);
1501 tmpi = slv_count_solvers_unattached(g_solvsys_cur,&vfilter);
1502 sprintf(tmps,"%d",tmpi);
1503 Tcl_AppendElement(interp,tmps);
1504
1505 ascfree(tmps);
1506 return TCL_OK;
1507 }
1508
1509 int Asc_SolvSlvDumpInt(ClientData cdata, Tcl_Interp *interp,
1510 int argc, CONST84 char *argv[])
1511 {
1512 int status,level;
1513
1514 UNUSED_PARAMETER(cdata);
1515
1516 if ( argc != 2 ) {
1517 FPRINTF(ASCERR, "call is: slvdump <level>\n");
1518 Tcl_SetResult(interp, "Specify a level to slvdump.", TCL_STATIC);
1519 return TCL_ERROR;
1520 }
1521 status=Tcl_GetInt(interp,argv[1],&level);
1522 if (status!=TCL_OK) {
1523 FPRINTF(ASCERR, "slvdump called with non-integer level.\n");
1524 Tcl_ResetResult(interp);
1525 Tcl_SetResult(interp, "slvdump called with non-integer level.",TCL_STATIC);
1526 return TCL_ERROR;
1527 }
1528 if (g_solvsys_cur!=NULL) {
1529 slv_dump_internals(g_solvsys_cur,level);
1530 } else {
1531 FPRINTF(ASCERR, "slvdump called with NULL system.\n");
1532 Tcl_SetResult(interp, "Empty solver context.", TCL_STATIC);
1533 return TCL_ERROR;
1534 }
1535 return TCL_OK;
1536 }
1537
1538
1539 int Asc_SolvSlvPresolve(ClientData cdata, Tcl_Interp *interp,
1540 int argc, CONST84 char *argv[])
1541 {
1542 UNUSED_PARAMETER(cdata);
1543 (void)argv; /* stop gcc whine about unused parameter */
1544
1545 if ( argc != 1 ) {
1546 FPRINTF(ASCERR, "call is: presolve <no args>\n");
1547 Tcl_SetResult(interp, "no arguments allowed for presolve", TCL_STATIC);
1548 return TCL_ERROR;
1549 }
1550
1551 #ifdef ASC_SIGNAL_TRAPS
1552 if (SETJMP(g_fpe_env)==0) {
1553 #endif /* ASC_SIGNAL_TRAPS */
1554 if (g_solvsys_cur!=NULL) {
1555 slv_presolve(g_solvsys_cur);
1556 return TCL_OK;
1557 } else {
1558 FPRINTF(ASCERR, "Presolve called with NULL system.\n");
1559 Tcl_SetResult(interp, "empty solver context.", TCL_STATIC);
1560 return TCL_ERROR;
1561 }
1562 #ifdef ASC_SIGNAL_TRAPS
1563 } else {
1564 FPRINTF(ASCERR, "Floating point exception in slv_presolve!!\n");
1565 Tcl_SetResult(interp, " Floating point exception in slv_presolve. Help!",
1566 TCL_STATIC);
1567 return TCL_ERROR;
1568 }
1569 #endif /* ASC_SIGNAL_TRAPS */
1570 }
1571
1572 /* After modification of an instance included in a when var list or
1573 * after running a procedure, the system must be reconfigured to
1574 * account for structural changes in the configuration.
1575 * Asc_SolvReanalyze has to be executed after running a procedure.
1576 */
1577 int Asc_SolvReanalyze(ClientData cdata, Tcl_Interp *interp,
1578 int argc, CONST84 char *argv[])
1579 {
1580 UNUSED_PARAMETER(cdata);
1581 (void)argv; /* stop gcc whine about unused parameter */
1582
1583 if ( argc != 1 ) {
1584 FPRINTF(ASCERR, "call is: slv_reanalyze <no args>\n");
1585 Tcl_SetResult(interp, "wong # arguments for slv_reanalyze", TCL_STATIC);
1586 return TCL_ERROR;
1587 }
1588 if (g_solvsys_cur!=NULL) {
1589 system_reanalyze(g_solvsys_cur);
1590 return TCL_OK;
1591 } else {
1592 FPRINTF(ASCERR, "Reanalyze called with NULL system.\n");
1593 Tcl_SetResult(interp, "empty solver context.", TCL_STATIC);
1594 return TCL_ERROR;
1595 }
1596 }
1597
1598 /*
1599 * This function needs to be fixed. Right now it does the same as
1600 * Asc_SolvReanalyze. Here, we are supposed to check if the boolean
1601 * instance modified is part of some whenvarlist, in the current
1602 * solver system. The instance to be checked is going to be sent
1603 * as the second argument to system_reanalyze.
1604 */
1605 int Asc_SolvCheckAndReanalyze(ClientData cdata, Tcl_Interp *interp,
1606 int argc, CONST84 char *argv[])
1607 {
1608 UNUSED_PARAMETER(cdata);
1609 (void)argv; /* stop gcc whine about unused parameter */
1610
1611 if ( argc != 2 ) {
1612 FPRINTF(ASCERR, "call is: slv_check_and_reanalyze <instance_name>\n");
1613 Tcl_SetResult(interp, "wong # arguments for slv_check_and_reanalyze",
1614 TCL_STATIC);
1615 return TCL_ERROR;
1616 }
1617 if (g_solvsys_cur!=NULL) {
1618 system_reanalyze(g_solvsys_cur);
1619 return TCL_OK;
1620 } else {
1621 FPRINTF(ASCERR, "CheckAndReanalyze called with NULL system.\n");
1622 Tcl_SetResult(interp, "empty solver context.", TCL_STATIC);
1623 return TCL_ERROR;
1624 }
1625 }
1626
1627 int Asc_SolvSlvResolve(ClientData cdata, Tcl_Interp *interp,
1628 int argc, CONST84 char *argv[])
1629 {
1630 UNUSED_PARAMETER(cdata);
1631 (void)argv; /* stop gcc whine about unused parameter */
1632
1633 if ( argc != 1 ) {
1634 FPRINTF(ASCERR, "call is: resolve <no args>\n");
1635 Tcl_SetResult(interp, "no arguments allowed for resolve", TCL_STATIC);
1636 return TCL_ERROR;
1637 }
1638
1639 #ifdef ASC_SIGNAL_TRAPS
1640 if (SETJMP(g_fpe_env)==0) {
1641 #endif /* ASC_SIGNAL_TRAPS */
1642 if (g_solvsys_cur!=NULL) {
1643 slv_resolve(g_solvsys_cur);
1644 return TCL_OK;
1645 } else {
1646 FPRINTF(ASCERR, "Resolve called with NULL system.\n");
1647 Tcl_SetResult(interp, "empty solver context.", TCL_STATIC);
1648 return TCL_ERROR;
1649 }
1650 #ifdef ASC_SIGNAL_TRAPS
1651 } else {
1652 FPRINTF(ASCERR, "Floating point exception in slv_resolve!!\n");
1653 Tcl_SetResult(interp, " Floating point exception in slv_resolve. Help!",
1654 TCL_STATIC);
1655 return TCL_ERROR;
1656 }
1657 #endif /* ASC_SIGNAL_TRAPS */
1658 }
1659
1660 /* invoking the name of the beast three times makes it come! */
1661 int Asc_SolvSlvSolve(ClientData cdata, Tcl_Interp *interp,
1662 int argc, CONST84 char *argv[])
1663 {
1664 UNUSED_PARAMETER(cdata);
1665 (void)argv; /* stop gcc whine about unused parameter */
1666
1667 if ( argc != 1 ) {
1668 FPRINTF(ASCERR, "call is: slv_solve <no args>\n");
1669 Tcl_SetResult(interp, "no arguments allowed for slv_solve", TCL_STATIC);
1670 return TCL_ERROR;
1671 }
1672 #ifdef ASC_SIGNAL_TRAPS
1673 if (SETJMP(g_fpe_env)==0) {
1674 #endif /* ASC_SIGNAL_TRAPS */
1675 if (g_solvsys_cur!=NULL) {
1676 slv_solve(g_solvsys_cur);
1677 return TCL_OK;
1678 } else {
1679 FPRINTF(ASCERR, "slv_solve called with NULL system.\n");
1680 Tcl_SetResult(interp, " empty solver context.", TCL_STATIC);
1681 return TCL_ERROR;
1682 }
1683 #ifdef ASC_SIGNAL_TRAPS
1684 } else {
1685 FPRINTF(ASCERR, "Floating point exception in slv_solve!!\n");
1686 Tcl_SetResult(interp, " Floating point exception in slv_solve. Help!",
1687 TCL_STATIC);
1688 return TCL_ERROR;
1689 }
1690 #endif /* ASC_SIGNAL_TRAPS */
1691 }
1692
1693 /* hide it out here from the exception clobber */
1694 static int safe_status;
1695 int Asc_SolvSlvIterate(ClientData cdata, Tcl_Interp *interp,
1696 int argc, CONST84 char *argv[])
1697 {
1698 slv_status_t s;
1699 int steps=1;
1700 double comptime=5.0,start,delta=0.0;
1701 safe_status=TCL_OK;
1702
1703 UNUSED_PARAMETER(cdata);
1704
1705 if ( argc > 3 ) {
1706 FPRINTF(ASCERR, "call is: slv_iterate <steps> [timelimit]\n");
1707 Tcl_SetResult(interp, "too many arguments to slv_iterate", TCL_STATIC);
1708 return TCL_ERROR;
1709 }
1710 if ( argc < 2 ) {
1711 FPRINTF(ASCERR, "call is: slv_iterate <steps> [timelimit]\n");
1712 Tcl_SetResult(interp, "need an iteration count for slv_iterate",
1713 TCL_STATIC);
1714 return TCL_ERROR;
1715 }
1716 safe_status=Tcl_GetInt(interp,argv[1],&steps);
1717 if (safe_status!=TCL_OK || steps <1) {
1718 FPRINTF(ASCERR, "slv_iterate called with bad step count.\n");
1719 Tcl_ResetResult(interp);
1720 Tcl_SetResult(interp, "slv_iterate called with bad step count.",
1721 TCL_STATIC);
1722 return safe_status;
1723 }
1724 if ( argc == 3 ) {
1725 safe_status=Tcl_GetDouble(interp,argv[2],&comptime);
1726 if (safe_status!=TCL_OK || comptime <0.1) {
1727 FPRINTF(ASCERR, "slv_iterate called with bad time limit.\n");
1728 Tcl_ResetResult(interp);
1729 Tcl_SetResult(interp, "slv_iterate called with bad time limit.",
1730 TCL_STATIC);
1731 return safe_status;
1732 }
1733 }
1734 Tcl_ResetResult(interp);
1735 if (g_solvsys_cur==NULL) {
1736 FPRINTF(ASCERR, "slv_iterate called with NULL system.\n");
1737 Tcl_SetResult(interp, " empty solver context.", TCL_STATIC);
1738 return TCL_ERROR;
1739 }
1740
1741 start=tm_cpu_time();
1742 for (safe_status=0;safe_status<steps && delta <comptime;safe_status++) {
1743 #ifdef ASC_SIGNAL_TRAPS
1744 if (SETJMP(g_fpe_env)==0) {
1745 #endif /* ASC_SIGNAL_TRAPS */
1746 slv_get_status(g_solvsys_cur,&s);
1747 if (s.ready_to_solve && !Solv_C_CheckHalt_Flag) {
1748 slv_iterate(g_solvsys_cur);
1749 }
1750 #ifdef ASC_SIGNAL_TRAPS
1751 } else {
1752 FPRINTF(ASCERR, "Floating point exception in slv_iterate!!\n");
1753 Tcl_SetResult(interp, " Floating point exception in slv_iterate. Help!",
1754 TCL_STATIC);
1755 return TCL_ERROR;
1756 }
1757 #endif /* ASC_SIGNAL_TRAPS */
1758 delta=tm_cpu_time()-start;
1759 }
1760 return TCL_OK;
1761 }
1762
1763 int Asc_SolvAvailSolver(ClientData cdata, Tcl_Interp *interp,
1764 int argc, CONST84 char *argv[])
1765 {
1766 int i;
1767
1768 UNUSED_PARAMETER(cdata);
1769 (void)argc; /* stop gcc whine about unused parameter */
1770 (void)argv; /* stop gcc whine about unused parameter */
1771
1772 const struct gl_list_t *L = solver_get_engines();
1773 SlvFunctionsT *S;
1774 for(i = 1; i <= gl_length(L); ++i){
1775 S = (SlvFunctionsT *)gl_fetch(L,i);
1776 Tcl_AppendElement(interp,S->name);
1777 }
1778 return TCL_OK;
1779 }
1780
1781 /* JP... */
1782 int Asc_SolvSolverNum(ClientData cdata, Tcl_Interp *interp
1783 , int argc, CONST84 char *argv[]
1784 ){
1785 char buf[8];
1786 const SlvFunctionsT *solver;
1787
1788 UNUSED_PARAMETER(cdata);
1789
1790 if ( argc != 2 ) {
1791 FPRINTF(ASCERR, "call is: slv_number <name>\n");
1792 Tcl_SetResult(interp, "one argument expected for slv_number",TCL_STATIC);
1793 return TCL_ERROR;
1794 }
1795
1796 solver = solver_engine_named(argv[1]);
1797 if(solver==NULL){
1798 FPRINTF(ASCERR, "Unknown solver '%s'!\n",argv[1]);
1799 Tcl_ResetResult(interp);
1800 Tcl_SetResult(interp, "Unknown solver.", TCL_STATIC);
1801 return TCL_ERROR;
1802 }else{
1803 sprintf(buf,"%d",solver->number);
1804 Tcl_AppendElement(interp,&buf[0]);
1805 return TCL_OK;
1806 }
1807 /* not reached */
1808 }
1809 /* ... JP */
1810
1811 int Asc_SolvSolverName(ClientData cdata, Tcl_Interp *interp
1812 , int argc, CONST84 char *argv[]
1813 ){
1814 const SlvFunctionsT *solver;
1815 UNUSED_PARAMETER(cdata);
1816 if(argc!=2){
1817 FPRINTF(ASCERR, "Call is: slv_name <number>\n");
1818 Tcl_SetResult(interp, "One argument expected for slv_name",TCL_STATIC);
1819 return TCL_ERROR;
1820 }
1821
1822 solver = solver_engine(atoi(argv[1]));
1823 if(solver==NULL){
1824 FPRINTF(ASCERR, "Unknown solver '%s' (=%d).\n",argv[1],atoi(argv[1]));
1825 Tcl_ResetResult(interp);
1826 Tcl_SetResult(interp, "Unknown solver.", TCL_STATIC);
1827 return TCL_ERROR;
1828 }else{
1829 Tcl_AppendElement(interp,solver->name);
1830 return TCL_OK;
1831 }
1832 }
1833
1834 int Asc_SolvLinsolNames(ClientData cdata, Tcl_Interp *interp,
1835 int argc, CONST84 char *argv[])
1836 {
1837 UNUSED_PARAMETER(cdata);
1838 UNUSED_PARAMETER(argc);
1839 UNUSED_PARAMETER(argv);
1840
1841 Tcl_AppendResult(interp,linsolqr_fmethods(),SNULL);
1842 return TCL_OK;
1843 }
1844
1845 int Asc_SolvEligSolver(ClientData cdata, Tcl_Interp *interp,
1846 int argc, CONST84 char *argv[])
1847 {
1848 /* KHACK: removed 'n' from call to slv_eligible_solver
1849 * may need to remove 'n' from this function totaly
1850 */
1851 slv_parameters_t sp;
1852 int cur;
1853 int status=0;
1854 int n;
1855 int tmpi;
1856 const SlvFunctionsT *S;
1857 struct gl_list_t *L;
1858
1859 UNUSED_PARAMETER(cdata);
1860
1861 if (( argc < 2 ) || ( argc > 3 )) {
1862 FPRINTF(ASCERR, "call is: slv_eligible_solver <solver number> [all]\n");
1863 Tcl_SetResult(interp, "slv_eligible_solver: solver number expected",
1864 TCL_STATIC);
1865 return TCL_ERROR;
1866 }
1867 if (g_solvsys_cur == NULL) {
1868 FPRINTF(ASCERR, "slv_eligible_solver called with NULL pointer\n");
1869 Tcl_SetResult(interp, "slv_eligible_solver called without slv_system",
1870 TCL_STATIC);
1871 return TCL_ERROR;
1872 }
1873
1874 slv_get_parameters(g_solvsys_cur,&sp);
1875 cur = slv_get_selected_solver(g_solvsys_cur);
1876 if (argc==3 && !!sp.output.less_important) {
1877 FPRINTF(ASCERR,"Solver Name ?Eligible\n");
1878 FPRINTF(ASCERR,"-----------------------------\n");
1879 for(n=1 ; n<gl_length(L); ++n) {
1880 S = (SlvFunctionsT *)gl_fetch(L,n);
1881 FPRINTF(ASCERR, "%c%3d %-11s %s\n", ((n==cur) ? '*' : ' '), n,
1882 S->name, YORN((S->celigible)(g_solvsys_cur)));
1883 }
1884 }
1885 status=Tcl_GetInt(interp, argv[1], &tmpi);
1886 Tcl_ResetResult(interp);
1887 if ((status==TCL_ERROR) || !solver_engine(tmpi<0)){
1888 Tcl_SetResult(interp,
1889 "slv_eligible_solver: called with invalid solver number",
1890 TCL_STATIC);
1891 return TCL_ERROR;
1892 } else {
1893 n = tmpi;
1894 if (slv_eligible_solver(g_solvsys_cur)) {
1895 Tcl_SetResult(interp, "1", TCL_STATIC);
1896 } else {
1897 Tcl_SetResult(interp, "0", TCL_STATIC);
1898 }
1899 }
1900 return TCL_OK;
1901 }
1902
1903 int Asc_SolvSelectSolver(ClientData cdata, Tcl_Interp *interp,
1904 int argc, CONST84 char *argv[])
1905 {
1906 int status=TCL_OK;
1907 int solver;
1908
1909 UNUSED_PARAMETER(cdata);
1910
1911 if ( argc != 2 ) {
1912 FPRINTF(ASCERR, "call is: slv_select_solver <N>\n");
1913 Tcl_SetResult(interp, "1 argument expected for slv_select_solver",
1914 TCL_STATIC);
1915 return TCL_ERROR;
1916 }
1917 if (g_solvsys_cur==NULL) {
1918 FPRINTF(ASCERR, "slv_select_solver called with NULL pointer\n");
1919 Tcl_SetResult(interp, "slv_select_solver called without slv_system",
1920 TCL_STATIC);
1921 return TCL_ERROR;
1922 }
1923 status=Tcl_GetInt(interp, argv[1], &solver);
1924 if(!solver_engine(solver) || (status==TCL_ERROR)) {
1925 FPRINTF(ASCERR, "Unknown solver (%d). Not selected!\n",solver);
1926 Tcl_ResetResult(interp);
1927 Tcl_SetResult(interp, "Solver not available.", TCL_STATIC);
1928 return TCL_ERROR;
1929 } else {
1930 char num[8];
1931 CONSOLE_DEBUG("...");
1932 int i = slv_get_selected_solver(g_solvsys_cur);
1933 if ( solver != i ) {
1934 CONSOLE_DEBUG("...");
1935 i = slv_select_solver(g_solvsys_cur,solver);
1936 }
1937 sprintf(num,"%d",i);
1938 Tcl_AppendElement(interp,&num[0]);
1939 return TCL_OK;
1940 }
1941 /* not reached */
1942 }
1943
1944 int Asc_SolvGetSelectedSolver(ClientData cdata, Tcl_Interp *interp,
1945 int argc, CONST84 char *argv[])
1946 {
1947 int solver;
1948 char * tmps=NULL;
1949
1950 UNUSED_PARAMETER(cdata);
1951 (void)argv; /* stop gcc whine about unused parameter */
1952
1953 tmps= (char *)ascmalloc((MAXIMUM_NUMERIC_LENGTH+1)*sizeof(char));
1954 if ( argc != 1 ) {
1955 FPRINTF(ASCERR, "call is: slv_get_solver <N>\n");
1956 Tcl_SetResult(interp, "No args allowed for slv_get_solver", TCL_STATIC);
1957 return TCL_ERROR;
1958 }
1959 if (g_solvsys_cur==NULL) {
1960 FPRINTF(ASCERR, "slv_get_solver called with NULL pointer\n");
1961 Tcl_SetResult(interp, "slv_get_solver called without slv_system",
1962 TCL_STATIC);
1963 return TCL_ERROR;
1964 }
1965 solver = slv_get_selected_solver(g_solvsys_cur);
1966 sprintf(tmps,"%d", solver);
1967 Tcl_AppendElement(interp,tmps);
1968 ascfree(tmps);
1969 return TCL_OK;
1970 }
1971
1972 int Asc_SolvFlushSolver(ClientData cdata, Tcl_Interp *interp,
1973 int argc, CONST84 char *argv[])
1974 {
1975 slv_system_t systmp;
1976
1977 UNUSED_PARAMETER(cdata);
1978 (void)interp; /* stop gcc whine about unused parameter */
1979 (void)argc; /* stop gcc whine about unused parameter */
1980 (void)argv; /* stop gcc whine about unused parameter */
1981
1982 if (g_solvsys_cur != NULL) {
1983 systmp=g_solvsys_cur;
1984 system_destroy(systmp);
1985 g_solvsys_cur = NULL;
1986 g_solvinst_cur = NULL;
1987 g_solvinst_root = NULL;
1988 }
1989 return TCL_OK;
1990 }
1991
1992 int Asc_SolvMakeIndependent(ClientData cdata, Tcl_Interp *interp,
1993 int argc, CONST84 char *argv[])
1994 {
1995 int j,k,tmpi,status=TCL_OK;
1996 int32 maxvar,freevar;
1997 struct var_variable **vp=NULL;
1998 var_filter_t vfilter;
1999 slv_system_t sys=NULL;
2000 int32 *swapvars=NULL;
2001 int32 *unassvars=NULL;
2002 mtx_range_t rng;
2003 mtx_matrix_t mtx=NULL;
2004 char res[40];
2005
2006 UNUSED_PARAMETER(cdata);
2007
2008 if ( argc < 2 ) {
2009 FPRINTF(ASCERR, "call is: slv_set_independent <ndx ...>\n");
2010 Tcl_SetResult(interp, "slv_set_independent wants at least 1 var index",
2011 TCL_STATIC);
2012 return TCL_ERROR;
2013 }
2014 sys=g_solvsys_cur;
2015 if (sys==NULL) {
2016 FPRINTF(ASCERR, "slv_set_independent called with NULL pointer\n");
2017 Tcl_SetResult(interp, "slv_set_independent without slv_system",TCL_STATIC);
2018 return TCL_ERROR;
2019 }
2020 mtx=slv_get_sys_mtx(sys);
2021 if (mtx==NULL) {
2022 FPRINTF(ASCERR,"slv_set_independent found no matrix. odd!\n");
2023 Tcl_SetResult(interp, "slv_set_independent found no matrix. odd!",
2024 TCL_STATIC);
2025 return TCL_ERROR;
2026 }
2027 vp=slv_get_solvers_var_list(sys);
2028 if (vp==NULL) {
2029 FPRINTF(ASCERR, "slv_set_independent called with NULL varlist\n");
2030 Tcl_SetResult(interp, "slv_set_independent called without varlist",
2031 TCL_STATIC);
2032 return TCL_ERROR;
2033 }
2034
2035 maxvar=slv_get_num_solvers_vars(sys);
2036
2037 vfilter.matchbits = (VAR_INCIDENT | VAR_ACTIVE);
2038 vfilter.matchvalue = (VAR_INCIDENT | VAR_ACTIVE);
2039 freevar=slv_count_solvers_vars(sys,&vfilter);
2040 rng.high=freevar-1;
2041 rng.low=mtx_symbolic_rank(mtx);
2042 if ( (argc-1) > (rng.high-rng.low+1) ) {
2043 FPRINTF(ASCERR, "slv_set_independent called with too many vars\n");
2044 Tcl_SetResult(interp, "slv_set_independent called with too many vars",
2045 TCL_STATIC);
2046 return TCL_ERROR;
2047 }
2048
2049 swapvars=(int32 *)ascmalloc(sizeof(int32)*(argc-1));
2050 k=rng.high-rng.low+1;
2051 unassvars=ASC_NEW_ARRAY(int32,k);
2052 for (j=0;j<k;j++) {
2053 unassvars[j]=mtx_col_to_org(mtx,j+rng.low); /* current outsiders */
2054 }
2055 for (j=1;j<argc;j++) {
2056 tmpi=maxvar;
2057 status=Tcl_GetInt(interp,argv[j],&tmpi);
2058 if (tmpi<0 || tmpi >= maxvar) {
2059 status=TCL_ERROR;
2060 }
2061 if (status!=TCL_OK) {
2062 FPRINTF(ASCERR,
2063 "slv_set_independent: %d is not number in variable list\n",tmpi);
2064 Tcl_ResetResult(interp);
2065 Tcl_SetResult(interp, "slv_set_independent: invalid variable number",
2066 TCL_STATIC);
2067 if (swapvars) {
2068 ascfree(swapvars);
2069 }
2070 if (unassvars) {
2071 ascfree(unassvars);
2072 }
2073 return status;
2074 } else {
2075 swapvars[j-1]=tmpi; /*var index numbers*/
2076 }
2077 }
2078 k=argc-1;
2079 for (j=0;j<k;j++) {
2080 if (slv_change_basis(sys,swapvars[j],&rng) ) {
2081 for (tmpi=rng.low;tmpi<=rng.high;tmpi++) {
2082 if (unassvars[tmpi-rng.low]!=mtx_col_to_org(mtx,tmpi)) {
2083 int32 tmpd;
2084 mtx_swap_cols(mtx,tmpi,rng.high);
2085 tmpd=unassvars[tmpi-rng.low];
2086 unassvars[tmpi-rng.low]=unassvars[rng.high-rng.low];
2087 unassvars[rng.high-rng.low]=tmpd;
2088 break;
2089 }
2090 }
2091 rng.high--;
2092 } else {
2093 char *name;
2094 name=var_make_name(sys,vp[swapvars[j]]);
2095 FPRINTF(ASCERR,"Unable to remove %s from the basis.\n",name);
2096 ascfree(name);
2097 sprintf(res,"%d",swapvars[j]);
2098 Tcl_AppendElement(interp,res);
2099 }
2100 }
2101 if (swapvars) {
2102 ascfree(swapvars);
2103 }
2104 if (unassvars) {
2105 ascfree(unassvars);
2106 }
2107 return TCL_OK;
2108 }
2109
2110
2111 int Asc_SolvImportQlfdid(ClientData cdata, Tcl_Interp *interp
2112 ,int argc, CONST84 char *argv[]
2113 ){
2114 int status, listc,prevs=0;
2115 char *temp=NULL;
2116 CONST84 char **listargv=NULL;
2117 slv_system_t systmp;
2118 enum inst_t ikind;
2119 struct Instance *solvinst_pot=NULL; /* potential solve instance */
2120 struct Instance *solvinst_root_pot=NULL; /* potential solve instance */
2121
2122 if (argc<2 || argc>3) {
2123 Tcl_SetResult(interp, "slv_import_qlfdid <qlfdid> [test]", TCL_STATIC);
2124 return TCL_ERROR;
2125 }
2126
2127 status=Asc_BrowQlfdidSearchCmd(cdata, interp, (int)2, argv);
2128 temp = ASC_STRDUP(Tcl_GetStringResult(interp));
2129 Tcl_ResetResult(interp);
2130
2131 if (status==TCL_OK) {
2132 /* catch inst ptr */
2133 solvinst_pot = g_search_inst;
2134 /* catch root name */
2135 status=Tcl_SplitList(interp, temp, &listc, &listargv);
2136 if (status!=TCL_OK) { /* this should never happen */
2137 Tcl_Free((char *)listargv);
2138 Tcl_ResetResult(interp);
2139 Tcl_SetResult(interp, "slv_import_qlfdid: error in split list for sim",
2140 TCL_STATIC);
2141 FPRINTF(ASCERR, "wierdness in slv_import_qlfdid splitlist.\n");
2142 solvinst_pot =NULL;
2143 if (temp) {
2144 ascfree(temp);
2145 }
2146 temp=NULL;
2147 return status;
2148 }
2149 /* catch root inst ptr */
2150 solvinst_root_pot = Asc_FindSimulationRoot(AddSymbol(listargv[0]));
2151 Tcl_Free((char *)listargv);
2152 if (!solvinst_root_pot) { /*an error we should never reach, knock wood */
2153 Tcl_ResetResult(interp);
2154 FPRINTF(ASCERR, "NULL simulation found by slv_import_qlfdid. %s\n",temp);
2155 Tcl_SetResult(interp,
2156 "slv_import_qlfdid: Simulation specified not found.",
2157 TCL_STATIC);
2158 if (temp) {
2159 ascfree(temp);
2160 }
2161 temp=NULL;
2162 return TCL_ERROR;
2163 }
2164 } else {
2165 /* failed. bail out. */
2166 Tcl_SetResult(interp, "slv_import_qlfdid: Asc_BrowQlfdidSearchCmd: ",
2167 TCL_STATIC);
2168 Tcl_AppendResult(interp, temp, SNULL);
2169 FPRINTF(ASCERR, "slv_import_qlfdid: Asc_BrowQlfdidSearchCmd error\n");
2170 if (temp) {
2171 ascfree(temp);
2172 }
2173 temp=NULL;
2174 return status;
2175 }
2176 /* got something worth having */
2177 if(temp){
2178 ascfree(temp);
2179 }
2180 temp=NULL;
2181 Tcl_ResetResult(interp);
2182
2183 /* check that instance is model */
2184 ikind=InstanceKind(solvinst_pot);
2185 if (ikind!=MODEL_INST) {
2186 switch (argc) {
2187 case 3: /* just testing */
2188 Tcl_SetResult(interp, "1", TCL_STATIC);
2189 return TCL_OK;
2190 default: /*report import error */
2191 FPRINTF(ASCERR, "Instance imported is not a solvable kind.\n");
2192 Tcl_SetResult(interp, "Instance kind not MODEL.", TCL_STATIC);
2193 return TCL_ERROR;
2194 }
2195 }
2196
2197 /* check instance is complete */
2198 if (NumberPendingInstances(solvinst_pot)!=0) {
2199 switch (argc) {
2200 case 3: /* just testing */
2201 Tcl_SetResult(interp, "1", TCL_STATIC);
2202 CheckInstance(ASCERR,solvinst_pot);
2203 return TCL_OK;
2204 default: /*report import error */
2205 FPRINTF(ASCERR, "Instance imported is incomplete: %ld pendings.\n",
2206 NumberPendingInstances(solvinst_pot));
2207 Tcl_SetResult(interp, "Instance has pendings: Not imported.",
2208 TCL_STATIC);
2209 return TCL_ERROR;
2210 }
2211 }
2212
2213 if(argc == 2){ /*not just testing */
2214 /* Here we will check to see if we really need to do
2215 all of this work by:
2216 1) Checking if the potential and current instance pointers are equal
2217 2) Checking a global counter to see if the compiler has been called
2218 */
2219 if (g_solvsys_cur == NULL) {
2220 g_compiler_counter = 1; /* initialize compiler counter */
2221 }
2222 if (g_solvinst_cur == solvinst_pot && g_compiler_counter == 0
2223 && g_solvinst_cur != NULL) {
2224 prevs = slv_get_selected_solver(g_solvsys_cur);
2225 CONSOLE_DEBUG("...");
2226 slv_select_solver(g_solvsys_cur,prevs);
2227 Tcl_SetResult(interp, "Solver instance created.", TCL_STATIC);
2228 #if SP_DEBUG
2229 FPRINTF(ASCERR,"YOU JUST AVOIDED A TOTAL REBUILD\n");
2230 #endif
2231 return TCL_OK;
2232 }
2233
2234 /* flush old system */
2235 g_solvinst_cur=solvinst_pot;
2236 g_solvinst_root=solvinst_root_pot;
2237 if (g_solvsys_cur != NULL) {
2238 prevs = slv_get_selected_solver(g_solvsys_cur);
2239 systmp=g_solvsys_cur;
2240 system_destroy(systmp);
2241 g_solvsys_cur = NULL;
2242 }
2243
2244 /* create system */
2245 if( g_solvsys_cur == NULL ) {
2246 g_solvsys_cur = system_build(g_solvinst_cur);
2247 if( g_solvsys_cur == NULL ) {
2248 FPRINTF(ASCERR,"system_build returned NULL.\n");
2249 Tcl_SetResult(interp, "Bad relations found: solve system not created.",
2250 TCL_STATIC);
2251 return TCL_ERROR;
2252 }
2253 }
2254
2255 if( g_solvsys_cur == NULL ) {
2256 FPRINTF(ASCERR,"system_build returned NULL!\n");
2257 Tcl_SetResult(interp, "importqlfdid: solve system not created.",
2258 TCL_STATIC);
2259 return TCL_ERROR;
2260 }
2261 CONSOLE_DEBUG("...");
2262 slv_select_solver(g_solvsys_cur,prevs);
2263 Tcl_SetResult(interp, "Solver instance created.", TCL_STATIC);
2264 g_compiler_counter = 0; /* set counter to 0 after full import */
2265 } else {
2266 Tcl_SetResult(interp, "0", TCL_STATIC);
2267 }
2268 return TCL_OK;
2269 }
2270
2271
2272 int Asc_SolvGetLnmEpsilon(ClientData cdata, Tcl_Interp *interp
2273 ,int argc, CONST84 char *argv[]
2274 ){
2275 char buf[MAXIMUM_NUMERIC_LENGTH]; /* string to hold integer */
2276 UNUSED_PARAMETER(cdata);
2277 (void)argv; /* stop gcc whine about unused parameter */
2278
2279 if ( argc > 1 ) {
2280 Tcl_SetResult(interp, "slv_lnmget takes no argument.", TCL_STATIC);
2281 return TCL_ERROR;
2282 }
2283 sprintf(buf, "%g",FuncGetLnmEpsilon());
2284 Tcl_SetResult(interp, buf, TCL_VOLATILE);
2285 return TCL_OK;
2286 }
2287
2288 int Asc_SolvSetLnmEpsilon(ClientData cdata, Tcl_Interp *interp,
2289 int argc, CONST84 char *argv[])
2290 {
2291 double eps;
2292
2293 UNUSED_PARAMETER(cdata);
2294
2295 if ( argc != 2 ) {
2296 Tcl_SetResult(interp, "slv_lnmset takes 1 positive # argument.", TCL_STATIC);
2297 return TCL_ERROR;
2298 }
2299 eps=FuncGetLnmEpsilon();
2300 if( Tcl_GetDouble(interp,argv[1],&eps)==TCL_ERROR) {
2301 Tcl_ResetResult(interp);
2302 Tcl_SetResult(interp, "slv_lnmset: arg 1 not real number", TCL_STATIC);
2303 return TCL_ERROR;
2304 }
2305 if (eps < 0.5) {
2306 FuncSetLnmEpsilon(eps);
2307 } else {
2308 FPRINTF(ASCERR,"Modified log epsilon > 0.5 not allowed. Eps = %g.\n",eps);
2309 }
2310 return TCL_OK;
2311 }
2312
2313 /*
2314 * Solv_C_CheckHalt_Flag is defined in slv.[ch].
2315 */
2316 int Asc_SolvSetCHaltFlag(ClientData cdata, Tcl_Interp *interp,
2317 int argc, CONST84 char *argv[])
2318 {
2319 int value;
2320
2321 UNUSED_PARAMETER(cdata);
2322
2323 if ( argc != 2 ) {
2324 Tcl_SetResult(interp, "wrong # args : Usage slv_set_haltflag", TCL_STATIC);
2325 return TCL_ERROR;
2326 }
2327 value = atoi(argv[1]);
2328 if (value) {
2329 Solv_C_CheckHalt_Flag = 1; /* any nonzero value will set the flag on. */
2330 } else {
2331 Solv_C_CheckHalt_Flag = 0; /* otherwise turn it off */
2332 }
2333 return TCL_OK;
2334 }
2335
2336 #define LONGHELP(b,ms) ((b)?ms:"")
2337 int Asc_SolvHelpList(ClientData cdata, Tcl_Interp *interp,
2338 int argc, CONST84 char *argv[])
2339 {
2340 boolean detail=1;
2341
2342 UNUSED_PARAMETER(cdata);
2343
2344 if ( argc > 2 ) {
2345 FPRINTF(ASCERR,"call is: slvhelp [s,l] \n");
2346 Tcl_SetResult(interp, "Too many args to slvhelp. Want 0 or 1 args",
2347 TCL_STATIC);
2348 return TCL_ERROR;
2349 }
2350 if ( argc == 2 ) {
2351 if (argv[1][0]=='s') {
2352 detail=0;
2353 }
2354 if (argv[1][0]=='l') {
2355 detail=1;
2356 }
2357 PRINTF("%-25s%s\n","slv_trapint",
2358 LONGHELP(detail,"turn ctrl-c traps on for solver"));
2359 PRINTF("%-25s%s\n","slv_untrapint",
2360 LONGHELP(detail,"turn ctrl-c traps off."));
2361 PRINTF("%-25s%s\n","slv_trapfp",
2362 LONGHELP(detail,"turn floating point traps on for solver"));
2363 PRINTF("%-25s%s\n","slv_untrapfp",
2364 LONGHELP(detail,"turn floating point traps off. take core dump."));
2365 PRINTF("%-25s%s\n","slv_checksim",
2366 LONGHELP(detail,"see if simulation has pendings:0ok,1incomplete"));
2367 PRINTF("%-25s%s\n","slv_checksys",
2368 LONGHELP(detail,"see if solver is occupied:0free,1busy"));
2369 PRINTF("%-25s%s\n","slv_get_parms",
2370 LONGHELP(detail,"get list of solver parameters."));
2371 PRINTF("%-25s%s\n","set_slv_parms",
2372 LONGHELP(detail,"set list of solver parameters."));
2373 PRINTF("%-25s%s\n","slv_get_insttype",
2374 LONGHELP(detail,"get typename of model instance being solved."));
2375
2376 PRINTF("%-25s%s\n","slv_get_cost_page",
2377 LONGHELP(detail,"get list of block costs."));
2378 PRINTF("%-25s%s\n","slv_get_stat_page",
2379 LONGHELP(detail,"get list of status values."));
2380 PRINTF("%-25s%s\n","slv_get_objval",
2381 LONGHELP(detail,"get value of objective function"));
2382 PRINTF("%-25s%s\n","slv_get_instname",
2383 LONGHELP(detail,"get instance path name from instroot to instcur"));
2384 PRINTF("%-25s%s\n","slv_get_pathname",
2385 LONGHELP(detail,"get solver inst qlfdid"));
2386 PRINTF("%-25s%s\n","slvdump",
2387 LONGHELP(detail,"dump something about the solver insides."));
2388
2389 PRINTF("%-25s%s\n","slv_reanalyze",
2390 LONGHELP(detail,"reanalyze the solver lists of g_solvsys_cur ."));
2391 PRINTF("%-25s%s\n","slv_check_and_reanalyze",
2392 LONGHELP(detail,"reanalyze g_solvsys_cur if a whenvar changes."));
2393 PRINTF("%-25s%s\n","slv_get_vr",
2394 LONGHELP(detail,"return some counts of rels/vars."));
2395 PRINTF("%-25s%s\n","slv_presolve",
2396 LONGHELP(detail,"call presolve on the g_solvsys_cur."));
2397 PRINTF("%-25s%s\n","slv_resolve",
2398 LONGHELP(detail,"call resolve on g_solvsys_cur."));
2399 PRINTF("%-25s%s\n","slv_solve",
2400 LONGHELP(detail,"call solve on g_solvsys_cur."));
2401 PRINTF("%-25s%s\n","slv_iterate",
2402 LONGHELP(detail,"call solve_iterate on g_solvsys_cur."));
2403
2404 PRINTF("%-25s%s\n","slv_available",
2405 LONGHELP(detail,"list names of all known solvers"));
2406
2407 PRINTF("%-25s%s\n","slv_number",
2408 LONGHELP(detail,"lookup the solver number for a named solver"));
2409
2410 PRINTF("%-25s%s\n","slv_linsol_names",
2411 LONGHELP(detail,"list names of all linear options for Slv class"));
2412 PRINTF("%-25s%s\n","slv_eligible_solver",
2413 LONGHELP(detail,"boolean check of current solver eligibility"));
2414 PRINTF("%-25s%s\n","slv_select_solver",
2415 LONGHELP(detail,"set solver to use."));
2416 PRINTF("%-25s%s\n","slv_get_solver",
2417 LONGHELP(detail,"return solver number in use."));
2418 PRINTF("%-25s%s\n","slv_flush_solver",
2419 LONGHELP(detail,"blow away g_solvsys_cur"));
2420 PRINTF("%-25s%s\n","slv_set_independent",
2421 LONGHELP(detail,"select set of independent (superbasic) vars"));
2422
2423 PRINTF("%-25s%s\n","slv_import_qlfdid",
2424 LONGHELP(detail,"focus solver on qualified name, or test it."));
2425 PRINTF("%-25s%s\n","get_model_children",
2426 LONGHELP(detail,"return the list of MODEL children of a qlfdid"));
2427
2428 PRINTF("%-25s%s\n","slv_lnmget",
2429 LONGHELP(detail,"return lnm epsilon value"));
2430 PRINTF("%-25s%s\n","slv_lnmset",
2431 LONGHELP(detail,"set lnm epsilon value"));
2432 PRINTF("%-25s%s\n","integration commands",
2433 LONGHELP(detail,""));
2434 PRINTF("%-25s%s\n","integrate_able",
2435 LONGHELP(detail,"check solver problem for integrability"));
2436 PRINTF("%-25s%s\n","integrate_setup",
2437 LONGHELP(detail,"setup and integrate an ivp in solver"));
2438 PRINTF("%-25s%s\n","integrate_cleanup",
2439 LONGHELP(detail,"tidy up after an ivp in solver"));
2440 PRINTF("%-25s%s\n","slvhelp",
2441 LONGHELP(detail,"slvhelp s(=names only) l(=this list)."));
2442
2443 PRINTF("\n");
2444 }
2445 if ( argc == 1 ) {
2446 char * tmps=NULL;
2447 tmps= (char *)ascmalloc((MAXIMUM_NUMERIC_LENGTH+1)*sizeof(char));
2448 sprintf(tmps,"slv_checksys");
2449 Tcl_AppendElement(interp,tmps);
2450 sprintf(tmps,"slv_trapfp");
2451 Tcl_AppendElement(interp,tmps);
2452 sprintf(tmps,"slv_untrapfp");
2453 Tcl_AppendElement(interp,tmps);
2454 sprintf(tmps,"slv_checksim");
2455 Tcl_AppendElement(interp,tmps);
2456 sprintf(tmps,"slv_get_parm");
2457 Tcl_AppendElement(interp,tmps);
2458 sprintf(tmps,"set_slv_parm");
2459 Tcl_AppendElement(interp,tmps);
2460 sprintf(tmps,"slv_get_insttype");
2461 Tcl_AppendElement(interp,tmps);
2462
2463 sprintf(tmps,"slv_get_cost_page");
2464 Tcl_AppendElement(interp,tmps);
2465 sprintf(tmps,"slv_get_stat_page");
2466 Tcl_AppendElement(interp,tmps);
2467 sprintf(tmps,"slv_get_objval");
2468 Tcl_AppendElement(interp,tmps);
2469 sprintf(tmps,"slv_get_instname");
2470 Tcl_AppendElement(interp,tmps);
2471 sprintf(tmps,"slv_get_pathname");
2472 Tcl_AppendElement(interp,tmps);
2473 sprintf(tmps,"slvdump");
2474 Tcl_AppendElement(interp,tmps);
2475
2476 sprintf(tmps,"slv_reanalyze");
2477 Tcl_AppendElement(interp,tmps);
2478 sprintf(tmps,"slv_check_and_reanalyze");
2479 Tcl_AppendElement(interp,tmps);
2480 sprintf(tmps,"slv_get_vr");
2481 Tcl_AppendElement(interp,tmps);
2482 sprintf(tmps,"slv_presolve");
2483 Tcl_AppendElement(interp,tmps);
2484 sprintf(tmps,"slv_resolve");
2485 Tcl_AppendElement(interp,tmps);
2486 sprintf(tmps,"slv_solve");
2487 Tcl_AppendElement(interp,tmps);
2488 sprintf(tmps,"slv_iterate");
2489 Tcl_AppendElement(interp,tmps);
2490
2491 sprintf(tmps,"slv_available");
2492 Tcl_AppendElement(interp,tmps);
2493
2494 sprintf(tmps,"slv_number");
2495 Tcl_AppendElement(interp,tmps);
2496
2497 sprintf(tmps,"slv_linsol_names");
2498 Tcl_AppendElement(interp,tmps);
2499 sprintf(tmps,"slv_eligible_solver");
2500 Tcl_AppendElement(interp,tmps);
2501 sprintf(tmps,"slv_select_solver");
2502 Tcl_AppendElement(interp,tmps);
2503 sprintf(tmps,"slv_get_solver");
2504 Tcl_AppendElement(interp,tmps);
2505 sprintf(tmps,"slv_flush_solver");
2506 Tcl_AppendElement(interp,tmps);
2507 sprintf(tmps,"slv_set_independent");
2508 Tcl_AppendElement(interp,tmps);
2509
2510 sprintf(tmps,"slv_import_qlfdid");
2511 Tcl_AppendElement(interp,tmps);
2512 sprintf(tmps,"slv_import_sim");
2513 Tcl_AppendElement(interp,tmps);
2514 sprintf(tmps,"slv_lnmget");
2515 Tcl_AppendElement(interp,tmps);
2516 sprintf(tmps,"slv_lnmset");
2517 Tcl_AppendElement(interp,tmps);
2518 sprintf(tmps,"integrate_able");
2519 Tcl_AppendElement(interp,tmps);
2520 sprintf(tmps,"integrate_setup");
2521 Tcl_AppendElement(interp,tmps);
2522 sprintf(tmps,"integrate_cleanup");
2523 Tcl_AppendElement(interp,tmps);
2524 sprintf(tmps,"slvhelp");
2525 Tcl_AppendElement(interp,tmps);
2526 ascfree(tmps);
2527 }
2528 return TCL_OK;
2529 }
2530
2531
2532 /*NOTE: Output is not terribly meaninful when put to stdout or ASCERR */
2533 int Asc_SolvNearBounds(ClientData cdata, Tcl_Interp *interp,
2534 int argc, CONST84 char *argv[])
2535 {
2536 int32 *rip=NULL;
2537 real64 epsilon;
2538 char tmps[MAXIMUM_NUMERIC_LENGTH];
2539 int i,dev,status,count;
2540 FILE *fp;
2541
2542 UNUSED_PARAMETER(cdata);
2543
2544 if ( argc != 3 ) {
2545 FPRINTF(ASCERR, "call is: slv_near_bounds epsilon <out>\n");
2546 Tcl_SetResult(interp, "slv_near_bounds wants epsilon and output device.",
2547 TCL_STATIC);
2548 return TCL_ERROR;
2549 }
2550 if (g_solvsys_cur==NULL) {
2551 FPRINTF(ASCERR, "slv_near_bounds called with NULL pointer\n");
2552 Tcl_SetResult(interp, "slv_near_bounds called without slv_system",
2553 TCL_STATIC);
2554 return TCL_ERROR;
2555 }
2556 /* get io option */
2557 i=3;
2558 status=Tcl_GetDouble(interp,argv[1],&epsilon);
2559 status=Tcl_GetInt(interp,argv[2],&i);
2560 if (i<0 || i >2) {
2561 status=TCL_ERROR;
2562 }
2563 if (status!=TCL_OK) {
2564 FPRINTF(ASCERR,"slv_near_bounds: first arg is 0,1, or 2\n");
2565 Tcl_ResetResult(interp);
2566 Tcl_SetResult(interp, "slv_near_bounds: invalid output dev #", TCL_STATIC);
2567 return status;
2568 } else {
2569 dev=i;
2570 }
2571 switch (dev) {
2572 case 0: fp=stdout;
2573 break;
2574 case 1: fp=ASCERR;
2575 break;
2576 case 2: fp=NULL;
2577 break;
2578 default : /* should never be here */
2579 FPRINTF(ASCERR,"slv_near_bounds called with strange i/o option\n");
2580 return TCL_ERROR;
2581 }
2582 if ((count = slv_near_bounds(g_solvsys_cur,epsilon,&rip)) > 0) {
2583 count += 2;
2584 switch (dev) {
2585 case 0:
2586 case 1:
2587 FPRINTF(fp,"Objective indices:\n");
2588 for (i=0; i < count;i++) {
2589 FPRINTF(fp,"%d\n",rip[i]);
2590 }
2591 break;
2592 case 2:
2593 Tcl_AppendResult(interp,"{",SNULL);
2594 for (i=0; i < count;i++) {
2595 sprintf(tmps,"%d ",rip[i]);
2596 Tcl_AppendResult(interp,tmps,SNULL);
2597 }
2598 Tcl_AppendResult(interp,"}",SNULL);
2599 break;
2600 default:
2601 FPRINTF(ASCERR,"wierdness in i/o!");
2602 break;
2603 }
2604 } else {
2605 Tcl_SetResult(interp, "{}", TCL_STATIC);
2606 }
2607 if (rip) {
2608 ascfree(rip);
2609 }
2610
2611 return TCL_OK;
2612 }
2613
2614 /*NOTE: Output is not terribly meaninful when put to stdout or ASCERR */
2615 int Asc_SolvFarFromNominal(ClientData cdata, Tcl_Interp *interp,
2616 int argc, CONST84 char *argv[])
2617 {
2618 int32 *rip=NULL;
2619 real64 bignum;
2620 char tmps[MAXIMUM_NUMERIC_LENGTH];
2621 int i,dev,status,count;
2622 FILE *fp;
2623
2624 UNUSED_PARAMETER(cdata);
2625
2626 if ( argc != 3 ) {
2627 FPRINTF(ASCERR, "call is: slv_far_from_nom <bignum> <out>\n");
2628 Tcl_SetResult(interp,
2629 "slv_far_from_nominals wants bignum and output device.",
2630 TCL_STATIC);
2631 return TCL_ERROR;
2632 }
2633 if (g_solvsys_cur==NULL) {
2634 FPRINTF(ASCERR, "slv_far_from_nominals called with NULL pointer\n");
2635 Tcl_SetResult(interp, "slv_far_from_nominals called without slv_system",
2636 TCL_STATIC);
2637 return TCL_ERROR;
2638 }
2639 /* get io option */
2640 i=3;
2641 status=Tcl_GetDouble(interp,argv[1],&bignum);
2642 status=Tcl_GetInt(interp,argv[2],&i);
2643 if (i<0 || i >2) {
2644 status=TCL_ERROR;
2645 }
2646 if (status!=TCL_OK) {
2647 FPRINTF(ASCERR,"slv_far_from_nominals: first arg is 0,1, or 2\n");
2648 Tcl_ResetResult(interp);
2649 Tcl_SetResult(interp, "slv_far_from_nominals: invalid output dev #",
2650 TCL_STATIC);
2651 return status;
2652 } else {
2653 dev=i;
2654 }
2655 switch (dev) {
2656 case 0: fp=stdout;
2657 break;
2658 case 1: fp=ASCERR;
2659 break;
2660 case 2: fp=NULL;
2661 break;
2662 default : /* should never be here */
2663 FPRINTF(ASCERR,"slv_far_from_nominals called with strange i/o option\n");
2664 return TCL_ERROR;
2665 }
2666 if ((count = slv_far_from_nominals(g_solvsys_cur,bignum,&rip)) > 0) {
2667 switch (dev) {
2668 case 0:
2669 case 1:
2670 FPRINTF(fp,"Objective indices:\n");
2671 for (i=0; i < count;i++) {
2672 FPRINTF(fp,"%d\n",rip[i]);
2673 }
2674 break;
2675 case 2:
2676 Tcl_AppendResult(interp,"{",SNULL);
2677 for (i=0; i < count;i++) {
2678 sprintf(tmps,"%d ",rip[i]);
2679 Tcl_AppendResult(interp,tmps,SNULL);
2680 }
2681 Tcl_AppendResult(interp,"}",SNULL);
2682 break;
2683 default:
2684 FPRINTF(ASCERR,"wierdness in i/o!");
2685 break;
2686 }
2687 } else {
2688 Tcl_SetResult(interp, "{}", TCL_STATIC);
2689 }
2690 if (rip) {
2691 ascfree(rip);
2692 }
2693
2694 return TCL_OK;
2695 }

john.pye@anu.edu.au
ViewVC Help
Powered by ViewVC 1.1.22