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

Annotation of /trunk/tcltk/generic/interface/DebugProc.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 708 - (hide annotations) (download) (as text)
Tue Jun 27 07:34:31 2006 UTC (18 years ago) by johnpye
File MIME type: text/x-csrc
File size: 116599 byte(s)
Replaced some references to ascmalloc with ASC_NEW_ARRAY
1 johnpye 571 /*
2     * DebugProc.c
3     * by Kirk Abbott and Ben Allan
4     * Created: 1/94
5     * Version: $Revision: 1.64 $
6     * Version control file: $RCSfile: DebugProc.c,v $
7     * Date last modified: $Date: 2003/08/23 18:43:05 $
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     #ifndef NO_SIGNAL_TRAPS
31     #include <signal.h>
32     #include <setjmp.h>
33     #endif /* NO_SIGNAL_TRAPS */
34     #include <tcl.h>
35     #include <utilities/ascConfig.h>
36     #include <utilities/ascSignal.h>
37     #include <utilities/ascMalloc.h>
38     #include <general/list.h>
39     #include <compiler/compiler.h>
40     #include <compiler/instance_enum.h>
41     #include <compiler/fractions.h>
42     #include <compiler/dimen.h>
43     #include <compiler/instance_name.h>
44     #include <compiler/atomvalue.h>
45     #include <compiler/instquery.h>
46 johnpye 670 #include <compiler/expr_types.h>
47 johnpye 571 #include <compiler/mathinst.h>
48     #include <compiler/relation_type.h>
49     #include <compiler/extfunc.h>
50     #include <compiler/find.h>
51     #include <compiler/functype.h>
52     #include <compiler/safe.h>
53     #include <compiler/relation.h>
54     #include <compiler/relation_util.h>
55     #include <compiler/pending.h>
56     #include <compiler/symtab.h>
57     #include <solver/slv_types.h>
58     #include <solver/mtx.h>
59     #include <solver/calc.h>
60     #include <solver/var.h>
61     #include <solver/rel.h>
62     #include <solver/discrete.h>
63     #include <solver/conditional.h>
64     #include <solver/logrel.h>
65     #include <solver/bnd.h>
66     #include <solver/relman.h>
67     #include <solver/slv_common.h>
68     #include <solver/linsol.h>
69     #include <solver/linsolqr.h>
70     #include <solver/slv_client.h>
71     #include <solver/slv_interface.h>
72     #include <solver/slv_stdcalls.h>
73     #include <solver/system.h>
74     #include <solver/slvDOF.h>
75     #include "old_utils.h"
76     #include "HelpProc.h"
77     #include "Qlfdid.h"
78     #include "BrowserQuery.h"
79     #include "DebugProc.h"
80     #include "BrowserMethod.h"
81     #include "DisplayProc.h"
82     #include "HelpProc.h"
83     #include "DebugProc.h"
84     #include "SolverGlobals.h"
85     #include "BrowserProc.h"
86     /* #include "slv5.h" *//* this is a sloppy mess due to slv5_calc_J */
87    
88     #ifndef lint
89     static CONST char DebugProcID[] = "$Id: DebugProc.c,v 1.64 2003/08/23 18:43:05 ballan Exp $";
90     #endif
91    
92    
93     #define SAFE_FIX_ME 0
94     #define REIMPLEMENT 0
95     #define TORF(b) ((b) ? "TRUE" : "FALSE")
96     #define YORN(b) ((b) ? "YES" : "NO")
97     #define ONEORZERO(b) ((b) ? "1" : "0")
98     #define SNULL (char *)NULL
99     #define QLFDID_LENGTH 1023
100     #define DP_DEBUG TRUE
101    
102     /*
103     * This function needs to be fixed to deal with mtxless systems
104     * much better.
105     */
106     int Asc_DebuGetBlkOfVar(ClientData cdata, Tcl_Interp *interp,
107     int argc, CONST84 char *argv[])
108     {
109     char * tmps;
110     int32 col,numblock,ndx,maxvar,blow,bhigh;
111     int status =TCL_OK;
112     mtx_matrix_t mtx;
113     mtx_region_t reg;
114     struct var_variable **vp;
115     var_filter_t vfilter;
116     dof_t *d;
117     const mtx_block_t *b;
118    
119 johnpye 670 UNUSED_PARAMETER(cdata);
120 johnpye 571
121     if ( argc != 2 ) {
122     FPRINTF(ASCERR, "call is: dbg_get_blk_of_var <var index>\n");
123     Tcl_SetResult(interp, "dbg_get_blk_of_var takes 1 arg", TCL_STATIC);
124     return TCL_ERROR;
125     }
126     if (g_solvsys_cur==NULL) {
127     FPRINTF(ASCERR, "dbg_get_blk_of_var called with NULL pointer\n");
128     Tcl_SetResult(interp, "dbg_get_blk_of_var called without slv_system",
129     TCL_STATIC);
130     return TCL_ERROR;
131     }
132    
133     mtx = slv_get_sys_mtx(g_solvsys_cur);
134     if (mtx==NULL) {
135     /* this is a horrible hack and incorrect and all that */
136     /* probably should issue a warning here */
137     Tcl_SetResult(interp, "0", TCL_STATIC);
138     return TCL_OK;
139     }
140     d = slv_get_dofdata(g_solvsys_cur);
141     b = slv_get_solvers_blocks(g_solvsys_cur);
142     assert(d!=NULL && b!=NULL);
143    
144     vp=slv_get_solvers_var_list(g_solvsys_cur);
145     /* maxvar=slv_get_num_solvers_vars(g_solvsys_cur); */
146     vfilter.matchbits = (VAR_ACTIVE);
147     vfilter.matchvalue = (VAR_ACTIVE);
148     maxvar=slv_count_solvers_vars(g_solvsys_cur,&vfilter);
149     ndx=maxvar;
150    
151     status=Tcl_GetInt(interp,argv[1],&ndx);
152     if (ndx>=maxvar||status==TCL_ERROR) {
153     Tcl_ResetResult(interp);
154     Tcl_SetResult(interp, "get_blk_of_var: variable does not exist",
155     TCL_STATIC);
156     FPRINTF(ASCERR, "dbg_get_blk_of_var: variable index invalid\n");
157     return TCL_ERROR;
158     }
159     col = mtx_org_to_col(mtx,ndx);
160     blow = 0;
161     bhigh = b->nblocks-1;
162     numblock = -1;
163     while( blow <= bhigh ) {
164     int32 block_number = (blow+bhigh)/2;
165     if( col > b->block[block_number].col.high ) {
166     blow = block_number+1;
167     } else if( col < b->block[block_number].col.low ) {
168     bhigh = block_number-1;
169     } else {
170     reg = b->block[block_number];
171     numblock = block_number;
172     break;
173     }
174     }
175     if ( var_fixed(vp[ndx]) || numblock<0 || !var_active(vp[ndx]) ) {
176     Tcl_SetResult(interp, "none", TCL_STATIC);
177     return TCL_OK;
178     } else {
179     tmps= (char *)ascmalloc((MAXIMUM_NUMERIC_LENGTH+1)*sizeof(char));
180     sprintf(tmps,"%d",numblock);
181     Tcl_AppendElement(interp,tmps);
182     ascfree(tmps);
183     }
184     return TCL_OK;
185     }
186    
187     /*
188     * This function needs to be fixed to deal with mtxless systems
189     * much better.
190     */
191     int Asc_DebuGetBlkOfEqn(ClientData cdata, Tcl_Interp *interp,
192     int argc, CONST84 char *argv[])
193     {
194     char * tmps;
195     int32 row,numblock,ndx,maxrel,blow,bhigh;
196     int status = TCL_OK;
197     mtx_matrix_t mtx;
198     mtx_region_t reg;
199     struct rel_relation **rp;
200     rel_filter_t rfilter;
201     dof_t *d;
202     const mtx_block_t *b;
203    
204 johnpye 670 UNUSED_PARAMETER(cdata);
205 johnpye 571
206     if ( argc != 2 ) {
207     FPRINTF(ASCERR, "call is: dbg_get_blk_of_eqn <rel index>\n");
208     Tcl_SetResult(interp, "dbg_get_blk_of_eqn takes 1 arg", TCL_STATIC);
209     return TCL_ERROR;
210     }
211     if (g_solvsys_cur==NULL) {
212     FPRINTF(ASCERR, "dbg_get_blk_of_eqn called with NULL pointer\n");
213     Tcl_SetResult(interp, "dbg_get_blk_of_eqn called without slv_system",
214     TCL_STATIC);
215     return TCL_ERROR;
216     }
217    
218     mtx = slv_get_sys_mtx(g_solvsys_cur);
219     if (mtx==NULL) {
220     /* this is a horrible hack and incorrect and all that */
221     /*probably should issue a warning here */
222     Tcl_SetResult(interp, "0", TCL_STATIC);
223     return TCL_OK;
224     }
225     d = slv_get_dofdata(g_solvsys_cur);
226     b = slv_get_solvers_blocks(g_solvsys_cur);
227     assert(d!=NULL && b!=NULL);
228    
229     rp=slv_get_solvers_rel_list(g_solvsys_cur);
230     /* maxrel=slv_get_num_solvers_rels(g_solvsys_cur); */
231     rfilter.matchbits = (REL_ACTIVE);
232     rfilter.matchvalue = (REL_ACTIVE);
233     maxrel=slv_count_solvers_rels(g_solvsys_cur,&rfilter);
234     ndx=maxrel;
235    
236     status=Tcl_GetInt(interp,argv[1],&ndx);
237     if (ndx>=maxrel||status==TCL_ERROR) {
238     Tcl_ResetResult(interp);
239     Tcl_SetResult(interp,
240     "dbg_get_blk_of_eqn: equation requested does not exist",
241     TCL_STATIC);
242     FPRINTF(ASCERR, "dbg_get_blk_of_eqn: relation index invalid.\n");
243     return TCL_ERROR;
244     }
245     row = mtx_org_to_row(mtx,ndx);
246     blow = 0;
247     bhigh = b->nblocks-1;
248     numblock = -1;
249     while( blow <= bhigh ) {
250     int32 block_number = (blow+bhigh)/2;
251     if( row > b->block[block_number].row.high ) {
252     blow = block_number+1;
253     } else if( row < b->block[block_number].row.low ) {
254     bhigh = block_number-1;
255     } else {
256     reg = b->block[block_number];
257     numblock = block_number;
258     break;
259     }
260     }
261     if (numblock<0 || !rel_included(rp[ndx]) || !rel_active(rp[ndx])) {
262     Tcl_SetResult(interp, "none", TCL_STATIC);
263     return TCL_OK;
264     } else {
265     tmps= (char *)ascmalloc((MAXIMUM_NUMERIC_LENGTH+1)*sizeof(char));
266     sprintf(tmps,"%d",numblock);
267     Tcl_AppendElement(interp,tmps);
268     ascfree(tmps);
269     }
270     return TCL_OK;
271     }
272    
273     /*
274     * this function deals ok with mtxless solvers
275     */
276     int Asc_DebuGetBlkCoords(ClientData cdata, Tcl_Interp *interp,
277     int argc, CONST84 char *argv[])
278     {
279     char * tmps;
280     int32 numblock,ndx,maxblk;
281     int status =TCL_OK;
282     mtx_region_t reg;
283     dof_t *d;
284     const mtx_block_t *b;
285    
286 johnpye 670 UNUSED_PARAMETER(cdata);
287 johnpye 571
288     if ( argc != 2 ) {
289     FPRINTF(ASCERR, "call is: dbg_get_blk_coords <blocknumber>\n");
290     Tcl_SetResult(interp, "dbg_get_blk_coords takes 1 arg", TCL_STATIC);
291     return TCL_ERROR;
292     }
293     if (g_solvsys_cur==NULL) {
294     FPRINTF(ASCERR, "dbg_get_blk_coords called with NULL pointer\n");
295     Tcl_SetResult(interp, "dbg_get_blk_coords called without slv_system",
296     TCL_STATIC);
297     return TCL_ERROR;
298     }
299    
300     d = slv_get_dofdata(g_solvsys_cur);
301     b = slv_get_solvers_blocks(g_solvsys_cur);
302     assert(d!=NULL && b!=NULL);
303    
304     numblock = b->nblocks-1;
305     maxblk = ndx = INT_MAX;
306     status=Tcl_GetInt(interp,argv[1],&ndx);
307     if (ndx<0 ||ndx>=maxblk||status==TCL_ERROR) {
308     Tcl_ResetResult(interp);
309     Tcl_SetResult(interp, "dbg_get_blk_coords: block does not exist",
310     TCL_STATIC);
311     FPRINTF(ASCERR, "dbg_get_blk_coords: block index invalid\n");
312     return TCL_ERROR;
313     }
314     if (ndx>numblock) {
315     Tcl_SetResult(interp, "none", TCL_STATIC);
316     return TCL_OK;
317     } else {
318     reg = b->block[ndx];
319     tmps= (char *)ascmalloc((2*MAXIMUM_NUMERIC_LENGTH+1)*sizeof(char));
320     sprintf(tmps,"%d %d %d %d",
321     reg.col.low, reg.row.low, reg.col.high, reg.row.high);
322     Tcl_AppendResult(interp,tmps,SNULL);
323     ascfree(tmps);
324     }
325     return TCL_OK;
326     }
327    
328     /*
329     * needs to deal with mtxless systems.
330     * quite likely spitting garbage.
331     */
332     int Asc_DebuGetEqnOfVar(ClientData cdata, Tcl_Interp *interp,
333     int argc, CONST84 char *argv[])
334     {
335     char * tmps;
336     int32 num,maxvar,numeq;
337     int tmpi,status=TCL_OK;
338     mtx_matrix_t mtx;
339     struct var_variable **vp;
340    
341 johnpye 670 UNUSED_PARAMETER(cdata);
342 johnpye 571
343     if ( argc != 2 ) {
344     FPRINTF(ASCERR,"call is: dbg_get_eqn_of_var <var Cindex> \n");
345     Tcl_SetResult(interp, "dbg_get_eqn_of_var wants 1 arg", TCL_STATIC);
346     return TCL_ERROR;
347     }
348     if (g_solvsys_cur==NULL) {
349     FPRINTF(ASCERR, "dbg_get_eqn_of_var called with NULL pointer\n");
350     Tcl_SetResult(interp, "dbg_get_eqn_of_var called without slv_system",
351     TCL_STATIC);
352     return TCL_ERROR;
353     }
354    
355     mtx = slv_get_sys_mtx(g_solvsys_cur);
356     vp=slv_get_solvers_var_list(g_solvsys_cur);
357     maxvar=slv_get_num_solvers_vars(g_solvsys_cur);
358    
359     tmpi=maxvar;
360     status=Tcl_GetInt(interp,argv[1],&tmpi);
361     if (tmpi<0 || tmpi >= maxvar) {
362     status=TCL_ERROR;
363     }
364     if (status!=TCL_OK) {
365     FPRINTF(ASCERR,"dbg_get_eqn_of_var: arg is not variable number in list\n");
366     Tcl_ResetResult(interp);
367     Tcl_SetResult(interp, "dbg_get_eqn_of_var: invalid variable number",
368     TCL_STATIC);
369     return status;
370     }
371     tmps= (char *)ascmalloc((MAXIMUM_NUMERIC_LENGTH+1)*sizeof(char));
372     num=tmpi;
373    
374     numeq = mtx_row_to_org(mtx,mtx_org_to_col(mtx,num));
375     if (numeq<0
376     || numeq>=maxvar
377     || var_fixed(vp[numeq])
378     || !var_active(vp[numeq]) ) {
379     Tcl_SetResult(interp, "none", TCL_STATIC);
380     } else {
381     sprintf(tmps,"%d",numeq);
382     Tcl_AppendElement(interp,tmps);
383     }
384     ascfree(tmps);
385     return TCL_OK;
386     }
387    
388     int Asc_DebuGetVarPartition(ClientData cdata, Tcl_Interp *interp,
389     int argc, CONST84 char *argv[])
390     {
391     char * tmps;
392     int32 numblock,lastblock,c,maxvar;
393     mtx_matrix_t mtx;
394     dof_t *d;
395     const mtx_block_t *b;
396    
397 johnpye 670 UNUSED_PARAMETER(cdata);
398 johnpye 571 (void)argv; /* stop gcc whine about unused parameter */
399    
400     if ( argc != 1 ) {
401     FPRINTF(ASCERR, "call is: dbg_get_varpartition <no args>\n");
402     Tcl_SetResult(interp, "dbg_get_varpartition: takes no arguments.",
403     TCL_STATIC);
404     return TCL_ERROR;
405     }
406     if (g_solvsys_cur==NULL) {
407     FPRINTF(ASCERR, "dbg_get_varpartition called with NULL pointer\n");
408     Tcl_SetResult(interp, "dbg_get_varpartition called without slv_system",
409     TCL_STATIC);
410     return TCL_ERROR;
411     }
412    
413     mtx = slv_get_sys_mtx(g_solvsys_cur);
414     d = slv_get_dofdata(g_solvsys_cur);
415     b = slv_get_solvers_blocks(g_solvsys_cur);
416     assert(d!=NULL && b!=NULL);
417    
418     lastblock = b->nblocks;
419    
420     tmps= (char *)ascmalloc((MAXIMUM_NUMERIC_LENGTH+1)*sizeof(char));
421     if (b->nblocks >1) {
422     mtx_region_t reg;
423     for (numblock=0; numblock <lastblock; numblock++) { /* over each block */
424     reg = b->block[numblock];
425     for( ; reg.col.low <= reg.col.high; reg.col.low++ ) {
426     sprintf(tmps,"%d",mtx_col_to_org(mtx,reg.col.low));
427     Tcl_AppendElement(interp,tmps);
428     }
429     sprintf(tmps,"/"); /* add block separator w/out extra whitespace */
430     Tcl_AppendResult(interp,tmps,SNULL);
431     }
432     } else {
433     struct var_variable **vp;
434     vp=slv_get_solvers_var_list(g_solvsys_cur);
435     maxvar=slv_get_num_solvers_vars(g_solvsys_cur);
436     if (vp) {
437     for (c=0; c<maxvar; c++) {
438     if (!var_fixed(vp[c]) && var_incident(vp[c]) && var_active(vp[c]) ) {
439     sprintf(tmps,"%d",var_sindex(vp[c]));
440     Tcl_AppendElement(interp,tmps);
441     } /* all in one block, no / needed */
442     }
443     }
444     }
445     ascfree(tmps);
446     return TCL_OK;
447     }
448    
449     int Asc_DebuGetEqnPartition(ClientData cdata, Tcl_Interp *interp,
450     int argc, CONST84 char *argv[])
451     {
452     char * tmps;
453     int32 numblock,lastblock,maxrel,c;
454     mtx_matrix_t mtx;
455     dof_t *d;
456     const mtx_block_t *b;
457    
458 johnpye 670 UNUSED_PARAMETER(cdata);
459 johnpye 571 (void)argv; /* stop gcc whine about unused parameter */
460    
461     if ( argc != 1 ) {
462     FPRINTF(ASCERR, "call is: dbg_get_eqnpartition <no args>\n");
463     Tcl_SetResult(interp, "dbg_get_eqnpartition: takes no arguments.",
464     TCL_STATIC);
465     return TCL_ERROR;
466     }
467     if (g_solvsys_cur==NULL) {
468     FPRINTF(ASCERR, "dbg_get_eqnpartition called with NULL pointer\n");
469     Tcl_SetResult(interp, "dbg_get_eqnpartition called without slv_system",
470     TCL_STATIC);
471     return TCL_ERROR;
472     }
473    
474     mtx = slv_get_sys_mtx(g_solvsys_cur);
475     d = slv_get_dofdata(g_solvsys_cur);
476     b = slv_get_solvers_blocks(g_solvsys_cur);
477     assert(d!=NULL && b!=NULL);
478    
479     lastblock = b->nblocks;
480    
481     tmps= (char *)ascmalloc((MAXIMUM_NUMERIC_LENGTH+1)*sizeof(char));
482     if (b->nblocks >1) {
483     mtx_region_t reg;
484     for (numblock=0; numblock <lastblock; numblock++) { /* over each block */
485     reg = b->block[numblock];
486     for( ; reg.row.low <= reg.row.high; reg.row.low++ ) {
487     sprintf(tmps,"%d",mtx_row_to_org(mtx,reg.row.low));
488     Tcl_AppendElement(interp,tmps);
489     }
490     sprintf(tmps,"/"); /* add block separator w/out extra whitespace */
491     Tcl_AppendResult(interp,tmps,SNULL);
492     }
493     } else {
494     struct rel_relation **rp;
495     rp=slv_get_solvers_rel_list(g_solvsys_cur);
496     maxrel=slv_get_num_solvers_rels(g_solvsys_cur);
497     if (rp) {
498     for (c=0; c<maxrel; c++) {
499     if (rel_included(rp[c]) && rel_active(rp[c])) {
500     sprintf(tmps,"%d",rel_sindex(rp[c]));
501     Tcl_AppendElement(interp,tmps);
502     } /* all in one block, no / needed */
503     }
504     }
505     }
506     ascfree(tmps);
507     return TCL_OK;
508     }
509    
510     int Asc_DebuListVars(ClientData cdata, Tcl_Interp *interp,
511     int argc, CONST84 char *argv[])
512     {
513     int status=TCL_OK,fil;
514     var_filter_t vfilter;
515     struct var_variable **vp;
516     int32 maxvar,c;
517     mtx_matrix_t mtx;
518     dof_t *d;
519     boolean vbool = FALSE;
520     char tmps[MAXIMUM_NUMERIC_LENGTH+1];
521    
522 johnpye 670 UNUSED_PARAMETER(cdata);
523 johnpye 571
524     if (( argc != 2 ) && ( argc != 3 )) {
525     FPRINTF(ASCERR,"call is: dbg_list_vars <1 args> [not] \n");
526     FPRINTF(ASCERR,"filter codes are:\n");
527     FPRINTF(ASCERR,"0 all vars, a rather redundant thing to do\n");
528     FPRINTF(ASCERR,"1 all vars incident\n");
529     FPRINTF(ASCERR,"2 all vars fixed\n");
530     FPRINTF(ASCERR,"3 all vars free\n");
531     FPRINTF(ASCERR,"4 all vars assigned\n");
532     FPRINTF(ASCERR,"5 all vars free & incident\n");
533     FFLUSH(ASCERR);
534     Tcl_SetResult(interp, "dbg_list_vars wants at least 1 arg", TCL_STATIC);
535     return TCL_ERROR;
536     }
537     if (g_solvsys_cur==NULL) {
538     FPRINTF(ASCERR, "dbg_list_vars called with NULL pointer\n");
539     Tcl_SetResult(interp,"dbg_list_vars called without slv_system",TCL_STATIC);
540     return TCL_ERROR;
541     }
542    
543     mtx = slv_get_sys_mtx(g_solvsys_cur);
544     status=Tcl_GetInt(interp,argv[1],&fil);
545     if(status!=TCL_OK) {
546     FPRINTF(ASCERR, "dbg_list_vars called with noninteger arg 1\n");
547     Tcl_SetResult(interp,"dbg_list_vars first arg must be integer",TCL_STATIC);
548     return TCL_ERROR;
549     }
550    
551     d = slv_get_dofdata(g_solvsys_cur);
552    
553     switch (fil) {
554     case 0: /*all*/
555     vfilter.matchbits = (VAR_ACTIVE);
556     vfilter.matchvalue = (VAR_ACTIVE);
557     break;
558     case 1:/*incid*/
559     vfilter.matchbits = (VAR_INCIDENT | VAR_ACTIVE);
560     vfilter.matchvalue = (VAR_INCIDENT | VAR_ACTIVE);
561     break;
562     case 2:/*fixed*/
563     vfilter.matchbits = (VAR_FIXED | VAR_ACTIVE);
564     vfilter.matchvalue = (VAR_FIXED | VAR_ACTIVE);
565     break;
566     case 3:/*free*/
567     vfilter.matchbits = (VAR_FIXED | VAR_ACTIVE);
568     vfilter.matchvalue = (VAR_ACTIVE);
569     break;
570     case 4:/*assigned*/
571     if (!mtx) {
572     FPRINTF(ASCERR, "dbg_list_vars called with NULL mtx pointer\n");
573     Tcl_SetResult(interp,"dbg_list_vars found bad system mtx", TCL_STATIC);
574     return TCL_ERROR;
575     }
576     break;
577     case 5:/*free*/
578     vfilter.matchbits = (VAR_FIXED | VAR_INCIDENT | VAR_ACTIVE);
579     vfilter.matchvalue = (VAR_INCIDENT | VAR_ACTIVE);
580     break;
581     default:
582     Tcl_SetResult(interp, "dbg_list_vars: Unrecognized variable filter",
583     TCL_STATIC);
584     return TCL_ERROR;
585     }
586     vp=slv_get_solvers_var_list(g_solvsys_cur);
587     maxvar=slv_get_num_solvers_vars(g_solvsys_cur);
588     for (c=0; c<maxvar; c++) {
589     switch( fil ) {
590     case 0: case 1:
591     case 2: case 3:
592     case 5:
593     vbool = (boolean)var_apply_filter(vp[c],&vfilter);
594     break;
595     case 4: {
596     int32 col = mtx_org_to_col(mtx,var_sindex(vp[c]));
597     vbool = (boolean)((col < d->structural_rank) && (col >= 0));
598     break;
599     }
600     }
601     if( argc == 3 ) {
602     vbool = !vbool;
603     }
604     if( vbool ) {
605     sprintf(&tmps[0],"%d",var_sindex(vp[c]));
606     Tcl_AppendElement(interp,&tmps[0]);
607     }
608     }
609     return TCL_OK;
610     }
611    
612    
613    
614     int Asc_DebuListRels(ClientData cdata, Tcl_Interp *interp,
615     int argc, CONST84 char *argv[])
616     {
617     int status=TCL_OK,fil;
618     rel_filter_t rfilter;
619     struct rel_relation **rp;
620     int32 maxrel,c;
621     mtx_matrix_t mtx;
622     dof_t *d;
623     boolean rbool = FALSE;
624     char tmps[MAXIMUM_NUMERIC_LENGTH+1];
625    
626 johnpye 670 UNUSED_PARAMETER(cdata);
627 johnpye 571
628     if (( argc != 2 ) && ( argc != 3 )) {
629     FPRINTF(ASCERR,"call is: dbg_list_rels <1 args> [not] \n");
630     FPRINTF(ASCERR,"filter codes are:\n");
631     FPRINTF(ASCERR,"0 all relations, a rather redundant thing to do\n");
632     FPRINTF(ASCERR,"1 all relations included\n");
633     FPRINTF(ASCERR,"2 all equalities\n");
634     FPRINTF(ASCERR,"3 all inequalities\n");
635     FPRINTF(ASCERR,"4 all assigned relations\n");
636     FFLUSH(ASCERR);
637     Tcl_SetResult(interp, "dbg_list_rels wants at least 1 arg", TCL_STATIC);
638     return TCL_ERROR;
639     }
640     if (g_solvsys_cur==NULL) {
641     FPRINTF(ASCERR, "dbg_list_rels called with NULL pointer\n");
642     Tcl_SetResult(interp,"dbg_list_rels called without slv_system",TCL_STATIC);
643     return TCL_ERROR;
644     }
645    
646     mtx = slv_get_sys_mtx(g_solvsys_cur);
647     status=Tcl_GetInt(interp,argv[1],&fil);
648     if(status!=TCL_OK) {
649     FPRINTF(ASCERR, "dbg_list_rels called with noninteger arg 1\n");
650     Tcl_SetResult(interp,"dbg_list_rels first arg must be integer",TCL_STATIC);
651     return TCL_ERROR;
652     }
653    
654     d = slv_get_dofdata(g_solvsys_cur);
655    
656     switch (fil) {
657     case 0: /*all*/
658     rfilter.matchbits = (REL_ACTIVE) ;
659     rfilter.matchvalue = (REL_ACTIVE) ;
660     break;
661     case 1:/*included*/
662     rfilter.matchbits = (REL_INCLUDED | REL_ACTIVE);
663     rfilter.matchvalue =(REL_INCLUDED | REL_ACTIVE);
664     break;
665     case 2:/*equality*/
666     rfilter.matchbits = (REL_EQUALITY | REL_ACTIVE);
667     rfilter.matchvalue = (REL_EQUALITY | REL_ACTIVE);
668     break;
669     case 3:/*inequality*/
670     rfilter.matchbits = (REL_EQUALITY | REL_ACTIVE);
671     rfilter.matchvalue = ( REL_ACTIVE);
672     break;
673     case 4:/*assigned*/
674     if (!mtx) {
675     FPRINTF(ASCERR, "dbg_list_rels called with NULL mtx pointer\n");
676     Tcl_SetResult(interp, "dbg_list_rels found bad system mtx",TCL_STATIC);
677     return TCL_ERROR;
678     }
679     break;
680     default:
681     Tcl_SetResult(interp, "dbg_list_rels: Unrecognized relation filter",
682     TCL_STATIC);
683     return TCL_ERROR;
684     }
685     rp=slv_get_solvers_rel_list(g_solvsys_cur);
686     maxrel=slv_get_num_solvers_rels(g_solvsys_cur);
687    
688     for ( c=0; c<maxrel; c++) {
689     switch( fil ) {
690     case 0: case 1:
691     case 2: case 3:
692     rbool = (boolean)rel_apply_filter(rp[c],&rfilter);
693     break;
694     case 4: {
695     int32 row = mtx_org_to_row(mtx,rel_sindex(rp[c]));
696     rbool = (boolean)((row < d->structural_rank) && (row >= 0));
697     break;
698     }
699     }
700     if( argc == 3 ) {
701     rbool = !rbool;
702     }
703     if( rbool ) {
704     sprintf(&tmps[0],"%d",rel_sindex(rp[c]));
705     Tcl_AppendElement(interp,&tmps[0]);
706     }
707     }
708     return TCL_OK;
709     }
710    
711     int Asc_DebuWriteVar(ClientData cdata, Tcl_Interp *interp,
712     int argc, CONST84 char *argv[])
713     {
714     int tmpi,dev,status=TCL_OK;
715     char tmps[QLFDID_LENGTH+1];
716     int32 maxvar,varnum,ilist;
717     struct var_variable **vp;
718     var_filter_t vfilter;
719     slv_system_t sys=NULL;
720     FILE *fp;
721     char *name=NULL;
722    
723     tmps[QLFDID_LENGTH]='\0';
724    
725     /*check sanity */
726     if (argc !=5 && argc !=6) {
727     FPRINTF(ASCERR,
728     "call is: dbg/brow_write_var <dev> %s",
729     " <var ndx> <fmt (#<8)> <solver/master> [simname]\n");
730     Tcl_SetResult(interp, "dbg/brow_write_var wants at least 4 args",
731     TCL_STATIC);
732     return TCL_ERROR;
733     }
734     if (!cdata) {
735     sys=g_solvsys_cur;
736     } else {
737     sys=g_browsys_cur;
738     }
739     if (sys==NULL) {
740     FPRINTF(ASCERR, "dbg/brow_write_var called with NULL pointer\n");
741     Tcl_SetResult(interp, "dbg/brow_write_var called without slv_system",
742     TCL_STATIC);
743     return TCL_ERROR;
744     }
745     /* get io option */
746     tmpi=3;
747     status=Tcl_GetInt(interp,argv[1],&tmpi);
748     if (tmpi<0 || tmpi >2) {
749     status=TCL_ERROR;
750     }
751     if (status!=TCL_OK) {
752     FPRINTF(ASCERR,"dbg/brow_write_var: first arg is 0,1, or 2\n");
753     Tcl_ResetResult(interp);
754     Tcl_SetResult(interp, "dbg/brow_write_var: invalid output dev",TCL_STATIC);
755     return status;
756     } else {
757     dev=tmpi;
758     }
759     switch (dev) {
760     case 0: fp=stdout;
761     break;
762     case 1: fp=ASCERR;
763     break;
764     case 2: fp=NULL;
765     break;
766     default : /* should never be here */
767     FPRINTF(ASCERR,
768     "dbg/brow_write_var called with strange i/o option!!\n");
769     return TCL_ERROR;
770     }
771    
772     /* get list option */
773     tmpi=0;
774     status=Tcl_GetInt(interp,argv[4],&tmpi);
775     if (tmpi<0 || tmpi >1) {
776     status=TCL_ERROR;
777     }
778     if (status!=TCL_OK) {
779     FPRINTF(ASCERR,
780     "dbg/brow_write_var: last arg is 0 (solver list) or 1 (master list)\n");
781     Tcl_ResetResult(interp);
782     Tcl_SetResult(interp, "dbg/brow_write_var: invalid var list",TCL_STATIC);
783     return status;
784     } else {
785     ilist =tmpi;
786     }
787    
788     if (ilist == 0) {
789     vp=slv_get_solvers_var_list(sys);
790     } else {
791     vp=slv_get_master_var_list(sys);
792     }
793    
794     /*get variable index */
795     maxvar=slv_get_num_solvers_vars(sys);
796     tmpi=maxvar;
797     status=Tcl_GetInt(interp,argv[2],&tmpi);
798     if (tmpi<0 || tmpi >= maxvar) {
799     status=TCL_ERROR;
800     }
801     if (status!=TCL_OK) {
802     FPRINTF(ASCERR,
803     "dbg/brow_write_var: 2nd arg is not variable number in list\n");
804     Tcl_ResetResult(interp);
805     Tcl_SetResult(interp, "dbg/brow_write_var: invalid variable number",
806     TCL_STATIC);
807     return status;
808     } else {
809     varnum=tmpi;
810     vp = vp + varnum;
811     }
812     /* get detail option */
813     status=Tcl_GetInt(interp,argv[3],&tmpi);
814     if (tmpi<0 || tmpi >7) {
815     status=TCL_ERROR;
816     }
817     if (status!=TCL_OK) {
818     FPRINTF(ASCERR,"dbg/brow_write_var: 3rd arg is not valid output format\n");
819     Tcl_ResetResult(interp);
820     Tcl_SetResult(interp, "dbg/brow_write_var: invalid output format #",
821     TCL_STATIC);
822     return status;
823     }
824     /* tmpi is now the format option, don't change it. */
825     if (tmpi>=3) { /*interface varindex*/
826     switch (dev) {
827     case 0:
828     case 1:
829     FPRINTF(fp,"<%d> ",varnum);
830     break;
831     case 2:
832     sprintf(&tmps[0],"<%d>",varnum);
833     Tcl_AppendElement(interp,&tmps[0]);
834     break;
835     default: break;
836     }
837     }
838     if (tmpi>=0) { /* qlfdid */
839     name = var_make_name(sys,*vp);
840     switch (dev) {
841     case 0:
842     case 1:
843     if( argc == 6 ) {
844     FPRINTF(fp,"%s.",argv[5]);
845     }
846     FPRINTF(fp,"%s ",name);
847     break;
848     case 2:
849     Tcl_AppendElement(interp,name);
850     break;
851     default: break;
852     }
853     if (name) {
854     ascfree(name);
855     }
856     name=NULL;
857     }
858     if (tmpi>=1) {/* value */
859     switch (dev) {
860     case 0:
861     case 1:
862     FPRINTF(fp,"%g ",var_value(*vp));
863     break;
864     case 2:
865     sprintf(&tmps[0],"%g",var_value(*vp));
866     Tcl_AppendElement(interp,&tmps[0]);
867     break;
868     default: break;
869     }
870     }
871     if (tmpi>=2) {/* dims */
872     char *dimens;
873     dimens = asc_make_dimensions(RealAtomDims(var_instance(*vp)));
874     switch (dev) {
875     case 0:
876     case 1:
877     FPRINTF(fp,"%s ",dimens);
878     break;
879     case 2:
880     Tcl_AppendElement(interp,dimens);
881     break;
882     default: break;
883     }
884     ascfree(dimens);
885     }
886     if (tmpi>=4) {/* fixed flag */
887     vfilter.matchbits = (VAR_FIXED | VAR_ACTIVE);
888     vfilter.matchvalue = (VAR_FIXED | VAR_ACTIVE);
889     switch (dev) {
890     case 0:
891     case 1:
892     FPRINTF(fp," fixed=%s", TORF(var_apply_filter(*vp,&vfilter)));
893     break;
894     case 2:
895     sprintf(&tmps[0],"fixed=%s", TORF(var_apply_filter(*vp,&vfilter)));
896     Tcl_AppendElement(interp,&tmps[0]);
897     break;
898     default: break;
899     }
900     }
901     if (tmpi>=5) {/* lower_bound */
902     switch (dev) {
903     case 0:
904     case 1:
905     FPRINTF(fp," %g ",var_lower_bound(*vp));
906     break;
907     case 2:
908     sprintf(&tmps[0],"%g",var_lower_bound(*vp));
909     Tcl_AppendElement(interp,&tmps[0]);
910     break;
911     default: break;
912     }
913     }
914     if (tmpi>=6) {/* nominal */
915     switch (dev) {
916     case 0:
917     case 1:
918     FPRINTF(fp,"%g ",var_nominal(*vp));
919     break;
920     case 2:
921     sprintf(&tmps[0],"%g",var_nominal(*vp));
922     Tcl_AppendElement(interp,&tmps[0]);
923     break;
924     default: break;
925     }
926     }
927     if (tmpi>=7) {/* upper_bound */
928     switch (dev) {
929     case 0:
930     case 1:
931     FPRINTF(fp,"%g ",var_upper_bound(*vp));
932     break;
933     case 2:
934     sprintf(&tmps[0],"%g",var_upper_bound(*vp));
935     Tcl_AppendElement(interp,&tmps[0]);
936     break;
937     default: break;
938     }
939     }
940     if (dev<2) {
941     FPRINTF(fp,"\n");
942     }
943     return TCL_OK;
944     }
945    
946     int Asc_DebuWriteRel(ClientData cdata, Tcl_Interp *interp,
947     int argc, CONST84 char *argv[])
948     {
949     int tmpi,dev,status=TCL_OK;
950     char tmps[MAXIMUM_NUMERIC_LENGTH+1];
951     int32 maxrel,relnum;
952     struct rel_relation **rp;
953     slv_system_t sys=NULL;
954     FILE *fp;
955    
956     tmps[MAXIMUM_NUMERIC_LENGTH]='\0';
957     /*check sanity */
958     if (argc !=4 && argc !=5) {
959     FPRINTF(ASCERR,
960     "call is: dbg/brow_write_rel <dev> <rel ndx> <fmt (#<5)> [simname] \n");
961     Tcl_SetResult(interp, "dbg/brow_write_rel wants at least 3 args",
962     TCL_STATIC);
963     return TCL_ERROR;
964     }
965     if (!cdata) {
966     sys=g_solvsys_cur;
967     } else {
968     sys=g_browsys_cur;
969     }
970     if (sys==NULL) {
971     FPRINTF(ASCERR, "dbg/brow_write_rel called with NULL pointer\n");
972     Tcl_SetResult(interp, "dbg/brow_write_rel called without slv_system",
973     TCL_STATIC);
974     return TCL_ERROR;
975     }
976     /* get io option */
977     tmpi=3;
978     status=Tcl_GetInt(interp,argv[1],&tmpi);
979     if (tmpi<0 || tmpi >2) {
980     status=TCL_ERROR;
981     }
982     if (status!=TCL_OK) {
983     FPRINTF(ASCERR,"dbg/brow_write_rel: first arg is 0,1, or 2\n");
984     Tcl_ResetResult(interp);
985     Tcl_SetResult(interp, "dbg/brow_write_rel: invalid output dev #",
986     TCL_STATIC);
987     return status;
988     } else {
989     dev=tmpi;
990     }
991     switch (dev) {
992     case 0: fp=stdout;
993     break;
994     case 1: fp=ASCERR;
995     break;
996     case 2: fp=NULL;
997     break;
998     default : /* should never be here */
999     FPRINTF(ASCERR,
1000     "dbg/brow_write_rel called with strange i/o option!!\n");
1001     return TCL_ERROR;
1002     }
1003     /*get relation index */
1004     rp=slv_get_solvers_rel_list(sys);
1005     maxrel=slv_get_num_solvers_rels(sys);
1006     tmpi=maxrel;
1007     status=Tcl_GetInt(interp,argv[2],&tmpi);
1008     if (tmpi<0 || tmpi >= maxrel) {
1009     status=TCL_ERROR;
1010     }
1011     if (status!=TCL_OK) {
1012     Tcl_ResetResult(interp);
1013     FPRINTF(ASCERR,
1014     "dbg/brow_write_rel: 2nd arg is not relation number in list\n");
1015     Tcl_SetResult(interp, "dbg/brow_write_rel: invalid relation number",
1016     TCL_STATIC);
1017     return status;
1018     } else {
1019     relnum=tmpi;
1020     rp = rp + relnum;
1021     }
1022     /* get detail option */
1023     status=Tcl_GetInt(interp,argv[3],&tmpi);
1024     if (tmpi<0 || tmpi >4) {
1025     status=TCL_ERROR;
1026     }
1027     if (status!=TCL_OK) {
1028     Tcl_ResetResult(interp);
1029     FPRINTF(ASCERR,"dbg/brow_write_rel: 3rd arg is not valid output format\n");
1030     Tcl_SetResult(interp, "dbg/brow_write_rel: invalid output format #",
1031     TCL_STATIC);
1032     return status;
1033     }
1034     /* tmpi is now the format option, don't change it. */
1035     if (tmpi==4) { /* return only the relation string */
1036     char *infix=NULL;
1037     infix= relman_make_string_infix(sys,*rp);
1038     if (dev<2) {
1039     FPRINTF(fp,"%s\n",infix);
1040     } else {
1041     Tcl_AppendElement(interp, infix);
1042     }
1043     if (infix) {
1044     ascfree(infix);
1045     }
1046     return TCL_OK;
1047     }
1048     if (tmpi>=2) { /*interface relindex*/
1049     switch (dev) {
1050     case 0:
1051     case 1:
1052     FPRINTF(fp,"<%d> ",relnum);
1053     break;
1054     case 2:
1055     sprintf(&tmps[0],"<%d>",relnum);
1056     Tcl_AppendElement(interp,&tmps[0]);
1057     break;
1058     default: break;
1059     }
1060     }
1061     if (tmpi>=0) { /* qlfdid */
1062     char *name=NULL;
1063     name = rel_make_name(sys,*rp);
1064     switch (dev) {
1065     case 0:
1066     case 1:
1067     if( argc == 5 ) {
1068     FPRINTF(fp,"%s.",argv[4]);
1069     }
1070     FPRINTF(fp,"%s ",name);
1071     break;
1072     case 2:
1073     Tcl_AppendElement(interp,name);
1074     break;
1075     default: break;
1076     }
1077     if (name) {
1078     ascfree(name);
1079     }
1080     }
1081     if (tmpi>=1) {/* residual */
1082     double res=0;
1083     res=relman_eval(*rp,&calc_ok,SAFE_FIX_ME);
1084     switch (dev) {
1085     case 0:
1086     case 1:
1087     FPRINTF(fp,"%g ",res);
1088     break;
1089     case 2:
1090     sprintf(&tmps[0],"%g",res);
1091     Tcl_AppendElement(interp,&tmps[0]);
1092     break;
1093     default: break;
1094     }
1095     }
1096     if (tmpi>=3) {/* include flag */
1097     int truth;
1098     truth=(rel_included(*rp) && rel_active(*rp));
1099     switch (dev) {
1100     case 0:
1101     case 1:
1102     FPRINTF(fp," included and active=%s", TORF(truth));
1103     break;
1104     case 2:
1105     sprintf(&tmps[0],"included and active =%s", TORF(truth));
1106     Tcl_AppendElement(interp,&tmps[0]);
1107     break;
1108     default: break;
1109     }
1110     }
1111     if (dev<2) {
1112     FPRINTF(fp,"\n");
1113     }
1114     return TCL_OK;
1115     }
1116    
1117     int Asc_DebuWriteUnattachedVar(ClientData cdata, Tcl_Interp *interp,
1118     int argc, CONST84 char *argv[])
1119     {
1120     int tmpi,dev,status=TCL_OK;
1121     char tmps[QLFDID_LENGTH+1];
1122     int32 maxvar,c;
1123     struct var_variable **vp;
1124     var_filter_t vfilter;
1125     slv_system_t sys=NULL;
1126     FILE *fp;
1127     char *name=NULL;
1128     char *dimens;
1129    
1130     tmps[QLFDID_LENGTH]='\0';
1131    
1132     /*check sanity */
1133     if ( argc < 2 ) {
1134     FPRINTF(ASCERR,
1135     "call is: dbg_write_unattvar <dev> [simname] \n");
1136     Tcl_SetResult(interp, "dbg_write_unattvar wants 2 args", TCL_STATIC);
1137     return TCL_ERROR;
1138     }
1139    
1140     if (!cdata) {
1141     sys=g_solvsys_cur;
1142     } else {
1143     sys=g_browsys_cur;
1144     }
1145     if (sys==NULL) {
1146     FPRINTF(ASCERR, "dbg_write_unattvar called with NULL pointer\n");
1147     Tcl_SetResult(interp, "dbg_write_var unattcalled without slv_system",
1148     TCL_STATIC);
1149     return TCL_ERROR;
1150     }
1151    
1152    
1153     /* get io option */
1154     tmpi=3;
1155     status=Tcl_GetInt(interp,argv[1],&tmpi);
1156    
1157     if (tmpi<0 || tmpi >2) {
1158     status=TCL_ERROR;
1159     }
1160    
1161     if (status!=TCL_OK) {
1162     FPRINTF(ASCERR,"dbg_write_unattvar: first arg is 0,1, or 2\n");
1163     Tcl_ResetResult(interp);
1164     Tcl_SetResult(interp, "dbg_write_unattvar: invalid output dev",TCL_STATIC);
1165     return status;
1166     } else {
1167     dev=tmpi;
1168     }
1169    
1170    
1171     switch (dev) {
1172     case 0: fp=stdout;
1173     break;
1174     case 1: fp=ASCERR;
1175     break;
1176     case 2: fp=NULL;
1177     break;
1178     default : /* should never be here */
1179     FPRINTF(ASCERR,
1180     "dbg_write_unattvar called with strange i/o option!!\n");
1181     return TCL_ERROR;
1182     }
1183    
1184     /*get unattached variable list */
1185     vp=slv_get_solvers_unattached_list(sys);
1186     maxvar = slv_get_num_solvers_unattached(sys);
1187    
1188     vfilter.matchbits = (VAR_ACTIVE);
1189     vfilter.matchvalue = (VAR_ACTIVE);
1190    
1191     /* Writing the list of unattached variables */
1192     for (c=0; c<maxvar; c++) {
1193     if (var_apply_filter(vp[c],&vfilter)) {
1194     /* qlfdid */
1195     name = var_make_name(sys,vp[c]);
1196     switch (dev) {
1197     case 0:
1198     case 1:
1199     FPRINTF(fp,"%s ",name);
1200     break;
1201     case 2:
1202     Tcl_AppendElement(interp,name);
1203     break;
1204     default: break;
1205     }
1206    
1207     if (name) {
1208     ascfree(name);
1209     name=NULL;
1210     }
1211    
1212     /* value */
1213     switch (dev) {
1214     case 0:
1215     case 1:
1216     FPRINTF(fp,"%g ",var_value(vp[c]));
1217     break;
1218     case 2:
1219     sprintf(&tmps[0],"%g",var_value(vp[c]));
1220     Tcl_AppendElement(interp,&tmps[0]);
1221     break;
1222     default: break;
1223     }
1224    
1225    
1226     /* dims */
1227     dimens = asc_make_dimensions(RealAtomDims(var_instance(vp[c])));
1228     switch (dev) {
1229     case 0:
1230     case 1:
1231     FPRINTF(fp,"%s ",dimens);
1232     break;
1233     case 2:
1234     Tcl_AppendElement(interp,dimens);
1235     break;
1236     default: break;
1237     }
1238     ascfree(dimens);
1239    
1240     if (dev<2) {
1241     FPRINTF(fp,"\n");
1242     }
1243     }
1244     }
1245    
1246     return TCL_OK;
1247     }
1248    
1249     int Asc_DebuWriteObj(ClientData cdata, Tcl_Interp *interp,
1250     int argc, CONST84 char *argv[])
1251     {
1252     int tmpi,dev,status=TCL_OK;
1253     char tmps[MAXIMUM_NUMERIC_LENGTH+1];
1254     int32 maxrel,relnum;
1255     struct rel_relation **rp;
1256     slv_system_t sys=NULL;
1257     FILE *fp;
1258    
1259     tmps[MAXIMUM_NUMERIC_LENGTH]='\0';
1260     /*check sanity */
1261     if (argc !=4 && argc !=5) {
1262     FPRINTF(ASCERR,
1263     "call is: dbg/brow_write_obj <dev> <rel ndx> <fmt (#<5)> [simname] \n");
1264     Tcl_SetResult(interp, "dbg/brow_write_obj wants at least 3 args",
1265     TCL_STATIC);
1266     return TCL_ERROR;
1267     }
1268     if (!cdata) {
1269     sys=g_solvsys_cur;
1270     } else {
1271     sys=g_browsys_cur;
1272     }
1273     if (sys==NULL) {
1274     FPRINTF(ASCERR, "dbg/brow_write_obj called with NULL pointer\n");
1275     Tcl_SetResult(interp, "dbg/brow_write_obj called without slv_system",
1276     TCL_STATIC);
1277     return TCL_ERROR;
1278     }
1279     /* get io option */
1280     tmpi=3;
1281     status=Tcl_GetInt(interp,argv[1],&tmpi);
1282     if (tmpi<0 || tmpi >2) {
1283     status=TCL_ERROR;
1284     }
1285     if (status!=TCL_OK) {
1286     FPRINTF(ASCERR,"dbg/brow_write_obj: first arg is 0,1, or 2\n");
1287     Tcl_ResetResult(interp);
1288     Tcl_SetResult(interp, "dbg/brow_write_obj: invalid output dev #",
1289     TCL_STATIC);
1290     return status;
1291     } else {
1292     dev=tmpi;
1293     }
1294     switch (dev) {
1295     case 0: fp=stdout;
1296     break;
1297     case 1: fp=ASCERR;
1298     break;
1299     case 2: fp=NULL;
1300     break;
1301     default : /* should never be here */
1302     FPRINTF(ASCERR,
1303     "dbg/brow_write_obj called with strange i/o option!!\n");
1304     return TCL_ERROR;
1305     }
1306     /*get relation index */
1307     rp=slv_get_solvers_obj_list(sys);
1308     maxrel=slv_get_num_solvers_objs(sys);
1309     tmpi=maxrel;
1310     status=Tcl_GetInt(interp,argv[2],&tmpi);
1311     if (tmpi<0 || tmpi >= maxrel) {
1312     status=TCL_ERROR;
1313     }
1314     if (status!=TCL_OK) {
1315     Tcl_ResetResult(interp);
1316     FPRINTF(ASCERR,
1317     "dbg/brow_write_obj: 2nd arg is not objective number in list\n");
1318     Tcl_SetResult(interp, "dbg/brow_write_obj: invalid objective number",
1319     TCL_STATIC);
1320     return status;
1321     } else {
1322     relnum=tmpi;
1323     rp = rp + relnum;
1324     }
1325     /* get detail option */
1326     status=Tcl_GetInt(interp,argv[3],&tmpi);
1327     if (tmpi<0 || tmpi >4) {
1328     status=TCL_ERROR;
1329     }
1330     if (status!=TCL_OK) {
1331     Tcl_ResetResult(interp);
1332     FPRINTF(ASCERR,"dbg/brow_write_obj: 3rd arg is not valid output format\n");
1333     Tcl_SetResult(interp, "dbg/brow_write_obj: invalid output format #",
1334     TCL_STATIC);
1335     return status;
1336     }
1337     /* tmpi is now the format option, don't change it. */
1338     if (tmpi==4) { /* return only the objective string */
1339     char *infix=NULL;
1340     infix= relman_make_string_infix(sys,*rp);
1341     if (dev<2) {
1342     FPRINTF(fp,"%s\n",infix);
1343     } else {
1344     Tcl_AppendElement(interp, infix);
1345     }
1346     if (infix) {
1347     ascfree(infix);
1348     }
1349     return TCL_OK;
1350     }
1351     if (tmpi>=2) { /*interface relindex*/
1352     switch (dev) {
1353     case 0:
1354     case 1:
1355     FPRINTF(fp,"<%d> ",relnum);
1356     break;
1357     case 2:
1358     sprintf(&tmps[0],"<%d>",relnum);
1359     Tcl_AppendElement(interp,&tmps[0]);
1360     break;
1361     default: break;
1362     }
1363     }
1364     if (tmpi>=0) { /* qlfdid */
1365     char *name=NULL;
1366     name = rel_make_name(sys,*rp);
1367     switch (dev) {
1368     case 0:
1369     case 1:
1370     if( argc == 5 ) {
1371     FPRINTF(fp,"%s.",argv[4]);
1372     }
1373     FPRINTF(fp,"%s ",name);
1374     break;
1375     case 2:
1376     Tcl_AppendElement(interp,name);
1377     break;
1378     default: break;
1379     }
1380     if (name) {
1381     ascfree(name);
1382     }
1383     }
1384     if (tmpi>=1) {/* residual */
1385     double res=0;
1386     res=relman_eval(*rp,&calc_ok,SAFE_FIX_ME);
1387     switch (dev) {
1388     case 0:
1389     case 1:
1390     FPRINTF(fp,"%g ",res);
1391     break;
1392     case 2:
1393     sprintf(&tmps[0],"%g",res);
1394     Tcl_AppendElement(interp,&tmps[0]);
1395     break;
1396     default: break;
1397     }
1398     }
1399     if (tmpi>=3) {/* include flag */
1400     int truth;
1401     truth=(rel_included(*rp) && rel_active(*rp));
1402     switch (dev) {
1403     case 0:
1404     case 1:
1405     FPRINTF(fp," included and active=%s", TORF(truth));
1406     break;
1407     case 2:
1408     sprintf(&tmps[0],"included and active =%s", TORF(truth));
1409     Tcl_AppendElement(interp,&tmps[0]);
1410     break;
1411     default: break;
1412     }
1413     }
1414     if (dev<2) {
1415     FPRINTF(fp,"\n");
1416     }
1417     return TCL_OK;
1418     }
1419    
1420     int Asc_DebuWriteVarAttr(ClientData cdata, Tcl_Interp *interp,
1421     int argc, CONST84 char *argv[])
1422     {
1423     int tmpi,status=TCL_OK;
1424     char tmps[QLFDID_LENGTH+1];
1425     int32 maxvar,varnum;
1426     struct var_variable **vp;
1427     struct Instance *i;
1428     char *name=NULL;
1429     char *dimens=NULL;
1430     slv_system_t sys;
1431     sys=g_solvsys_cur; /* may be null */
1432    
1433     tmps[QLFDID_LENGTH]='\0';
1434     /*check sanity */
1435     if ( argc != 2 ) {
1436     if (cdata) {
1437     FPRINTF(ASCERR, "call is: dbg_write_qlfattr <qlfdid>\n");
1438     Tcl_SetResult(interp, "dbg_write_qlfattr wants 1 arg", TCL_STATIC);
1439     } else {
1440     FPRINTF(ASCERR, "call is: dbg_write_varattr <var ndx>\n");
1441     Tcl_SetResult(interp, "dbg_write_varattr wants 1 arg", TCL_STATIC);
1442     }
1443     return TCL_ERROR;
1444     }
1445     if (!cdata) { /* dbg_write_varattr case */
1446     if (sys==NULL) {
1447     FPRINTF(ASCERR, "dbg_write_varattr called with NULL pointer\n");
1448     Tcl_SetResult(interp, "dbg_write_varattr called without slv_system",
1449     TCL_STATIC);
1450     return TCL_ERROR;
1451     }
1452     /*get variable index */
1453     vp=slv_get_solvers_var_list(sys);
1454     if (vp==NULL) {
1455     FPRINTF(ASCERR, "dbg_write_varattr called with NULL varlist\n");
1456     Tcl_SetResult(interp, "dbg_write_varattr called without varlist",
1457     TCL_STATIC);
1458     return TCL_ERROR;
1459     }
1460     maxvar=slv_get_num_solvers_vars(sys);
1461     tmpi=maxvar;
1462     status=Tcl_GetInt(interp,argv[1],&tmpi);
1463     if (tmpi<0 || tmpi >= maxvar) {
1464     status=TCL_ERROR;
1465     }
1466     if (status!=TCL_OK) {
1467     FPRINTF(ASCERR,"dbg_write_varattr: arg not variable number in list\n");
1468     Tcl_ResetResult(interp);
1469     Tcl_SetResult(interp, "dbg_write_varattr: invalid variable number",
1470     TCL_STATIC);
1471     return status;
1472     } else {
1473     varnum=tmpi;
1474     vp = vp + varnum;
1475     i=var_instance(*vp);
1476     }
1477     } else { /* qlfattr case */ /* broken, since vars != instances */
1478     #define VARS_EQ_INSTS 0
1479     #if VARS_EQ_INST
1480     status = Asc_QlfdidSearch3(argv[1],0);
1481     if (status==0) {
1482     i = g_search_inst;
1483     vp = &i; /* this is in error */
1484     } else {
1485     Tcl_AppendResult(interp,"dbg_write_qlfattr: QlfdidSearch error",
1486     argv[1]," not found.",SNULL);
1487     return TCL_ERROR;
1488     }
1489     if (InstanceKind(i)!=REAL_ATOM_INST) {
1490     Tcl_SetResult(interp,"dbg_write_qlfattr called on non-variable instance",
1491     TCL_STATIC);
1492     return TCL_ERROR;
1493     }
1494     } /* vp and i now set to interesting instance */
1495     if (!vp || !i) {
1496     if (cdata) {
1497     FPRINTF(ASCERR, "dbg_write_qlfattr found NULL variable instance\n");
1498     Tcl_SetResult(interp,"dbg_write_qlfattr found NULL variable",TCL_STATIC);
1499     } else {
1500     FPRINTF(ASCERR, "dbg_write_varattr found NULL variable instance\n");
1501     Tcl_SetResult(interp,"dbg_write_varattr found NULL variable",TCL_STATIC);
1502     }
1503     return TCL_ERROR;
1504     #else
1505     Tcl_SetResult(interp,
1506     "dbg_write_qlfattr broken since vars no longer = instances.",
1507     TCL_STATIC);
1508     return TCL_ERROR;
1509     #endif
1510     }
1511     /* write type */
1512     Tcl_AppendResult(interp,"{TYPE: ",(char *)InstanceType(i),"} ",SNULL);
1513     /* write dims */
1514     dimens = asc_make_dimensions(RealAtomDims(var_instance(*vp)));
1515     Tcl_AppendResult(interp,"{DIMENSIONS: ",dimens,"}",SNULL);
1516     if (dimens) {
1517     ascfree(dimens);
1518     }
1519     dimens=NULL;
1520     /* write value */
1521     sprintf(tmps,"VALUE: %g",var_value(*vp));
1522     Tcl_AppendElement(interp,tmps);
1523     /* write qlfdid */
1524     if (cdata) {
1525     Tcl_AppendElement(interp,argv[1]);
1526     } else {
1527     name = var_make_name(sys,*vp); /* this is in error. no sys exists */
1528     Tcl_AppendElement(interp,name);
1529     if (name) {
1530     ascfree(name);
1531     }
1532     name=NULL;
1533     }
1534     if (Asc_DispWriteIpCmd(interp,i)) {
1535     Tcl_AppendElement(interp,"index: -1");
1536     Tcl_AppendElement(interp,"incident: -1");
1537     Tcl_AppendElement(interp,"in block: -1");
1538     }
1539     Tcl_AppendResult(interp," ",SNULL);
1540     Asc_BrowWriteAtomChildren(interp,i);
1541     return TCL_OK;
1542     }
1543    
1544     int Asc_DebuRelIncluded(ClientData cdata, Tcl_Interp *interp,
1545     int argc, CONST84 char *argv[])
1546     {
1547     int tmpi,status=TCL_OK;
1548     int32 maxrel,relnum;
1549     struct rel_relation **rp;
1550     slv_system_t sys=NULL;
1551     char res[40];
1552    
1553 johnpye 670 UNUSED_PARAMETER(cdata);
1554 johnpye 571
1555     if ( argc != 2 ) {
1556     FPRINTF(ASCERR, "call is: dbg_rel_included <var ndx>\n");
1557     Tcl_SetResult(interp, "dbg_rel_included wants 1 arg", TCL_STATIC);
1558     return TCL_ERROR;
1559     }
1560     sys=g_solvsys_cur;
1561     if (sys==NULL) {
1562     FPRINTF(ASCERR, "dbg_rel_included called with NULL pointer\n");
1563     Tcl_SetResult(interp, "dbg_rel_included called without slv_system",
1564     TCL_STATIC);
1565     return TCL_ERROR;
1566     }
1567     /*get relation index */
1568     rp=slv_get_solvers_rel_list(sys);
1569     maxrel=slv_get_num_solvers_rels(sys);
1570     tmpi=maxrel;
1571     status=Tcl_GetInt(interp,argv[1],&tmpi);
1572     if (tmpi<0 || tmpi >= maxrel) {
1573     status=TCL_ERROR;
1574     }
1575     if (status!=TCL_OK) {
1576     FPRINTF(ASCERR, "dbg_rel_included: arg is not number in relation list\n");
1577     Tcl_ResetResult(interp);
1578     Tcl_SetResult(interp, "dbg_rel_included: invalid relation number",
1579     TCL_STATIC);
1580     return status;
1581     } else {
1582     relnum=tmpi;
1583     rp = rp + relnum;
1584     }
1585     sprintf(res,"%d",(rel_included(*rp) && rel_active(*rp) ));
1586     Tcl_AppendResult(interp,res,SNULL);
1587     return TCL_OK;
1588     }
1589    
1590     int Asc_DebuVarFixed(ClientData cdata, Tcl_Interp *interp,
1591     int argc, CONST84 char *argv[])
1592     {
1593     int tmpi,status=TCL_OK;
1594     int32 maxvar,varnum;
1595     struct var_variable **vp;
1596     slv_system_t sys=NULL;
1597     char res[40];
1598    
1599 johnpye 670 UNUSED_PARAMETER(cdata);
1600 johnpye 571
1601     if ( argc != 2 ) {
1602     FPRINTF(ASCERR, "call is: dbg_var_fixed <var ndx>\n");
1603     Tcl_SetResult(interp, "dbg_var_fixed wants 1 arg", TCL_STATIC);
1604     return TCL_ERROR;
1605     }
1606     sys=g_solvsys_cur;
1607     if (sys==NULL) {
1608     FPRINTF(ASCERR, "dbg_var_fixed called with NULL pointer\n");
1609     Tcl_SetResult(interp,"dbg_var_fixed called without slv_system",TCL_STATIC);
1610     return TCL_ERROR;
1611     }
1612     /*get variable index */
1613     vp=slv_get_solvers_var_list(sys);
1614     maxvar=slv_get_num_solvers_vars(sys);
1615     tmpi=maxvar;
1616     status=Tcl_GetInt(interp,argv[1],&tmpi);
1617     if (tmpi<0 || tmpi >= maxvar) {
1618     status=TCL_ERROR;
1619     }
1620     if (status!=TCL_OK) {
1621     FPRINTF(ASCERR, "dbg_var_fixed: arg is not number in variable list\n");
1622     Tcl_ResetResult(interp);
1623     Tcl_SetResult(interp, "dbg_var_fixed: invalid variable number",TCL_STATIC);
1624     return status;
1625     } else {
1626     varnum=tmpi;
1627     vp = vp + varnum;
1628     }
1629     sprintf(res,"%d",var_fixed(*vp));
1630     Tcl_AppendResult(interp,res,SNULL);
1631     return TCL_OK;
1632     }
1633    
1634    
1635     int Asc_DebuGetIncidence(ClientData cdata, Tcl_Interp *interp,
1636     int argc, CONST84 char *argv[])
1637     {
1638     int32 relnum,maxrel,ninc,c;
1639     struct rel_relation **rp=NULL;
1640     var_filter_t vfilter;
1641     const struct var_variable **vp=NULL;
1642     int status=TCL_OK;
1643     char *tmps=NULL;
1644    
1645 johnpye 670 UNUSED_PARAMETER(cdata);
1646 johnpye 571
1647     if ( argc != 2 ) {
1648     FPRINTF(ASCERR, "call is: dbg_get_incidence <rel index>\n");
1649     Tcl_SetResult(interp, "dbg_get_incidence takes 1 arg", TCL_STATIC);
1650     return TCL_ERROR;
1651     }
1652     if (g_solvsys_cur==NULL) {
1653     FPRINTF(ASCERR, "dbg_get_incidence called with NULL pointer\n");
1654     Tcl_SetResult(interp, "dbg_get_incidence called without slv_system",
1655     TCL_STATIC);
1656     return TCL_ERROR;
1657     }
1658     rp=slv_get_solvers_rel_list(g_solvsys_cur);
1659     if (!rp) {
1660     FPRINTF(ASCERR, "NULL relation list found in dbg_get_incidence\n");
1661     Tcl_SetResult(interp, "dbg_get_incidence called with null rellist",
1662     TCL_STATIC);
1663     return TCL_ERROR;
1664     }
1665    
1666     maxrel=slv_get_num_solvers_rels(g_solvsys_cur);
1667     relnum=maxrel;
1668     status=Tcl_GetInt(interp,argv[1],&relnum);
1669     if (relnum>=maxrel||status==TCL_ERROR) {
1670     Tcl_ResetResult(interp);
1671     Tcl_SetResult(interp,
1672     "dbg_get_incidence: equation requested does not exist",
1673     TCL_STATIC);
1674     /*FPRINTF(ASCERR, "dbg_get_incidence: relation index invalid.\n"); */
1675     return TCL_ERROR;
1676     }
1677    
1678     tmps= (char *)ascmalloc((MAXIMUM_NUMERIC_LENGTH+1)*sizeof(char));
1679     ninc = rel_n_incidences(rp[relnum]);
1680     vp=rel_incidence_list(rp[relnum]);
1681    
1682     vfilter.matchbits = (VAR_SVAR | VAR_ACTIVE);
1683     vfilter.matchvalue = (VAR_SVAR | VAR_ACTIVE);
1684    
1685     if (vp) {
1686     for(c=0; c<ninc; c++ ) {
1687     if(var_apply_filter(vp[c],&vfilter)) {
1688     sprintf(tmps,"%d",var_sindex(vp[c]));
1689     Tcl_AppendElement(interp,tmps);
1690     }
1691     }
1692     }
1693     if (tmps) {
1694     ascfree(tmps);
1695     }
1696     return TCL_OK;
1697     }
1698    
1699     int Asc_DebuGetOrder(ClientData cdata, Tcl_Interp *interp,
1700     int argc, CONST84 char **argv)
1701     {
1702     int32 ndx,rc,max;
1703     mtx_matrix_t mtx;
1704     char num[20];
1705     rel_filter_t rfilter;
1706    
1707 johnpye 670 UNUSED_PARAMETER(cdata);
1708 johnpye 571
1709     if ( argc != 2 ) {
1710     FPRINTF(ASCERR,"call is: dbg_get_order <row,col> \n");
1711     Tcl_SetResult(interp, "dbg_get_order wants one arg", TCL_STATIC);
1712     return TCL_ERROR;
1713     }
1714     if (g_solvsys_cur==NULL) {
1715     FPRINTF(ASCERR,"dbg_get_order called with empty slv_system\n");
1716     Tcl_SetResult(interp, "dbg_get_order called with empty slv_system",
1717     TCL_STATIC);
1718     return TCL_ERROR;
1719     }
1720     mtx=slv_get_sys_mtx(g_solvsys_cur);
1721     if (!mtx) {
1722     FPRINTF(ASCERR,"dbg_get_order found no mtx. odd!\n");
1723     Tcl_SetResult(interp, "dbg_get_order found no mtx. odd!", TCL_STATIC);
1724     return TCL_ERROR;
1725     }
1726     max=mtx_order(mtx);
1727     if (argv[1][0]=='r') {
1728     rfilter.matchbits = (REL_INCLUDED | REL_ACTIVE);
1729     rfilter.matchvalue = (REL_INCLUDED | REL_ACTIVE);
1730     max=slv_count_solvers_rels(g_solvsys_cur,&rfilter);
1731     }
1732     for (rc=0;rc<max;rc++) {
1733     switch (argv[1][0]) {
1734     case 'r':
1735     ndx=mtx_row_to_org(mtx,rc);
1736     break;
1737     case 'c':
1738     ndx=mtx_col_to_org(mtx,rc);
1739     break;
1740     default:
1741     ndx=(-1);
1742     break;
1743     }
1744     sprintf(&num[0],"%d",ndx);
1745     Tcl_AppendElement(interp,(char *)&num[0]);
1746     }
1747     return TCL_OK;
1748     }
1749    
1750     int Asc_DebuWriteIncidence(ClientData cdata, Tcl_Interp *interp,
1751     int argc, CONST84 char *argv[])
1752     {
1753     int tmpi,dev,status;
1754     FILE * fp;
1755     mtx_matrix_t mtx;
1756     mtx_coord_t nz;
1757     int32 order,bnum,maxrel;
1758     int32 *tmp;
1759     mtx_region_t reg;
1760     real64 value;
1761     struct rel_relation **rp;
1762 johnpye 708 char *line = ASC_NEW_ARRAY(char,32);
1763 johnpye 571
1764 johnpye 670 UNUSED_PARAMETER(cdata);
1765 johnpye 571
1766     if ( argc != 2 ) {
1767     FPRINTF(ASCERR,"call is: dbg_write_incidence <device#> \n");
1768     Tcl_SetResult(interp, "dbg_write_incidence wants 1 arg", TCL_STATIC);
1769     return TCL_ERROR;
1770     }
1771     if (!g_solvsys_cur) {
1772     FPRINTF(ASCERR, "dbg_write_incidence called with NULL pointer\n");
1773     Tcl_SetResult(interp, "dbg_write_incidence called without slv_system",
1774     TCL_STATIC);
1775     return TCL_ERROR;
1776     }
1777     rp=slv_get_solvers_rel_list(g_solvsys_cur);
1778     if (!rp) {
1779     FPRINTF(ASCERR, "dbg_write_incidence called with NULL rellist\n");
1780     Tcl_SetResult(interp,
1781     "dbg_write_incidence called on system without rel list",
1782     TCL_STATIC);
1783     return TCL_ERROR;
1784     }
1785     maxrel=slv_get_num_solvers_rels(g_solvsys_cur);
1786    
1787     /* get io option */
1788     tmpi=4;
1789     status=Tcl_GetInt(interp,argv[1],&tmpi);
1790     if (tmpi<0 || tmpi >3) {
1791     status=TCL_ERROR;
1792     }
1793     if (status!=TCL_OK) {
1794     FPRINTF(ASCERR,"dbg_write_incidence: first arg is 0,1, or 2\n");
1795     Tcl_ResetResult(interp);
1796     Tcl_SetResult(interp, "dbg_write_incidence: invalid output dev #",
1797     TCL_STATIC);
1798     return status;
1799     } else {
1800     dev=tmpi;
1801     }
1802     switch (dev) {
1803     case 0: fp=stdout;
1804     case 3: fp=stdout;
1805     break;
1806     case 1: fp=ASCERR;
1807     break;
1808     case 2: fp=NULL;
1809     break;
1810     default : /* should never be here */
1811     FPRINTF(ASCERR,"dbg_write_incidence called with strange i/o option\n");
1812     return TCL_ERROR;
1813     }
1814     if (dev==3) { /* an unpublished option for DOF debugging */
1815     tmpi=slv_get_selected_solver(g_solvsys_cur);
1816     slv_select_solver(g_solvsys_cur,32767);
1817     }
1818     mtx=slv_get_sys_mtx(g_solvsys_cur);
1819     if (!mtx) {
1820     FPRINTF(ASCERR,"dbg_get_order found no linsol matrix. odd!\n");
1821     Tcl_SetResult(interp, "dbg_get_order found no linsol matrix. odd!",
1822     TCL_STATIC);
1823     return TCL_ERROR;
1824     }
1825     if (dev==3) {
1826     slv_select_solver(g_solvsys_cur,tmpi);
1827     }
1828     order = mtx_order(mtx);
1829 johnpye 670 tmp = ASC_NEW_ARRAY(int32,order);
1830 johnpye 571 for( nz.row=0 ; nz.row < order ; ++nz.row ) {
1831     #if DP_DEBUG
1832     if (dev <2) {
1833     FPRINTF(fp,"org row %4d",mtx_row_to_org(mtx,nz.row));
1834     }
1835     #endif
1836     if( mtx_output_assigned(mtx) ) {
1837     bnum=mtx_block_containing_row(mtx,nz.row,&reg);
1838     } else {
1839     bnum = mtx_row_to_org(mtx,nz.row);
1840     if ( bnum >= 0 && bnum < maxrel
1841     && rel_included(rp[bnum]) && rel_active(rp[bnum]) ) {
1842     bnum=0;
1843     } else {
1844     bnum=-1;
1845     }
1846     }
1847     if (dev<2) {
1848     FPRINTF(fp,"block %4d: ",bnum);
1849     } else {
1850     sprintf( line, " {%4d:", bnum );
1851     Tcl_AppendResult(interp,line,SNULL);
1852     }
1853     mtx_zero_int32(tmp,order);
1854     nz.col=mtx_FIRST;
1855     while ( value=mtx_next_in_row(mtx,&nz,mtx_ALL_COLS), nz.col!=mtx_LAST) {
1856     tmp[nz.col] = 1;
1857     }
1858     for( nz.col=0; nz.col<order; nz.col++ ) {
1859     if (dev<2) {
1860     FPRINTF(fp,tmp[nz.col]? "X ": ". ");
1861     } else {
1862     Tcl_AppendResult(interp,(tmp[nz.col]? "X": "."),SNULL);
1863     }
1864     }
1865     if (dev<2) {
1866     PUTC('\n',fp);
1867     } else {
1868     Tcl_AppendResult(interp,"}\n",SNULL);
1869     }
1870     }
1871     ascfree(tmp);
1872     ascfree(line);
1873     return (status);
1874     }
1875    
1876     int Asc_DebuFindEligible(ClientData cdata, Tcl_Interp *interp,
1877     int argc, CONST84 char *argv[])
1878     {
1879     int32 *vip=NULL;
1880     char tmps[MAXIMUM_NUMERIC_LENGTH];
1881     int i,dev,status,len;
1882     FILE *fp;
1883     struct var_variable **vp;
1884     symchar *message;
1885     symchar *eligible;
1886     symchar *none;
1887    
1888 johnpye 670 UNUSED_PARAMETER(cdata);
1889 johnpye 571
1890     if ( argc != 2 ) {
1891     FPRINTF(ASCERR, "call is: dbg_find_eligible <out>\n");
1892     Tcl_SetResult(interp, "dbg_find_eligible wants output device.",TCL_STATIC);
1893     return TCL_ERROR;
1894     }
1895     if (g_solvsys_cur==NULL) {
1896     FPRINTF(ASCERR, "dbg_find_eligible called with NULL pointer\n");
1897     Tcl_SetResult(interp, "dbg_find_eligible called without slv_system",
1898     TCL_STATIC);
1899     return TCL_ERROR;
1900     }
1901     /* get io option */
1902     i=3;
1903     status=Tcl_GetInt(interp,argv[1],&i);
1904     if (i<0 || i >2) {
1905     status=TCL_ERROR;
1906     }
1907     if (status!=TCL_OK) {
1908     FPRINTF(ASCERR,"dbg_find_eligible: first arg is 0,1, or 2\n");
1909     Tcl_ResetResult(interp);
1910     Tcl_SetResult(interp,"dbg_find_eligible: invalid output dev #",TCL_STATIC);
1911     return status;
1912     } else {
1913     dev=i;
1914     }
1915     switch (dev) {
1916     case 0: fp=stdout;
1917     break;
1918     case 1: fp=ASCERR;
1919     break;
1920     case 2: fp=NULL;
1921     break;
1922     default : /* should never be here */
1923     FPRINTF(ASCERR,"dbg_find_eligible called with strange i/o option\n");
1924     return TCL_ERROR;
1925     }
1926     eligible = AddSymbolL("eligible",8);
1927     message = AddSymbolL("message",7);
1928     none = AddSymbolL("none",4);
1929     len = slv_get_num_solvers_vars(g_solvsys_cur);
1930     vp = slv_get_solvers_var_list(g_solvsys_cur);
1931     for (i=0; i < len; i++) {
1932     Asc_BrowSetAtomAttribute(interp,(struct Instance *)var_instance(vp[i]),
1933     message,SYMBOL_INST,&none);
1934     }
1935     if (slvDOF_eligible(g_solvsys_cur,&vip)) {
1936     switch (dev) {
1937     case 0:
1938     case 1:
1939     FPRINTF(fp,"Degrees of freedom variable indices (fixable):\n");
1940     for (i=0;vip[i]>-1;i++) {
1941     FPRINTF(fp,"%d\n",vip[i]);
1942     }
1943     break;
1944     case 2:
1945     Tcl_AppendResult(interp,"{",SNULL);
1946     for (i=0;vip[i]>-1;i++) {
1947     sprintf(tmps,"%d ",vip[i]);
1948     Tcl_AppendResult(interp,tmps,SNULL);
1949     }
1950     Tcl_AppendResult(interp,"}",SNULL);
1951     break;
1952     default:
1953     FPRINTF(ASCERR,"wierdness in i/o!");
1954     break;
1955     }
1956     for (i=0;vip[i]>-1;i++) {
1957     Asc_BrowSetAtomAttribute(interp,var_instance(vp[vip[i]]),
1958     message,SYMBOL_INST,&eligible);
1959     }
1960     ascfree(vip);
1961     } else {
1962     Tcl_SetResult(interp, "{}", TCL_STATIC);
1963     }
1964     return TCL_OK;
1965     }
1966    
1967     int Asc_DebuInstEligible(ClientData cdata, Tcl_Interp *interp,
1968     int argc, CONST84 char *argv[])
1969     {
1970     int32 *vip=NULL;
1971     struct var_variable **vp;
1972     char *tmps = NULL;
1973     int i,dev,status;
1974     enum inst_t ikind;
1975     unsigned long pc;
1976     FILE *fp;
1977    
1978 johnpye 670 UNUSED_PARAMETER(cdata);
1979 johnpye 571
1980     if ( argc != 2 ) {
1981     FPRINTF(ASCERR, "call is: brow_find_eligible <out>\n");
1982     Tcl_SetResult(interp,"brow_find_eligible wants output device.",TCL_STATIC);
1983     return TCL_ERROR;
1984     }
1985     if (!g_root) {
1986     FPRINTF(ASCERR,"brow_find_eligible: called without sim in browser.\n");
1987     Tcl_SetResult(interp, "focus browser before calling brow_find_eligible",
1988     TCL_STATIC);
1989     return TCL_ERROR;
1990     }
1991     ikind=InstanceKind(g_curinst);
1992     if (ikind!=MODEL_INST) {
1993     FPRINTF(ASCERR, "Instance examined is not a solvable kind.\n");
1994     Tcl_SetResult(interp, "Instance kind not MODEL.", TCL_STATIC);
1995     return TCL_ERROR;
1996     }
1997     if ((pc=NumberPendingInstances(g_curinst))!=0) {
1998     FPRINTF(ASCERR, "Instance examined is incomplete: %ld pendings.\n",pc);
1999     Tcl_SetResult(interp, "Instance has pendings: Not solvable.", TCL_STATIC);
2000     return TCL_ERROR;
2001     }
2002     if (g_browsys_cur != NULL) {
2003     system_destroy(g_browsys_cur);
2004     g_browsys_cur = NULL;
2005     }
2006    
2007     /* get io option */
2008     i=3;
2009     status=Tcl_GetInt(interp,argv[1],&i);
2010     if (i<-1 || i >2) {
2011     status=TCL_ERROR;
2012     }
2013     if (status!=TCL_OK) {
2014     FPRINTF(ASCERR,"brow_find_eligible: first arg is -1,0,1, or 2\n");
2015     Tcl_ResetResult(interp);
2016     Tcl_SetResult(interp, "brow_find_eligible: invalid output dev #",
2017     TCL_STATIC);
2018     return status;
2019     } else {
2020     dev=i;
2021     }
2022     switch (dev) {
2023     case -1:
2024     Tcl_SetResult(interp, "{}", TCL_STATIC);
2025     return TCL_OK;
2026     case 0:
2027     fp=stdout;
2028     break;
2029     case 1:
2030     fp=ASCERR;
2031     break;
2032     case 2:
2033     fp=NULL;
2034     break;
2035     default : /* should never be here */
2036     FPRINTF(ASCERR,"brow_find_eligible called with strange i/o option\n");
2037     return TCL_ERROR;
2038     }
2039     g_browsys_cur = system_build(g_curinst);
2040     if( g_browsys_cur == NULL ) {
2041     FPRINTF(ASCERR,"system_build returned NULL.\n");
2042     Tcl_SetResult(interp, "Bad relations found: DOF system not created.",
2043     TCL_STATIC);
2044     return TCL_ERROR;
2045     }
2046    
2047     if (slvDOF_eligible(g_browsys_cur,&vip)) {
2048     vp = slv_get_solvers_var_list(g_browsys_cur);
2049     switch (dev) {
2050     case 0:
2051     case 1:
2052     FPRINTF(fp,"Degrees of freedom variables (fixable):\n");
2053     if (vip[0] < 0) {
2054     FPRINTF(fp," None.\n");
2055     }
2056     for (i=0; vip[i] > -1; i++) {
2057     FPRINTF(fp," ");
2058     var_write_name(g_browsys_cur,vp[vip[i]],fp);
2059     FPRINTF(fp,"\n");
2060     }
2061     break;
2062     case 2:
2063     Tcl_AppendResult(interp,"{",SNULL);
2064     for (i=0;vip[i]>-1;i++) {
2065     tmps = var_make_name(g_browsys_cur,vp[vip[i]]);
2066     Tcl_AppendResult(interp,"{",tmps,"}",SNULL);
2067     ascfree(tmps);
2068     tmps = NULL;
2069     if (vip[i+1] > -1) {
2070     Tcl_AppendResult(interp," ",SNULL);
2071     }
2072     }
2073     Tcl_AppendResult(interp,"}",SNULL);
2074     break;
2075     default:
2076     FPRINTF(ASCERR,"wierdness in i/o!");
2077     break;
2078     }
2079     if (vip) {
2080     ascfree(vip);
2081     }
2082     } else {
2083     Tcl_SetResult(interp, "{}", TCL_STATIC);
2084     }
2085     system_destroy(g_browsys_cur);
2086     g_browsys_cur = NULL;
2087     return TCL_OK;
2088     }
2089    
2090     /*
2091     * Get a "globally" (several alternatives in conditional model) consistent
2092     * set of variables to be fixed which, if fixed, would let all the
2093     * alternatives square and structurally consistent
2094     *
2095     */
2096     int Asc_DebuConsistencyAnalysis(ClientData cdata, Tcl_Interp *interp,
2097     int argc, CONST84 char *argv[])
2098     {
2099     int32 *vip=NULL;
2100     char tmps[MAXIMUM_NUMERIC_LENGTH];
2101     int i,dev,status,len;
2102     FILE *fp;
2103     struct var_variable **vp;
2104     symchar *message;
2105     symchar *consistent;
2106     symchar *none;
2107    
2108 johnpye 670 UNUSED_PARAMETER(cdata);
2109 johnpye 571
2110     if ( argc != 2 ) {
2111     FPRINTF(ASCERR, "call is: dbg_consistency_analysis <out>\n");
2112     Tcl_SetResult(interp, "dbg_consistency_analysis wants output device.",
2113     TCL_STATIC);
2114     return TCL_ERROR;
2115     }
2116     if (g_solvsys_cur==NULL) {
2117     FPRINTF(ASCERR, "cdbg_consistency_analysis alled with NULL pointer\n");
2118     Tcl_SetResult(interp, "dbg_consistency_analysis called without slv_system",
2119     TCL_STATIC);
2120     return TCL_ERROR;
2121     }
2122     /* get io option */
2123     i=3;
2124     status=Tcl_GetInt(interp,argv[1],&i);
2125     if (i<0 || i >2) {
2126     status=TCL_ERROR;
2127     }
2128     if (status!=TCL_OK) {
2129     FPRINTF(ASCERR,":dbg_consistency_analysis first arg is 0,1, or 2\n");
2130     Tcl_ResetResult(interp);
2131     Tcl_SetResult(interp,"dbg_consistency_analysis: invalid output dev #",
2132     TCL_STATIC);
2133     return status;
2134     } else {
2135     dev=i;
2136     }
2137     switch (dev) {
2138     case 0: fp=stdout;
2139     break;
2140     case 1: fp=ASCERR;
2141     break;
2142     case 2: fp=NULL;
2143     break;
2144     default : /* should never be here */
2145     FPRINTF(ASCERR,
2146     "dbg_consistency_analysis called with strange i/o option\n");
2147     return TCL_ERROR;
2148     }
2149     consistent = AddSymbolL("consistent",10);
2150     message = AddSymbolL("message",7);
2151     none = AddSymbolL("none",4);
2152     len = slv_get_num_master_vars(g_solvsys_cur);
2153     vp = slv_get_master_var_list(g_solvsys_cur);
2154     for (i=0; i < len; i++) {
2155     Asc_BrowSetAtomAttribute(interp,(struct Instance *)var_instance(vp[i]),
2156     message,SYMBOL_INST,&none);
2157     }
2158     if (consistency_analysis(g_solvsys_cur,&vip)) {
2159     switch (dev) {
2160     case 0:
2161     case 1:
2162     FPRINTF(fp,"Consistent set of fixable variables:\n");
2163     for (i=0;vip[i]>-1;i++) {
2164     FPRINTF(fp,"%d\n",vip[i]);
2165     }
2166     break;
2167     case 2:
2168     Tcl_AppendResult(interp,"{",SNULL);
2169     for (i=0;vip[i]>-1;i++) {
2170     sprintf(tmps,"%d ",vip[i]);
2171     Tcl_AppendResult(interp,tmps,SNULL);
2172     }
2173     Tcl_AppendResult(interp,"}",SNULL);
2174     break;
2175     default:
2176     FPRINTF(ASCERR,"wierdness in i/o!");
2177     break;
2178     }
2179     for (i=0;vip[i]>-1;i++) {
2180     Asc_BrowSetAtomAttribute(interp,var_instance(vp[vip[i]]),
2181     message,SYMBOL_INST,&consistent);
2182     }
2183     ascfree(vip);
2184     } else {
2185     Tcl_SetResult(interp, "{}", TCL_STATIC);
2186     }
2187     return TCL_OK;
2188     }
2189    
2190     /*
2191     * Get a set of eligible variables common to all the alternatives in
2192     * the problem
2193     */
2194     int Asc_DebuFindGlobalEligible(ClientData cdata, Tcl_Interp *interp,
2195     int argc, CONST84 char *argv[])
2196     {
2197     int32 *vip=NULL;
2198     char tmps[MAXIMUM_NUMERIC_LENGTH];
2199     int i,dev,status,len;
2200     FILE *fp;
2201     struct var_variable **vp;
2202     symchar *message;
2203     symchar *eligible;
2204     symchar *none;
2205    
2206 johnpye 670 UNUSED_PARAMETER(cdata);
2207 johnpye 571
2208     if ( argc != 2 ) {
2209     FPRINTF(ASCERR, "call is: dbg_global_eligible <out>\n");
2210     Tcl_SetResult(interp, "dbg_global_eligible wants output device.",
2211     TCL_STATIC);
2212     return TCL_ERROR;
2213     }
2214     if (g_solvsys_cur==NULL) {
2215     FPRINTF(ASCERR, "dbg_global_eligible called with NULL pointer\n");
2216     Tcl_SetResult(interp, "dbg_global_eligible called without slv_system",
2217     TCL_STATIC);
2218     return TCL_ERROR;
2219     }
2220     /* get io option */
2221     i=3;
2222     status=Tcl_GetInt(interp,argv[1],&i);
2223     if (i<0 || i >2) {
2224     status=TCL_ERROR;
2225     }
2226     if (status!=TCL_OK) {
2227     FPRINTF(ASCERR,":dbg_global_eligible first arg is 0,1, or 2\n");
2228     Tcl_ResetResult(interp);
2229     Tcl_SetResult(interp,"dbg_global_eligible: invalid output dev #",
2230     TCL_STATIC);
2231     return status;
2232     } else {
2233     dev=i;
2234     }
2235     switch (dev) {
2236     case 0: fp=stdout;
2237     break;
2238     case 1: fp=ASCERR;
2239     break;
2240     case 2: fp=NULL;
2241     break;
2242     default : /* should never be here */
2243     FPRINTF(ASCERR,
2244     "dbg_global_eligible called with strange i/o option\n");
2245     return TCL_ERROR;
2246     }
2247     eligible = AddSymbolL("g_eligible",10);
2248     message = AddSymbolL("message",7);
2249     none = AddSymbolL("none",4);
2250     len = slv_get_num_master_vars(g_solvsys_cur);
2251     vp = slv_get_master_var_list(g_solvsys_cur);
2252     for (i=0; i < len; i++) {
2253     Asc_BrowSetAtomAttribute(interp,(struct Instance *)var_instance(vp[i]),
2254     message,SYMBOL_INST,&none);
2255     }
2256     if (get_globally_consistent_eligible(g_solvsys_cur,&vip)) {
2257     switch (dev) {
2258     case 0:
2259     case 1:
2260     FPRINTF(fp,"Set of globally eligible variables:\n");
2261     for (i=0;vip[i]>-1;i++) {
2262     FPRINTF(fp,"%d\n",vip[i]);
2263     }
2264     break;
2265     case 2:
2266     Tcl_AppendResult(interp,"{",SNULL);
2267     for (i=0;vip[i]>-1;i++) {
2268     sprintf(tmps,"%d ",vip[i]);
2269     Tcl_AppendResult(interp,tmps,SNULL);
2270     }
2271     Tcl_AppendResult(interp,"}",SNULL);
2272     break;
2273     default:
2274     FPRINTF(ASCERR,"wierdness in i/o!");
2275     break;
2276     }
2277     for (i=0;vip[i]>-1;i++) {
2278     Asc_BrowSetAtomAttribute(interp,var_instance(vp[vip[i]]),
2279     message,SYMBOL_INST,&eligible);
2280     }
2281     ascfree(vip);
2282     } else {
2283     Tcl_SetResult(interp, "{}", TCL_STATIC);
2284     }
2285     return TCL_OK;
2286     }
2287    
2288     /*
2289     * Find Active relations in the current solver system
2290     */
2291     int Asc_DebuFindActive(ClientData cdata, Tcl_Interp *interp,
2292     int argc, CONST84 char *argv[])
2293     {
2294     FILE *fp;
2295     struct rel_relation **rp;
2296     struct rel_relation *rel;
2297     rel_filter_t rfilter;
2298     char tmps[MAXIMUM_NUMERIC_LENGTH];
2299     symchar *message;
2300     symchar *active;
2301     symchar *none;
2302     int32 *rip;
2303     int i,dev,status;
2304     int count,len,aclen;
2305    
2306 johnpye 670 UNUSED_PARAMETER(cdata);
2307 johnpye 571
2308     if ( argc != 2 ) {
2309     FPRINTF(ASCERR, "call is: dbg_find_activerels <out>\n");
2310     Tcl_SetResult(interp, "dbg_find_activerels wants output device.",
2311     TCL_STATIC);
2312     return TCL_ERROR;
2313     }
2314    
2315     if (g_solvsys_cur==NULL) {
2316     FPRINTF(ASCERR,"dbg_find_activerels called with NULL pointer\n");
2317     Tcl_SetResult(interp, "dbg_find_activerels called without slv_system",
2318     TCL_STATIC);
2319     return TCL_ERROR;
2320     }
2321    
2322     /* get io option */
2323     i=3;
2324     status=Tcl_GetInt(interp,argv[1],&i);
2325     if (i<0 || i >2) {
2326     status=TCL_ERROR;
2327     }
2328     if (status!=TCL_OK) {
2329     FPRINTF(ASCERR,"dbg_find_activerels: first arg is 0,1, or 2\n");
2330     Tcl_ResetResult(interp);
2331     Tcl_SetResult(interp,"dbg_find_activerels: invalid output dev #",
2332     TCL_STATIC);
2333     return status;
2334     } else {
2335     dev=i;
2336     }
2337     switch (dev) {
2338     case 0: fp=NULL;
2339     break;
2340     case 1: fp=ASCERR;
2341     break;
2342     case 2: fp=NULL;
2343     break;
2344     default : /* should never be here */
2345     FPRINTF(ASCERR,"dbg_find_activerels called with strange i/o option\n");
2346     return TCL_ERROR;
2347     }
2348    
2349     active = AddSymbolL("active",6);
2350     message = AddSymbolL("message",7);
2351     none = AddSymbolL("none",4);
2352    
2353     rfilter.matchbits = (REL_ACTIVE);
2354     rfilter.matchvalue = (REL_ACTIVE);
2355    
2356     rp = slv_get_solvers_rel_list(g_solvsys_cur);
2357     len = slv_get_num_solvers_rels(g_solvsys_cur);
2358     aclen = slv_count_solvers_rels(g_solvsys_cur,&rfilter);
2359 johnpye 670 rip = ASC_NEW_ARRAY(int32,aclen);
2360 johnpye 571
2361     count =0;
2362     for (i=0; i < len; i++) {
2363     rel = rp[i];
2364     if (rel_apply_filter(rel,&rfilter)) {
2365     Asc_BrowSetAtomAttribute(interp,(struct Instance *)rel_instance(rel),
2366     message,SYMBOL_INST,&active);
2367     rip[count] = i;
2368     count++;
2369     } else {
2370     Asc_BrowSetAtomAttribute(interp,(struct Instance *)rel_instance(rel),
2371     message,SYMBOL_INST,&none);
2372     }
2373     }
2374    
2375     if (aclen>0) {
2376     switch (dev) {
2377     case 0:
2378     break;
2379     case 1:
2380     FPRINTF(fp,"Active relation indices:\n");
2381     for (i=0;i<aclen;i++) {
2382     FPRINTF(fp,"%d\n",rip[i]);
2383     }
2384     break;
2385     case 2:
2386     Tcl_AppendResult(interp,"{",SNULL);
2387     for (i=0;i<aclen;i++) {
2388     sprintf(tmps,"%d ",rip[i]);
2389     Tcl_AppendResult(interp,tmps,SNULL);
2390     }
2391     Tcl_AppendResult(interp,"}",SNULL);
2392     break;
2393     default:
2394     FPRINTF(ASCERR,"wierdness in i/o!");
2395     break;
2396     }
2397     ascfree(rip);
2398     } else {
2399     Tcl_SetResult(interp, "{}", TCL_STATIC);
2400     }
2401    
2402     return TCL_OK;
2403     }
2404    
2405    
2406     /*
2407     * Find Active relations in the instance selected in the browser
2408     */
2409     int Asc_DebuInstActive(ClientData cdata, Tcl_Interp *interp,
2410     int argc, CONST84 char *argv[])
2411     {
2412     FILE *fp;
2413     struct rel_relation **rp;
2414     struct rel_relation *rel;
2415     char *tmps = NULL;
2416     rel_filter_t rfilter;
2417     enum inst_t ikind;
2418     unsigned long pc;
2419     int i,dev,status,len,count,aclen;
2420     int32 *rip;
2421    
2422 johnpye 670 UNUSED_PARAMETER(cdata);
2423 johnpye 571
2424     if ( argc != 2 ) {
2425     FPRINTF(ASCERR,"call is: brow_find_activerels <out>\n");
2426     Tcl_SetResult(interp,"brow_find_activerels wants output device.",
2427     TCL_STATIC);
2428     return TCL_ERROR;
2429     }
2430    
2431     if (!g_root) {
2432     FPRINTF(ASCERR,"brow_find_activerels: called without sim in browser.\n");
2433     Tcl_SetResult(interp, "focus browser before calling brow_find_activerels",
2434     TCL_STATIC);
2435     return TCL_ERROR;
2436     }
2437    
2438     ikind=InstanceKind(g_curinst);
2439     if (ikind!=MODEL_INST) {
2440     FPRINTF(ASCERR, "Instance examined is not a solvable kind.\n");
2441     Tcl_SetResult(interp, "Instance kind not MODEL.", TCL_STATIC);
2442     return TCL_ERROR;
2443     }
2444     if ((pc=NumberPendingInstances(g_curinst))!=0) {
2445     FPRINTF(ASCERR, "Instance examined is incomplete: %ld pendings.\n",pc);
2446     Tcl_SetResult(interp, "Instance has pendings: Not solvable.", TCL_STATIC);
2447     return TCL_ERROR;
2448     }
2449    
2450     if (g_browsys_cur != NULL) {
2451     system_destroy(g_browsys_cur);
2452     g_browsys_cur = NULL;
2453     }
2454    
2455     /* get io option */
2456     i=3;
2457     status=Tcl_GetInt(interp,argv[1],&i);
2458     if (i<-1 || i >2) {
2459     status=TCL_ERROR;
2460     }
2461     if (status!=TCL_OK) {
2462     FPRINTF(ASCERR,"brow_find_activerels: first arg is -1,0,1, or 2\n");
2463     Tcl_ResetResult(interp);
2464     Tcl_SetResult(interp, "brow_find_activerels: invalid output dev #",
2465     TCL_STATIC);
2466     return status;
2467     } else {
2468     dev=i;
2469     }
2470     switch (dev) {
2471     case -1:
2472     Tcl_SetResult(interp, "{}", TCL_STATIC);
2473     return TCL_OK;
2474     case 0:
2475     fp=stdout;
2476     break;
2477     case 1:
2478     fp=ASCERR;
2479     break;
2480     case 2:
2481     fp=NULL;
2482     break;
2483     default : /* should never be here */
2484     FPRINTF(ASCERR,"brow_find_activerels called with strange i/o option\n");
2485     return TCL_ERROR;
2486     }
2487    
2488     g_browsys_cur = system_build(g_curinst);
2489     if( g_browsys_cur == NULL ) {
2490     FPRINTF(ASCERR,"system_build returned NULL.\n");
2491     Tcl_SetResult(interp, "Bad relations found: DOF system not created.",
2492     TCL_STATIC);
2493     return TCL_ERROR;
2494     }
2495    
2496     rfilter.matchbits = (REL_ACTIVE);
2497     rfilter.matchvalue = (REL_ACTIVE);
2498    
2499     rp = slv_get_solvers_rel_list(g_browsys_cur);
2500     len = slv_get_num_solvers_rels(g_browsys_cur);
2501     aclen = slv_count_solvers_rels(g_browsys_cur,&rfilter);
2502 johnpye 670 rip = ASC_NEW_ARRAY(int32,aclen);
2503 johnpye 571
2504     count =0;
2505     for (i=0; i < len; i++) {
2506     rel = rp[i];
2507     if (rel_apply_filter(rel,&rfilter)) {
2508     rip[count] = i;
2509     count++;
2510     }
2511     }
2512    
2513     if (aclen>0) {
2514     switch (dev) {
2515     case 0:
2516     case 1:
2517     FPRINTF(fp,"Active relations :\n");
2518     if (aclen == 0) {
2519     FPRINTF(fp," None.\n");
2520     }
2521     for (i=0; i<count; i++) {
2522     FPRINTF(fp," ");
2523     rel_write_name(g_browsys_cur,rp[rip[i]],fp);
2524     FPRINTF(fp,"\n");
2525     }
2526     break;
2527     case 2:
2528     Tcl_AppendResult(interp,"{",SNULL);
2529     for (i=0;i<count;i++) {
2530     tmps = rel_make_name(g_browsys_cur,rp[rip[i]]);
2531     Tcl_AppendResult(interp,"{",tmps,"}",SNULL);
2532     ascfree(tmps);
2533     tmps = NULL;
2534     if (i < count -1) {
2535     Tcl_AppendResult(interp," ",SNULL);
2536     }
2537     }
2538     Tcl_AppendResult(interp,"}",SNULL);
2539     break;
2540     default:
2541     FPRINTF(ASCERR,"wierdness in i/o!");
2542     break;
2543     }
2544    
2545     if (rip) {
2546     ascfree(rip);