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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 411 - (show annotations) (download) (as text)
Sun Apr 2 07:05:54 2006 UTC (16 years, 1 month ago) by ben.allan
File MIME type: text/x-csrc
File size: 117682 byte(s)
Restored autotools to working, parsers to typ_ and zz_,
Fixed many missing initializations, many casting insanities
that have been creeping in, many missing forward declarations
in preparation for fixing external relations.

1 /*
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 #include <compiler/types.h>
47 #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 (void)cdata; /* stop gcc whine about unused parameter */
120
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 (void)cdata; /* stop gcc whine about unused parameter */
205
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 (void)cdata; /* stop gcc whine about unused parameter */
287
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 (void)cdata; /* stop gcc whine about unused parameter */
342
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 (void)cdata; /* stop gcc whine about unused parameter */
398 (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 (void)cdata; /* stop gcc whine about unused parameter */
459 (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 (void)cdata; /* stop gcc whine about unused parameter */
523
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 (void)cdata; /* stop gcc whine about unused parameter */
627
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 (void)cdata; /* stop gcc whine about unused parameter */
1554
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 (void)cdata; /* stop gcc whine about unused parameter */
1600
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 (void)cdata; /* stop gcc whine about unused parameter */
1646
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 (void)cdata; /* stop gcc whine about unused parameter */
1708
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 char *line = (char *)ascmalloc(32);
1763
1764 (void)cdata; /* stop gcc whine about unused parameter */
1765
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 tmp = (int32 *)ascmalloc(order*sizeof(int32));
1830 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 (void)cdata; /* stop gcc whine about unused parameter */
1889
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 (void)cdata; /* stop gcc whine about unused parameter */
1979
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 (void)cdata; /* stop gcc whine about unused parameter */
2109
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 (void)cdata; /* stop gcc whine about unused parameter */
2207
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 (void)cdata; /* stop gcc whine about unused parameter */
2307
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 rip = (int32 *)ascmalloc(aclen*sizeof(int32));
2360
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 (void)cdata; /* stop gcc whine about unused parameter */
2423
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 rip = (int32 *)ascmalloc(aclen*sizeof(int32));
2503
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);
2547 }
2548 } else {
2549 Tcl_SetResult(interp, "{}", TCL_STATIC);
2550 }
2551
2552 system_destroy(g_browsys_cur);
2553 g_browsys_cur = NULL;
2554 return TCL_OK;
2555 }
2556
2557
2558 /*
2559 * Calculates the given region of the jacobian. It is unscaled.
2560 * var/rel _in_block flags will be set based on the region.
2561 * returns calc_ok value.
2562 */
2563 static boolean dbg_calc_jacobian(mtx_matrix_t mtx,
2564 mtx_region_t reg,
2565 struct rel_relation **rlist,
2566 struct var_variable **vlist)
2567 {
2568 int32 row,col,maxrel,maxvar,c;
2569 var_filter_t vfilter;
2570 struct rel_relation *rel;
2571 struct var_variable *var;
2572 struct var_variable **vp;
2573 struct rel_relation **rp;
2574 double resid;
2575
2576 calc_ok = TRUE;
2577 vfilter.matchbits = (VAR_INBLOCK | VAR_ACTIVE);
2578 vfilter.matchvalue = (VAR_INBLOCK | VAR_ACTIVE);
2579 mtx_clear_region(mtx,&reg);
2580
2581 vp=vlist;
2582 rp=rlist;
2583 maxrel=slv_get_num_solvers_rels(g_solvsys_cur);
2584 maxvar=slv_get_num_solvers_vars(g_solvsys_cur);
2585
2586 for (c=0;c<maxvar; c++) {
2587 var_set_in_block(vp[c],FALSE);
2588 }
2589 for (c=0;c<maxrel; c++) {
2590 rel_set_in_block(rp[c],FALSE);
2591 }
2592
2593 for( col=reg.col.low; col <= reg.col.high; col++ ) {
2594 var = vlist[mtx_col_to_org(mtx,col)];
2595 var_set_in_block(var,TRUE);
2596 }
2597 for( row=reg.row.low; row <=reg.row.high; row++ ) {
2598 rel = rlist[mtx_row_to_org(mtx,row)];
2599 rel_set_in_block(rel,TRUE);
2600 }
2601
2602 for( row = reg.row.low; row <= reg.row.high; row++ ) {
2603 rel = rlist[mtx_row_to_org(mtx,row)];
2604 relman_diffs(rel,&vfilter,mtx,&resid,SAFE_FIX_ME);
2605
2606 /* added */
2607 rel_set_residual(rel,resid);
2608 }
2609 return (boolean)calc_ok;
2610 }
2611
2612
2613 #ifdef THIS_MAY_BE_UNUSED_CODE
2614 static void dbg_invert_block(linsol_system_t lsys,
2615 mtx_region_t *reg,
2616 mtx_matrix_t mtx,
2617 struct rel_relation **rp,
2618 struct var_variable **vp) {
2619 int status=1;
2620 linsol_matrix_was_changed(lsys);
2621 status=dbg_calc_jacobian(mtx,*reg,rp,vp);
2622 if (!status) {
2623 FPRINTF(ASCERR,"Error in jacobian calculation: attempting check anyway.");
2624 }
2625 calc_ok=TRUE;
2626 linsol_reorder(lsys,reg);
2627 linsol_invert(lsys,reg);
2628 }
2629 #endif
2630
2631
2632 static void dbg_factor_block(linsolqr_system_t lsys,
2633 mtx_region_t *reg,
2634 mtx_matrix_t mtx,
2635 struct rel_relation **rp,
2636 struct var_variable **vp) {
2637 int status=1, oldtiming;
2638 enum factor_method fmethod;
2639 enum reorder_method rmethod;
2640 linsolqr_matrix_was_changed(lsys);
2641 status=dbg_calc_jacobian(mtx,*reg,rp,vp);
2642 if (!status) {
2643 FPRINTF(ASCERR,"Error in jacobian calculation: attempting check anyway.");
2644 }
2645 calc_ok = TRUE;
2646 fmethod = linsolqr_fmethod(lsys);
2647 if (fmethod == 0) { /* Unknown factorization method. */
2648 FPRINTF(ASCERR,"factorization method = %s\n",
2649 linsolqr_fmethod_description(fmethod));
2650 fmethod = ranki_jz2;
2651 FPRINTF(ASCERR,"Setting factorization method = %s\n",
2652 linsolqr_fmethod_description(fmethod));
2653 }
2654 rmethod = linsolqr_rmethod(lsys);
2655 if ( strcmp(linsolqr_enum_to_rmethod(rmethod),"Unknown reordering method.")
2656 == 0) {
2657 FPRINTF(ASCERR,"Reorder method = %s\n",
2658 linsolqr_rmethod_description(rmethod));
2659 rmethod = spk1;
2660 FPRINTF(ASCERR,"Setting reorder method = %s\n",
2661 linsolqr_rmethod_description(rmethod));
2662 }
2663 linsolqr_reorder(lsys,reg,rmethod);
2664 oldtiming = g_linsolqr_timing;
2665 g_linsolqr_timing =0;
2666 linsolqr_factor(lsys,fmethod);
2667 g_linsolqr_timing =oldtiming;
2668 }
2669
2670 int Asc_DebuNumBlockSing(ClientData cdata, Tcl_Interp *interp,
2671 int argc, CONST84 char *argv[])
2672 {
2673 struct rel_relation **rp;
2674 struct var_variable **vp;
2675 dof_t *d;
2676 const mtx_block_t *b;
2677 linsolqr_system_t lsys;
2678 int32 nr,nv,u,p,numblocks,cur_block;
2679 mtx_region_t region;
2680 mtx_matrix_t mtx;
2681 slv_status_t ss;
2682 int i,dev,status,rc;
2683 mtx_sparse_t *singrows = NULL, *singcols = NULL,
2684 *rowcoefs = NULL, *colcoefs = NULL;
2685 char tmps[MAXIMUM_NUMERIC_LENGTH];
2686 FILE *fp;
2687
2688 (void)cdata; /* stop gcc whine about unused parameter */
2689
2690 if ( argc != 4 ) {
2691 FPRINTF(ASCERR,
2692 "call is: dbg_num_block_singular <out#> <block#> <row,col>\n");
2693 Tcl_SetResult(interp,
2694 "dbg_num_block_singular wants output dev & row or col.",
2695 TCL_STATIC);
2696 return TCL_ERROR;
2697 }
2698 if (g_solvsys_cur==NULL) {
2699 FPRINTF(ASCERR, "dbg_num_block_singular called with NULL pointer\n");
2700 Tcl_SetResult(interp, "dbg_num_block_singular called without slv_system",
2701 TCL_STATIC);
2702 return TCL_ERROR;
2703 }
2704 slv_get_status(g_solvsys_cur,&ss);
2705 rp=slv_get_solvers_rel_list(g_solvsys_cur);
2706 if (!rp) {
2707 FPRINTF(ASCERR, "NULL relation list found in dbg_num_block_singular\n");
2708 Tcl_SetResult(interp, "dbg_num_block_singular called with null rellist",
2709 TCL_STATIC);
2710 return TCL_ERROR;
2711 }
2712 lsys = slv_get_linsolqr_sys(g_solvsys_cur);
2713 if (!lsys) {
2714 FPRINTF(ASCERR, "NULL linsolqr sys found in dbg_num_singular\n");
2715 Tcl_SetResult(interp,
2716 "dbg_num_block_singular called with null linsolqr sys",
2717 TCL_STATIC);
2718 return TCL_ERROR;
2719 }
2720 mtx = linsolqr_get_matrix(lsys);
2721 d = slv_get_dofdata(g_solvsys_cur);
2722 b = slv_get_solvers_blocks(g_solvsys_cur);
2723 numblocks = b->nblocks;
2724
2725 if (!numblocks) {
2726 FPRINTF(ASCERR, "dbg_num_block_singular: mtx not assigned yet.\n");
2727 Tcl_SetResult(interp, "dbg_num_block_singular called before presolve.",
2728 TCL_STATIC);
2729 return TCL_ERROR;
2730 }
2731
2732 vp=slv_get_solvers_var_list(g_solvsys_cur);
2733 if (!vp) {
2734 FPRINTF(ASCERR, "NULL variable list found in dbg_num_singular\n");
2735 Tcl_SetResult(interp, "dbg_num_block_singular called with null varlist",
2736 TCL_STATIC);
2737 return TCL_ERROR;
2738 }
2739 nr=slv_get_num_solvers_rels(g_solvsys_cur);
2740 nv=slv_get_num_solvers_vars(g_solvsys_cur);
2741
2742 /* get io option */
2743 i=3;
2744 status=Tcl_GetInt(interp,argv[1],&i);
2745 if (i<0 || i >2) {
2746 status=TCL_ERROR;
2747 }
2748 if (status!=TCL_OK) {
2749 FPRINTF(ASCERR,"dbg_num_block_singular: first arg is 0,1, or 2\n");
2750 Tcl_ResetResult(interp);
2751 Tcl_SetResult(interp, "dbg_num_block_singular: invalid output dev #",
2752 TCL_STATIC);
2753 return status;
2754 } else {
2755 dev=i;
2756 }
2757 switch (dev) {
2758 case 0: fp=stdout;
2759 break;
2760 case 1: fp=ASCERR;
2761 break;
2762 case 2: fp=NULL;
2763 break;
2764 default : /* should never be here */
2765 FPRINTF(ASCERR,
2766 "dbg_num_block_singular called with strange i/o option\n");
2767 return TCL_ERROR;
2768 }
2769 /* get block number */
2770 i=-1;
2771 status=Tcl_GetInt(interp,argv[2],&i);
2772 if (i<0 || i >= numblocks) {
2773 status=TCL_ERROR;
2774 }
2775 if (status!=TCL_OK) {
2776 FPRINTF(ASCERR,"dbg_num_block_singular: second arg is a block number");
2777 Tcl_ResetResult(interp);
2778 Tcl_SetResult(interp, "dbg_num_block_singular: invalid block #",
2779 TCL_STATIC);
2780 return status;
2781 } else {
2782 cur_block=i;
2783 }
2784 region = b->block[cur_block];
2785 linsolqr_set_region(lsys,region);
2786 #ifndef NO_SIGNAL_TRAPS
2787 if (setjmp(g_fpe_env)==0) {
2788 #endif /* NO_SIGNAL_TRAPS */
2789 dbg_factor_block(lsys,&region,mtx,rp,vp);
2790 #ifndef NO_SIGNAL_TRAPS
2791 } else {
2792 FPRINTF(ASCERR, "Floating point exception in dbg_num_block_singular.\n");
2793 Tcl_SetResult(interp, " Float error in dbg_num_block_singular. ",
2794 TCL_STATIC);
2795 return TCL_ERROR;
2796 }
2797 #endif /* NO_SIGNAL_TRAPS */
2798 switch (argv[3][0]) {
2799 case 'r':
2800 rc=0;
2801 break;
2802 case 'c':
2803 rc=1; /* if want col dependency instead, rc is 1 */
2804 break;
2805 default:
2806 Tcl_SetResult(interp,
2807 "dbg_num_block_singular:second arg is \"row\" or \"col\"",
2808 TCL_STATIC);
2809 return TCL_ERROR;
2810 }
2811 if (!rc) {
2812 if (dev!=2) {
2813 FPRINTF(fp,"Checking block %d for numeric row dependency.\n",cur_block);
2814 }
2815 linsolqr_calc_row_dependencies(lsys);
2816 singrows = linsolqr_unpivoted_rows(lsys);
2817 if (singrows != NULL) {
2818 for (u = 0; u < singrows->len; u++) {
2819 if (dev==2) {
2820 sprintf(tmps,"{%d ",u);
2821 Tcl_AppendResult(interp,tmps,SNULL);
2822 } else {
2823 FPRINTF(fp,"Unpivoted row %d sum of:\n",singrows->idata[u]);
2824 }
2825 rowcoefs = linsolqr_row_dependence_coefs(lsys,singrows->idata[u]);
2826 for (p = 0; p < rowcoefs->len; p++) {
2827 if (dev==2) {
2828 sprintf(tmps,"{%d %.16g} ",rowcoefs->idata[p],rowcoefs->data[p]);
2829 Tcl_AppendResult(interp,tmps,SNULL);
2830 } else {
2831 FPRINTF(fp,"Row(%d) * %.16g\n",rowcoefs->idata[p],
2832 rowcoefs->data[p]);
2833 }
2834 }
2835 if (dev==2) {
2836 sprintf(tmps,"} ");
2837 Tcl_AppendResult(interp,tmps,SNULL);
2838 } else {
2839 FPRINTF(fp,"\n");
2840 }
2841 }
2842 }
2843 if (dev!=2) {
2844 FPRINTF(fp,"All rows checked.\n");
2845 }
2846 } else {
2847 if (dev!=2) {
2848 FPRINTF(fp,"Checking block %d for numeric column dependency.\n",cur_block);
2849 }
2850 linsolqr_calc_col_dependencies(lsys);
2851 singcols = linsolqr_unpivoted_cols(lsys);
2852 if ( singcols != NULL) {
2853 for (u = 0; u < singcols->len; u++) {
2854 if (dev==2) {
2855 sprintf(tmps,"{%d ",u);
2856 Tcl_AppendResult(interp,tmps,SNULL);
2857 } else {
2858 FPRINTF(fp,"Unpivoted column %d sum of:",singrows->idata[u]);
2859 }
2860 colcoefs = linsolqr_col_dependence_coefs(lsys,singcols->idata[u]);
2861 for (p = 0; p < colcoefs->len; p++) {
2862 if (dev==2) {
2863 sprintf(tmps,"{%d %.16g} ",colcoefs->idata[p],colcoefs->data[p]);
2864 Tcl_AppendResult(interp,tmps,SNULL);
2865 } else {
2866 FPRINTF(fp,"Column(%d) * %.16g\n",colcoefs->idata[p],
2867 colcoefs->data[p]);
2868 }
2869 }
2870 }
2871 if (dev==2) {
2872 sprintf(tmps,"} ");
2873 Tcl_AppendResult(interp,tmps,SNULL);
2874 } else {
2875 FPRINTF(fp,"\n");
2876 }
2877 }
2878 if (dev!=2) {
2879 FPRINTF(fp,"All columns checked.\n");
2880 }
2881 }
2882 mtx_destroy_sparse(singrows);
2883 mtx_destroy_sparse(singcols);
2884 mtx_destroy_sparse(rowcoefs);
2885 mtx_destroy_sparse(colcoefs);
2886 return TCL_OK;
2887 }
2888
2889
2890 int Asc_DebuStructSing(ClientData cdata, Tcl_Interp *interp,
2891 int argc, CONST84 char *argv[])
2892 {
2893 int32 *rip=NULL, *vip=NULL, *fip=NULL;
2894 struct rel_relation **rp;
2895 struct var_variable **vp;
2896 int i,dev,status;
2897 int32 relnum,maxrel;
2898 FILE *fp;
2899
2900 (void)cdata; /* stop gcc whine about unused parameter */
2901
2902 if ( argc != 3 ) {
2903 FPRINTF(ASCERR, "call is: dbg_struct_singular <out> <relindex,-1>\n");
2904 Tcl_SetResult(interp,
2905 "dbg_struct_singular wants output dev & relation index.",
2906 TCL_STATIC);
2907 return TCL_ERROR;
2908 }
2909 if (g_solvsys_cur==NULL) {
2910 FPRINTF(ASCERR, "dbg_struct_singular called with NULL pointer\n");
2911 Tcl_SetResult(interp, "dbg_struct_singular called without slv_system",
2912 TCL_STATIC);
2913 return TCL_ERROR;
2914 }
2915 rp=slv_get_solvers_rel_list(g_solvsys_cur);
2916 vp=slv_get_solvers_var_list(g_solvsys_cur);
2917 if (!rp) {
2918 FPRINTF(ASCERR, "NULL relation list found in dbg_struct_singular\n");
2919 Tcl_SetResult(interp, "dbg_struct_singular called with null rellist",
2920 TCL_STATIC);
2921 return TCL_ERROR;
2922 }
2923 if (!vp) {
2924 FPRINTF(ASCERR, "NULL variable list found in dbg_struct_singular\n");
2925 Tcl_SetResult(interp, "dbg_struct_singular called with null rellist",
2926 TCL_STATIC);
2927 return TCL_ERROR;
2928 }
2929 maxrel=slv_get_num_solvers_rels(g_solvsys_cur);
2930 relnum = maxrel;
2931 status = Tcl_GetInt(interp,argv[2],&relnum);
2932 if (relnum >= maxrel || status == TCL_ERROR) {
2933 Tcl_ResetResult(interp);
2934 Tcl_SetResult(interp,
2935 "dbg_struct_singular: equation checked does not exist",
2936 TCL_STATIC);
2937 return TCL_ERROR;
2938 }
2939 if (relnum < 0) {
2940 relnum = mtx_FIRST;
2941 }
2942 /* get io option */
2943 i=3;
2944 status=Tcl_GetInt(interp,argv[1],&i);
2945 if (i<0 || i >2) {
2946 status=TCL_ERROR;
2947 }
2948 if (status!=TCL_OK) {
2949 FPRINTF(ASCERR,"dbg_struct_singular: first arg is 0,1, or 2\n");
2950 Tcl_ResetResult(interp);
2951 Tcl_SetResult(interp, "dbg_struct_singular: invalid output dev #",
2952 TCL_STATIC);
2953 return status;
2954 } else {
2955 dev=i;
2956 }
2957 switch (dev) {
2958 case 0: fp=stdout;
2959 break;
2960 case 1: fp=ASCERR;
2961 break;
2962 case 2: fp=NULL;
2963 break;
2964 default : /* should never be here */
2965 FPRINTF(ASCERR,"dbg_struct_singular called with strange i/o option\n");
2966 return TCL_ERROR;
2967 }
2968 if (slvDOF_structsing(g_solvsys_cur,relnum,&vip,&rip,&fip)) {
2969 char tmps[MAXIMUM_NUMERIC_LENGTH];
2970 switch (dev) {
2971 case 0:
2972 case 1:
2973 FPRINTF(fp,"Relations in structural singularity:\n");
2974 if (rip[0] < 0) {
2975 FPRINTF(fp," None.\n");
2976 }
2977 for (i=0; rip[i] > -1; i++) {
2978 FPRINTF(fp," ");
2979 rel_write_name(g_solvsys_cur,rp[rip[i]],fp);
2980 FPRINTF(fp,"\n");
2981 }
2982 FPRINTF(fp,"Variables in structural singularity:\n");
2983 if (vip[0] < 0) {
2984 FPRINTF(fp," None.\n");
2985 }
2986 for (i=0; vip[i] > -1; i++) {
2987 FPRINTF(fp," ");
2988 var_write_name(g_solvsys_cur,vp[vip[i]],fp);
2989 FPRINTF(fp,"\n");
2990 }
2991
2992 FPRINTF(fp,"Variables reducing structural singularity if freed:\n");
2993 if (fip[0] < 0) {
2994 FPRINTF(fp," None.\n");
2995 }
2996 for (i=0; fip[i] > -1; i++) {
2997 FPRINTF(fp," ");
2998 var_write_name(g_solvsys_cur,vp[fip[i]],fp);
2999 FPRINTF(fp,"\n");
3000 }
3001 break;
3002 case 2:
3003 Tcl_AppendResult(interp,"{",SNULL);
3004 for (i=0;rip[i]>-1;i++) {
3005 sprintf(tmps,"%d ",rip[i]);
3006 Tcl_AppendResult(interp,tmps,SNULL);
3007 }
3008 Tcl_AppendResult(interp,"} {",SNULL);
3009 for (i=0;vip[i]>-1;i++) {
3010 sprintf(tmps,"%d ",vip[i]);
3011 Tcl_AppendResult(interp,tmps,SNULL);
3012 }
3013 Tcl_AppendResult(interp,"} {",SNULL);
3014 for (i=0;fip[i]>-1;i++) {
3015 sprintf(tmps,"%d ",fip[i]);
3016 Tcl_AppendResult(interp,tmps,SNULL);
3017 }
3018 Tcl_AppendResult(interp,"}",SNULL);
3019 break;
3020 default:
3021 FPRINTF(ASCERR,"wierdness in i/o!");
3022 break;
3023 }
3024 if (vip) {
3025 ascfree(vip);
3026 }
3027 if (rip) {
3028 ascfree(rip);
3029 }
3030 if (fip) {
3031 ascfree(fip);
3032 }
3033 } else {
3034 Tcl_SetResult(interp, "{} {} {}", TCL_STATIC);
3035 }
3036 return TCL_OK;
3037 }
3038 int Asc_DebuVarFree2Nom(ClientData cdata, Tcl_Interp *interp,
3039 int argc, CONST84 char *argv[])
3040 {
3041 struct var_variable **vp;
3042 var_filter_t vfilter;
3043 int32 c,maxvar;
3044
3045 (void)cdata; /* stop gcc whine about unused parameter */
3046 (void)argv; /* stop gcc whine about unused parameter */
3047
3048 if ( argc != 1 ) {
3049 FPRINTF(ASCERR, "call is: var_free2nom <no args>\n");
3050 Tcl_SetResult(interp, "var_free2nom takes no arguments.", TCL_STATIC);
3051 return TCL_ERROR;
3052 }
3053 if (g_solvsys_cur==NULL) {
3054 FPRINTF(ASCERR, "var_free2nom called with NULL pointer\n");
3055 Tcl_SetResult(interp, "var_free2nom called without slv_system",TCL_STATIC);
3056 return TCL_ERROR;
3057 }
3058 vfilter.matchbits = (VAR_FIXED | VAR_INCIDENT | VAR_ACTIVE);
3059 vfilter.matchvalue = (VAR_INCIDENT | VAR_ACTIVE);
3060
3061 vp=slv_get_solvers_var_list(g_solvsys_cur);
3062 maxvar=slv_get_num_solvers_vars(g_solvsys_cur);
3063
3064 for (c=0; c<maxvar; c++) { /*reset vars */
3065 if (var_apply_filter(vp[c],&vfilter)) {
3066 var_set_value(vp[c],var_nominal(vp[c]));
3067 /* FPRINTF(ASCERR,"%g\n",var_nominal(vp[c])); */
3068 }
3069 }
3070
3071 return TCL_OK;
3072 }
3073
3074 int Asc_DebuVarNom2Free(ClientData cdata, Tcl_Interp *interp,
3075 int argc, CONST84 char *argv[])
3076 {
3077 struct var_variable **vp;
3078 var_filter_t vfilter;
3079 int32 maxvar,c;
3080
3081 (void)cdata; /* stop gcc whine about unused parameter */
3082 (void)argv; /* stop gcc whine about unused parameter */
3083
3084 if ( argc != 1 ) {
3085 FPRINTF(ASCERR, "call is: var_nom2free <no args>\n");
3086 Tcl_SetResult(interp, "var_nom2free takes no arguments.", TCL_STATIC);
3087 return TCL_ERROR;
3088 }
3089 if (g_solvsys_cur==NULL) {
3090 FPRINTF(ASCERR, "var_nom2free called with NULL pointer\n");
3091 Tcl_SetResult(interp, "var_nomfree called without slv_system", TCL_STATIC);
3092 return TCL_ERROR;
3093 }
3094 vfilter.matchbits = (VAR_FIXED | VAR_INCIDENT | VAR_ACTIVE);
3095 vfilter.matchvalue = (VAR_INCIDENT | VAR_ACTIVE);
3096
3097 vp=slv_get_solvers_var_list(g_solvsys_cur);
3098 maxvar=slv_get_num_solvers_vars(g_solvsys_cur);
3099
3100 for (c=0; c<maxvar; c++) { /*reset vars */
3101 if (var_apply_filter(vp[c],&vfilter)) {
3102 var_set_nominal(vp[c],var_value(vp[c]));
3103 /* FPRINTF(ASCERR,"%g\n",var_value(vp[c])); */
3104 }
3105 }
3106
3107 return TCL_OK;
3108 }
3109
3110 /* since an fp error -> badness to automatic variables, and
3111 since hp doesn't handle this as robustly as the decs tend to,
3112 these little functions exist to isolate the chaos involved
3113 in the jmps due to float errors.
3114 */
3115 static int dbg_calc_nominal(struct rel_relation *rel) {
3116 double nom;
3117 enum Expr_enum dummy;
3118 #ifndef NO_SIGNAL_TRAPS
3119 if (setjmp(g_fpe_env)==0) {
3120 #endif /* NO_SIGNAL_TRAPS */
3121 nom = CalcRelationNominal(rel_instance(rel));
3122 if (nom >0.0) {
3123 SetRelationNominal(
3124 (struct relation *)GetInstanceRelation(rel_instance(rel),&dummy), nom);
3125 }
3126 return 0;
3127 #ifndef NO_SIGNAL_TRAPS
3128 } else {
3129 return 2;
3130 }
3131 #endif /* NO_SIGNAL_TRAPS */
3132 }
3133
3134 int Asc_DebuCheckRelFp(ClientData cdata, Tcl_Interp *interp,
3135 int argc, CONST84 char *argv[])
3136 {
3137 struct rel_relation **rp,*rel;
3138 struct var_variable **vp;
3139 int32 i,maxrel;
3140 int status;
3141 struct Instance *rinst;
3142 char tmps[MAXIMUM_NUMERIC_LENGTH+1];
3143
3144 (void)cdata; /* stop gcc whine about unused parameter */
3145 (void)argv; /* stop gcc whine about unused parameter */
3146
3147 if ( argc != 1 ) {
3148 FPRINTF(ASCERR,"call is: dbg_check_rels <no args>\n");
3149 Tcl_SetResult(interp, "dbg_check_rels wants no args", TCL_STATIC);
3150 return TCL_ERROR;
3151 }
3152 if (g_solvsys_cur==NULL) {
3153 FPRINTF(ASCERR, "dbg_check_rels called with NULL pointer\n");
3154 Tcl_SetResult(interp, "dbg_check_rels called without slv_system",
3155 TCL_STATIC);
3156 return TCL_ERROR;
3157 }
3158 vp=slv_get_solvers_var_list(g_solvsys_cur);
3159 rp=slv_get_solvers_rel_list(g_solvsys_cur);
3160 maxrel=slv_get_num_solvers_rels(g_solvsys_cur);
3161
3162 if (!vp || !rp ) {
3163 FPRINTF(ASCERR, "dbg_check_rels called with NULL rel or var list\n");
3164 Tcl_SetResult(interp, "dbg_check_rels called without rels or vars",
3165 TCL_STATIC);
3166 return TCL_ERROR;
3167 }
3168
3169 Asc_SignalHandlerPush(SIGFPE,SIG_IGN);
3170 /* convert any int to a 0/1 int */
3171 #define ISTRUE(a) ((a)!=0)
3172 for (i=0; i<maxrel; i++) {
3173 rel=rp[i];
3174 rinst =(struct Instance *)rel_instance(rel);
3175 status = RelationCalcExceptionsInfix(rinst);
3176 if (status != RCE_OK && status != RCE_BADINPUT) {
3177 sprintf(tmps,"%d %d %d %d %d",i,
3178 ISTRUE(RCE_ERR_LHS & status),
3179 ISTRUE(RCE_ERR_RHS & status),
3180 ISTRUE(RCE_ERR_LHSGRAD & status),
3181 ISTRUE(RCE_ERR_RHSGRAD & status));
3182 Tcl_AppendElement(interp, tmps);
3183 }
3184 }
3185 Asc_SignalHandlerPop(SIGFPE,SIG_IGN);
3186 #undef ISTRUE
3187 /* if external relations special case. don't know what yet.
3188 * But the compiler while whine accordingly.
3189 */
3190
3191 return TCL_OK;
3192 }
3193
3194 int Asc_DebuCalcRelNominals(ClientData cdata, Tcl_Interp *interp,
3195 int argc, CONST84 char *argv[])
3196 {
3197 struct rel_relation **rp,**rl,*rel;
3198 struct var_variable **vp,**vl;
3199 int32 maxrel,i;
3200