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

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