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

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

Parent Directory Parent Directory | Revision Log Revision Log


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


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