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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 113 - (show annotations) (download) (as text)
Thu Dec 15 03:59:55 2005 UTC (16 years, 5 months ago) by ben.allan
File MIME type: text/x-csrc
File size: 89993 byte(s)
added slv_[un]trapint tcl callbacks which can be used to turn off
ctrl-c trapping of the commandline. in theory this will help gdb.
Note: traps are handled on a stack, so to guarantee the sigint
stack is empty, use slv_untrapint untill you get an error message:
        ascSignal.c:437: Asc_Signal (2) stack pop mismatch.


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

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