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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 389 - (show annotations) (download) (as text)
Thu Mar 30 06:24:10 2006 UTC (16 years, 1 month ago) by johnpye
File MIME type: text/x-csrc
File size: 62679 byte(s)
Cleaning up #includes in the Tcl/Tk interface. Doing this
all as a group so that it can be reversed out if necessary.
1 /*
2 * UnitsProc.c
3 * by Kirk Abbott and Ben Allan
4 * Created: 1/94
5 * Version: $Revision: 1.41 $
6 * Version control file: $RCSfile: UnitsProc.c,v $
7 * Date last modified: $Date: 2003/08/23 18:43:08 $
8 * Last modified by: $Author: ballan $
9 *
10 * This file is part of the ASCEND Tcl/Tk interface
11 *
12 * Copyright 1997, Carnegie Mellon University
13 *
14 * The ASCEND Tcl/Tk interface is free software; you can redistribute
15 * it and/or modify it under the terms of the GNU General Public License as
16 * published by the Free Software Foundation; either version 2 of the
17 * License, or (at your option) any later version.
18 *
19 * The ASCEND Tcl/Tk interface is distributed in hope that it will be
20 * useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
21 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
22 * General Public License for more details.
23 *
24 * You should have received a copy of the GNU General Public License
25 * along with the program; if not, write to the Free Software Foundation,
26 * Inc., 675 Mass Ave, Cambridge, MA 02139 USA. Check the file named
27 * COPYING. COPYING is found in ../compiler.
28 */
29
30 #ifndef NO_SIGNAL_TRAPS
31 #include <signal.h>
32 #include <setjmp.h>
33 #endif
34 #include <stdarg.h>
35 #include <tcl.h>
36 #include <utilities/ascConfig.h>
37 #include <utilities/ascSignal.h>
38 #include <utilities/ascMalloc.h>
39 #include <utilities/ascPanic.h>
40 #include <general/list.h>
41 #include <general/dstring.h>
42 #include <compiler/compiler.h>
43 #include <compiler/instance_enum.h>
44 #include <compiler/cmpfunc.h>
45 #include <compiler/fractions.h>
46 #include <compiler/dimen.h>
47 #include <compiler/dimen_io.h>
48 #include <compiler/units.h>
49 #include <compiler/child.h>
50 #include <compiler/type_desc.h>
51 #include <compiler/module.h>
52 #include <compiler/library.h>
53 #include <compiler/symtab.h>
54 #include <compiler/instance_io.h>
55 #include <compiler/atomvalue.h>
56 #include <compiler/instquery.h>
57 #include <compiler/types.h>
58 #include <compiler/mathinst.h>
59 #include <compiler/instance_name.h>
60 #include <compiler/relation_type.h>
61 #include <compiler/extfunc.h>
62 #include <compiler/find.h>
63 #include <compiler/relation.h>
64 #include <compiler/functype.h>
65 #include <compiler/safe.h>
66 #include <compiler/relation_util.h>
67 #include <solver/slv_types.h>
68 #include <solver/var.h>
69 #include <solver/rel.h>
70 #include <solver/discrete.h>
71 #include <solver/conditional.h>
72 #include <solver/logrel.h>
73 #include <solver/bnd.h>
74 #include <solver/mtx.h>
75 #include <solver/slv_common.h>
76 #include <solver/linsol.h>
77 #include <solver/linsolqr.h>
78 #include <solver/slv_client.h>
79 #include "old_utils.h"
80 #include "HelpProc.h"
81 #include "UnitsProc.h"
82 #include "BrowserQuery.h"
83 #include "BrowserProc.h"
84 #include "Qlfdid.h"
85 #include "Driver.h"
86 #include "HelpProc.h"
87 #include "SolverGlobals.h"
88
89 #ifndef lint
90 static CONST char UnitsProcID[] = "$Id: UnitsProc.c,v 1.41 2003/08/23 18:43:08 ballan Exp $";
91 #endif
92
93
94 /* convenience macros */
95 #define SNULL (char *)NULL
96 #define UnitsFindType(s) FindType(AddSymbol(s))
97
98 /* return info when units convert badly. because io may happen within
99 * another trap context, we have our own return address and return function.
100 */
101 static jmp_buf g_unit_env;
102
103 struct Units * g_base_units[NUM_DIMENS];
104 struct Units * g_SI_units[NUM_DIMENS];
105
106 /*********************INTERNALS ******************************/
107
108 static int display_precision = 6;
109 static char *unit_display_string = NULL;
110 static int updatefundunitdim;
111 static Tcl_Interp *unitsinterp;
112 #define UDS (unit_display_string)
113 #define UPREC (display_precision)
114
115 #define DLSIZE (512L)
116 /* while there are infinitely many instances and units combos, there are
117 only a limited (in practice) number of dimensionalities. DLSIZE should
118 be a reasonable upper bound on that limited number.
119 */
120 static struct gl_list_t *DUList; /* association list for display units */
121
122 struct DisplayUnit {
123 dim_type *d; /* dimensionality applied to */
124 struct Units *u; /* user set display units */
125 struct Units *fu; /* fundamental display units */
126 };
127
128
129 static int check_units_set(ClientData cdata, Tcl_Interp *interp,
130 int argc, CONST84 char *argv[]) /* args ignored but needed*/
131 {
132 static int base_units_set;
133 if (!base_units_set) {
134 Asc_UnitDefaultBaseUnits(cdata,interp,argc,argv);
135 base_units_set = 1;
136 }
137 return (base_units_set);
138 }
139
140 static
141 int Unit_CmpDU(CONST struct DisplayUnit *du1, CONST struct DisplayUnit *du2)
142 {
143 return CmpDimen(du1->d,du2->d);
144 }
145
146 static int destroy_DUList() {
147 if (DUList) {
148 gl_free_and_destroy(DUList);
149 }
150 return 0;
151 }
152
153 static int check_DU_set()
154 {
155 static int duset = 0 ;
156 if (!duset) { /* first time through, init the world */
157 dim_type *d;
158 register unsigned long c,len = gl_length(g_dimen_list);
159 struct DisplayUnit *newDU;
160 DUList = gl_create(DLSIZE);
161 assert(DUList!=NULL);
162 for(c = 1;c <= len;c++) { /*far faster than FindOrAddDU */
163 newDU=(struct DisplayUnit *)ascmalloc(sizeof(struct DisplayUnit));
164 d = (dim_type *)gl_fetch(g_dimen_list,c);
165 newDU->d = d;
166 newDU->u = (struct Units *)NULL;
167 newDU->fu = (struct Units *)NULL;
168 gl_insert_sorted(DUList,(VOIDPTR)newDU,(CmpFunc)Unit_CmpDU);
169 }
170 duset = 1;
171 }
172 return (duset);
173 }
174
175 /* push fundy's to bottom of list */
176 static
177 int Unit_CmpAtomName(CONST struct TypeDescription *d1,
178 CONST struct TypeDescription *d2)
179 {
180 if (!d1 || !d2 || CheckFundamental(GetName(d1)) ) {
181 return 1;
182 }
183 return CmpSymchar(GetName(d1),GetName(d2));
184 }
185
186 /* small numbers and nulls go to the bottom (high index) of the list */
187 static
188 int Unit_CmpConv(CONST struct Units *u1, CONST struct Units *u2)
189 {
190 if (!u1 || !u2 || UnitsConvFactor(u1)<UnitsConvFactor(u2)) {
191 return 1;
192 }
193 if (UnitsConvFactor(u1)==UnitsConvFactor(u2)) {
194 if (SCLEN(UnitsDescription(u1)) > SCLEN(UnitsDescription(u2))) {
195 return 1;
196 } else if (SCLEN(UnitsDescription(u1)) < SCLEN(UnitsDescription(u2))) {
197 return -1;
198 } else {
199 return (CmpSymchar(UnitsDescription(u1),UnitsDescription(u2)));
200 }
201 } else {
202 return -1;
203 }
204 }
205
206 /*
207 * note that since fractional and irrational exponents are not allowed
208 * on dimensioned quantities, we don't have to worry on denominator.
209 */
210 static
211 void Unit_WriteNumer(Tcl_DString *str, struct fraction frac,
212 CONST char *baseunit, int *CONST p)
213 {
214 char sval[MAXIMUM_NUMERIC_LENGTH];
215 if (Numerator(frac)>0) {
216 (*p) = 1;
217 if (Denominator(frac)==1) {
218 if (Numerator(frac)==1) {
219 sprintf(sval,"%s*",baseunit);
220 } else {
221 sprintf(sval,"%s^%d*",baseunit,Numerator(frac));
222 }
223 } else {
224 /* this won't parse, but shouldn't happen anyway */
225 sprintf(sval,"%s^(%d/%d)*",baseunit,Numerator(frac),Denominator(frac));
226 }
227 Tcl_DStringAppend(str,sval,-1);
228 }
229 }
230
231 static
232 void Unit_WriteDenom(Tcl_DString *str, struct fraction frac,
233 CONST char *baseunit, int *CONST p)
234 {
235 char sval[MAXIMUM_NUMERIC_LENGTH];
236 if (Numerator(frac)<0) {
237 (*p) = 1;
238 if (Denominator(frac)==1) {
239 if (Numerator(frac)==-1) {
240 sprintf(sval,"/%s",baseunit);
241 } else {
242 sprintf(sval,"/%s^%d",baseunit,-Numerator(frac));
243 }
244 } else {
245 /* this won't parse, but shouldn't happen anyway */
246 sprintf(sval,"/%s^(%d/%d)",baseunit,-Numerator(frac),Denominator(frac));
247 }
248 Tcl_DStringAppend(str,sval,-1);
249 }
250 }
251
252 /* return a nicely formatted units string */
253 static
254 char *Unit_MakeString(dim_type *dimp, struct Units * units[NUM_DIMENS])
255 {
256 struct fraction frac;
257 Tcl_DString str1, str2;
258 char *result;
259 int printed = 0,len;
260 Tcl_DStringInit(&str1);
261 Tcl_DStringInit(&str2);
262 if (IsWild(dimp)) {
263 Tcl_DStringAppend(&str2,"*",-1);
264 } else {
265 int i;
266 for( i = 0; i<NUM_DIMENS; i++ ) {
267 frac = GetDimFraction(*dimp,i);
268 Unit_WriteNumer(&str1,frac,SCP(UnitsDescription(units[i])),&printed);
269 }
270 if (!printed) {
271 Tcl_DStringAppend(&str2,"1",-1);
272 printed = 1;
273 } else {
274 /* eat the trailing multiply */
275 Tcl_DStringAppend(&str2,
276 Tcl_DStringValue(&str1),
277 (strlen(Tcl_DStringValue(&str1))-1) );
278 }
279 for( i = 0; i<NUM_DIMENS; i++ ) {
280 frac = GetDimFraction(*dimp,i);
281 Unit_WriteDenom(&str2,frac,SCP(UnitsDescription(units[i])),&printed);
282 }
283 }
284 len = strlen(Tcl_DStringValue(&str2));
285 result = Asc_MakeInitString(len);
286 strcpy(result, Tcl_DStringValue(&str2));
287 Tcl_DStringFree(&str1);
288 Tcl_DStringFree(&str2);
289 return result;
290 }
291
292 #ifdef THIS_IS_AN_UNUSED_FUNCTION
293 static
294 void Unit_PrintDU(struct DisplayUnit *du)
295 {
296 if (du==NULL) {
297 FPRINTF(stderr,"NULL");
298 } else {
299 FPRINTF(stderr,"0x%p 0x%p \n",du->d, du->u);
300 }
301 }
302 #endif /* THIS_IS_AN_UNUSED_FUNCTION */
303
304 /*
305 * return the DisplayUnit pointer that matches dimp.
306 * create it if necessary. failing create, crash.
307 */
308 static struct DisplayUnit *Unit_FindOrAddDU(dim_type *dimp)
309 {
310 unsigned long ndx;
311 struct DisplayUnit dimpDU;
312 struct DisplayUnit *newdu;
313
314 dimpDU.d = dimp;
315 check_DU_set();
316 ndx = gl_search(DUList,(VOIDPTR)&dimpDU,(CmpFunc)Unit_CmpDU);
317 if (ndx==0L) {
318 newdu = (struct DisplayUnit *)ascmalloc(sizeof(struct DisplayUnit));
319 newdu->d = dimp;
320 newdu->u = NULL;
321 newdu->fu = NULL;
322 gl_insert_sorted(DUList,(VOIDPTR)newdu,(CmpFunc)Unit_CmpDU);
323 return newdu;
324 }
325 return ((struct DisplayUnit *)gl_fetch(DUList,ndx));
326 }
327
328 /*
329 * returns display unit matching dimp, creating it in association list if
330 * not existing. Will not actually create a Units struct. a NULL return
331 * means the unit has been defaulted in the units window.
332 */
333 static struct Units *Unit_DisplayUnits(dim_type *dimp)
334 {
335 struct DisplayUnit *dimpdu;
336 assert(check_DU_set());
337 dimpdu = Unit_FindOrAddDU(dimp);
338 return (dimpdu->u);
339 }
340
341 /*
342 * called when display unit is defaulted. constructs a display string
343 * if needed using user set base units and adds to the Units hash table.
344 * returns the pointer of the fund units.
345 */
346 static struct Units *Unit_DisplayFund(dim_type *dimp)
347 {
348 struct DisplayUnit* dimpDU;
349 char *newunits = NULL;
350 unsigned long pos;
351 int ecode;
352
353 assert(check_DU_set());
354 dimpDU = Unit_FindOrAddDU(dimp);
355 if (dimpDU->fu==NULL) {
356 newunits = Unit_MakeString(dimp,g_base_units);
357 dimpDU->fu = (struct Units *)FindOrDefineUnits(newunits,&pos,&ecode);
358 if (!dimpDU->fu) {
359 FPRINTF(stderr,"Error %d, position %ld\n",ecode,pos);
360 FPRINTF(stderr,"failed fundstring: {%s} \n",newunits);
361 }
362 if (newunits) {
363 ascfree(newunits);
364 }
365 }
366 return (dimpDU->fu);
367 }
368
369 /*
370 * called when display unit is too small. constructs a display string
371 * using SI base units and adds to the Units hash table if needed.
372 * returns the pointer of the units. This should seldom be called, so
373 * we are constructing the string every time rather than expanding
374 * the DisplayUnit struct.
375 */
376 static struct Units *Unit_DisplaySI(dim_type *dimp)
377 {
378 static unsigned long pos;
379 static int ecode;
380 struct Units *u;
381 char *newunits = Unit_MakeString(dimp,g_SI_units);
382 u = (struct Units *)FindOrDefineUnits(newunits,&pos,&ecode);
383 if (!u) {
384 FPRINTF(stderr,"error %d, position %ld\n",ecode,pos);
385 FPRINTF(stderr,"SIstring: {%s} \n",newunits);
386 }
387 if (newunits) {
388 ascfree(newunits);
389 }
390 return u;
391 }
392
393 /*
394 * this function checks to see if the fundamental unit being updated
395 * needs to be changed in already set displayunits.
396 */
397 static
398 void Unit_UpdateFundUnits(struct DisplayUnit *du)
399 {
400 dim_type *d;
401
402 if (du==NULL || du->fu==NULL) {
403 return;
404 }
405 d = (dim_type *)UnitsDimensions(du->fu);
406 if (Numerator(GetDimFraction(*(dim_type *)UnitsDimensions(du->fu),
407 updatefundunitdim)) != 0) {
408 du->fu = NULL;
409 Unit_DisplayFund(du->d);
410 }
411 }
412
413 #ifndef NO_SIGNAL_TRAPS
414 /* un/conversion error handling done in the next 5 procedures */
415 static
416 void uunconversion_trap(int sigval)
417 {
418 (void)sigval; /* stop gcc whine about unused parameter */
419
420 FPRINTF(stderr,"Float error in converting display value to SI value.\n");
421 FPRESET;
422 longjmp(g_unit_env,SIGFPE);
423 }
424 #endif /* NO_SIGNAL_TRAPS */
425
426 /* respects any already active Asc_SignalTrap as we may want unit
427 * output during another call which needs trapping.
428 * retval is the SI value converted from the units specified by u
429 * returns 1 if unhappy, 0 otherwise.
430 */
431 static int Unit_UnconvertReal(double val, struct Units *u, double *retval)
432 {
433 static int status;
434 if (!u) {
435 return 1;
436 }
437 #ifndef NO_SIGNAL_TRAPS
438 Asc_SignalHandlerPush(SIGFPE,uunconversion_trap);
439 if (setjmp(g_unit_env)==0) {
440 #endif /* NO_SIGNAL_TRAPS */
441 status = 0;
442 *retval = val*UnitsConvFactor(u);
443 #ifndef NO_SIGNAL_TRAPS
444 } else {
445 status = 1;
446 }
447 Asc_SignalHandlerPop(SIGFPE,uunconversion_trap);
448 #endif /* NO_SIGNAL_TRAPS */
449 return status;
450 }
451
452 static
453 void uconversion_trap(int sigval)
454 {
455 (void)sigval; /* stop gcc whine about unused parameter */
456
457 FPRINTF(stderr,"Float error in converting SI value to display units.\n");
458 FPRESET;
459 longjmp(g_unit_env,SIGFPE);
460 }
461
462 /* respects any already active fp_trap
463 * retval is the display value in the units specified by u
464 */
465 static int Unit_ConvertReal(double val, struct Units *u, double *retval)
466 {
467 static int status;
468 if (!u) {
469 return 1;
470 }
471 #ifndef NO_SIGNAL_TRAPS
472 Asc_SignalHandlerPush(SIGFPE,uconversion_trap);
473 if (setjmp(g_unit_env)==0) {
474 #endif /* NO_SIGNAL_TRAPS */
475 status = 0;
476 /* often enough debug
477 FPRINTF(stderr,"Conversion: v%.16g f%.16g\n",val,UnitsConvFactor(u));
478 */
479 *retval = val/UnitsConvFactor(u);
480 #ifndef NO_SIGNAL_TRAPS
481 } else {
482 status = 1;
483 }
484 Asc_SignalHandlerPop(SIGFPE,uconversion_trap);
485 #endif /* NO_SIGNAL_TRAPS */
486 return status;
487 }
488
489 /* does integer math yield errors?? */
490 static int Unit_ConvertInteger(long val, struct Units *u, long *retval)
491 {
492 (void)u; /* stop gcc whine about unused parameter */
493
494 *retval = val;
495 return 0;
496 }
497 /* end any pretense of conversion error handling */
498
499 static int Unit_PrintUndefined(dim_type *dimp)
500 {
501 char str[MAXIMUM_NUMERIC_LENGTH];
502 int len;
503 struct Units *du;
504 if (IsWild(dimp)) {
505 sprintf(str,"UNDEFINED *");
506 len = 11; /* should match prior sprintf */
507 UDS = Asc_MakeInitString(len);
508 strcat(UDS,str);
509 return 0;
510 }
511 if (CmpDimen(dimp,Dimensionless())==0) {
512 sprintf(str,"UNDEFINED ");
513 len = 10;
514 UDS = Asc_MakeInitString(len);
515 strcat(UDS,str);
516 return 0;
517 }
518 du = Unit_DisplayUnits(dimp); /* get units window set */
519 if (du==NULL) { /* if defaulted, use base units */
520 du = Unit_DisplayFund(dimp);
521 }
522 assert(du!=NULL);
523 sprintf(str,"UNDEFINED ");
524 len = strlen(str)+SCLEN(UnitsDescription(du));
525 UDS = Asc_MakeInitString(len);
526 strcat(UDS,str);
527 strcat(UDS,SCP(UnitsDescription(du)));
528 return 0;
529 }
530
531 static int Unitless_PrintUndefined(void)
532 {
533 UDS = Asc_MakeInitString(9);
534 strcat(UDS,"UNDEFINED");
535 return 0;
536 }
537
538 /*
539 * Assumes UDS is NULL on entry. That's why it's static.
540 * Unit_PrintXXXXX are responsible for mallocing UDS, and
541 * Asc_UnitValue is responsible for destroying it.
542 */
543 static int Unit_PrintReal(double val, dim_type *dimp)
544 {
545 char str[MAXIMUM_NUMERIC_LENGTH];
546 int len;
547 double dval; /* the printed value */
548 struct Units *du;
549 if (IsWild(dimp)) {
550 sprintf(str,"%.*g *",UPREC,val);
551 len = strlen(str);
552 UDS = Asc_MakeInitString(len);
553 strcat(UDS,str);
554 return 0;
555 }
556 if (CmpDimen(dimp,Dimensionless())==0) {
557 sprintf(str,"%.*g",UPREC,val);
558 len = strlen(str);
559 UDS = Asc_MakeInitString(len);
560 strcat(UDS,str);
561 return 0;
562 }
563 du = Unit_DisplayUnits(dimp); /* get units window set */
564 if (du==NULL) { /* if defaulted, use base units */
565 du = Unit_DisplayFund(dimp);
566 if (Unit_ConvertReal(val,du,&dval)) { /* if conversion error, use SI */
567 du = Unit_DisplaySI(dimp);
568 dval = val;
569 }
570 } else {
571 if (Unit_ConvertReal(val,du,&dval)) { /* if units window set failed */
572 du = Unit_DisplayFund(dimp); /* get base units */
573 if (Unit_ConvertReal(val,du,&dval)) {/* if conversion error, use SI */
574 du = Unit_DisplaySI(dimp);
575 dval = val;
576 }
577 }
578 }
579 assert(du!=NULL);
580 sprintf(str,"%.*g ",UPREC,dval);
581 len = strlen(str)+SCLEN(UnitsDescription(du));
582 UDS = Asc_MakeInitString(len);
583 strcat(UDS,str);
584 strcat(UDS,SCP(UnitsDescription(du)));
585 return 0;
586 }
587
588 /*
589 * Assumes UDS is NULL on entry. That's why it's static.
590 * Call only from Asc_UnitValue.
591 */
592 static int Unitless_PrintReal(double val, dim_type *dimp, int si)
593 {
594 char str[MAXIMUM_NUMERIC_LENGTH];
595 int len;
596 double dval; /* the printed value */
597 struct Units *du;
598 if (IsWild(dimp) || CmpDimen(dimp,Dimensionless())==0) {
599 sprintf(str,"%.*g",UPREC,val);
600 len = strlen(str);
601 UDS = Asc_MakeInitString(len);
602 strcat(UDS,str);
603 return 0;
604 }
605 du = Unit_DisplayUnits(dimp); /* get units window set */
606 if (du==NULL) { /* if defaulted, use base units */
607 du = Unit_DisplayFund(dimp);
608 if (si || Unit_ConvertReal(val,du,&dval)) {
609 /* if conversion error or si, use SI */
610 dval = val;
611 }
612 } else {
613 if (si || Unit_ConvertReal(val,du,&dval)) {
614 /* if si or units window set conversion failed */
615 du = Unit_DisplayFund(dimp); /* get base units */
616 if (si || Unit_ConvertReal(val,du,&dval)) {
617 /* if conversion error or si, use SI */
618 dval = val;
619 }
620 }
621 }
622 sprintf(str,"%.*g",UPREC,dval);
623 len = strlen(str);
624 UDS = Asc_MakeInitString(len);
625 strcat(UDS,str);
626 return 0;
627 }
628
629 /*
630 * Assumes UDS is NULL on entry. That's why it's static.
631 * Call only from Asc_UnitValue.
632 */
633 static int Unit_PrintInteger(long val, dim_type *dimp)
634 {
635 char str[81];
636 int len;
637 long dval; /* the printed value */
638 struct Units *du;
639 if (CmpDimen(dimp,Dimensionless())==0) {
640 sprintf(str,"%ld",val);
641 len = strlen(str);
642 UDS = Asc_MakeInitString(len);
643 strcat(UDS,str);
644 return 0;
645 }
646 if (IsWild(dimp)) {
647 sprintf(str,"%ld *",val);
648 len = strlen(str);
649 UDS = Asc_MakeInitString(len);
650 strcat(UDS,str);
651 return 0;
652 }
653 du = Unit_DisplayUnits(dimp); /* get units window set */
654 if (du==NULL) { /* if defaulted, use base units */
655 du = Unit_DisplayFund(dimp);
656 if (Unit_ConvertInteger(val,du,&dval)) { /* if conversion error, use SI */
657 du = Unit_DisplaySI(dimp);
658 dval = val;
659 }
660 } else {
661 if (Unit_ConvertInteger(val,du,&dval)) { /* if units window set failed */
662 du = Unit_DisplayFund(dimp); /* get base units */
663 if (Unit_ConvertInteger(val,du,&dval)) {/* if conversion error, use SI */
664 du = Unit_DisplaySI(dimp);
665 dval = val;
666 }
667 }
668 }
669 sprintf(str,"%ld ",dval);
670 len = strlen(str)+SCLEN(UnitsDescription(du));
671 UDS = Asc_MakeInitString(len);
672 strcat(UDS,str);
673 strcat(UDS,SCP(UnitsDescription(du)));
674 return 0;
675 }
676
677 /*
678 * This code at the moment is only valid for token relations.
679 */
680 static
681 dim_type *Unit_FindRelDim(CONST struct Instance *i)
682 {
683 int consistent;
684 dim_type dim;
685 dim_type *newd;
686 CONST struct relation *reln;
687 enum Expr_enum reltype;
688
689 reln = GetInstanceRelation(i,&reltype);
690 switch (reltype) {
691 case e_blackbox:
692 case e_glassbox:
693 case e_opcode:
694 if (g_check_dimensions_noisy) {
695 FPRINTF(stderr,
696 "Dimensionality checking not supported for these relns\n");
697 }
698 return (dim_type *)WildDimension();
699 case e_token:
700 break;
701 default:
702 Asc_Panic(2, "Unit_FindRelDimen",
703 "Type is not a relation type in Unit_FindRelDimen\n");
704 }
705
706 consistent = asc_check_dimensions(reln,&dim);
707 if( !consistent ) {
708 if (g_check_dimensions_noisy) {
709 FPRINTF(stderr,"An inconsistency was found in ");
710 WriteInstanceName(stderr,i,NULL); PRINTF("\n");
711 }
712 return (dim_type *)WildDimension();
713 } else {
714 newd = (dim_type *)FindOrAddDimen(&dim);
715 if (consistent ==1) {
716 SetRelationDim((struct relation *)reln,newd);
717 }
718 return newd;
719 }
720 }
721
722 /*
723 * returns TRUE if the instance is NULL or is dimensionally
724 * sane. integers are sane (DIMENSIONLESS).
725 */
726 static int IsDimInstance(CONST struct Instance *i)
727 {
728 enum inst_t t;
729 if (!i) {
730 return 1;
731 }
732 t = InstanceKind(i);
733 return (t== REAL_ATOM_INST || /* non-fundamental real atom */
734 t==REAL_INST || /* a fundamental real instance */
735 t==REAL_CONSTANT_INST || /* a non fundamental real
736 * constant instance */
737 t==INTEGER_ATOM_INST || /* non-fundamental integer atom */
738 t==INTEGER_INST || /* a fundamental integer instance */
739 t==INTEGER_CONSTANT_INST || /* a non fundamental integer
740 * constant instance */
741 t==REL_INST /* relation(equality or inequality) */
742 );
743 }
744
745 /*
746 * Don't call it on a non-dimensional instance or you will get what
747 * you deserve: a null pointer back.
748 * For my purposes dimensional instances are INT, REAL, REL and their
749 * ATOM versions.
750 * Happens to not mind integers,since I think integers will have dims
751 * eventually, and because it make the browser easy to deal with.
752 * This is the broker for access to the Unit_PrintXXXXX routines and
753 * is responsible for destroying the UDS.
754 */
755 char *Asc_UnitValue(CONST struct Instance *i)
756 {
757 double dval;
758 dim_type *dimp = NULL;
759 long ival;
760 CONST struct relation *reln;
761 enum Expr_enum reltype;
762
763 if (UDS) {
764 ascfree(UDS);
765 UDS = SNULL;
766 }
767 if (!i) {
768 return SNULL;
769 }
770 switch (InstanceKind(i)) {
771 case REAL_ATOM_INST:
772 case REAL_CONSTANT_INST:
773 case REAL_INST:
774 dimp = (dim_type *)RealAtomDims(i);
775 if (!AtomAssigned(i)) {
776 Unit_PrintUndefined(dimp);
777 } else {
778 dval = RealAtomValue(i);
779 Unit_PrintReal(dval,dimp);
780 }
781 break;
782 case REL_INST:
783 reln = GetInstanceRelation(i,&reltype);
784 if (reln!=NULL) {
785 dval = RelationResidual((struct relation *)reln);
786 dimp = Unit_FindRelDim(i);
787 } else {
788 dval = 0.0;
789 dimp = (dim_type *)WildDimension();
790 }
791 Unit_PrintReal(dval,dimp);
792 break;
793 case INTEGER_INST:
794 case INTEGER_CONSTANT_INST:
795 case INTEGER_ATOM_INST:
796 /* dimp = IntegerAtomDims(i); Doesnotexist. integer inst don't have dim.*/
797 if (!AtomAssigned(i)) {
798 Unit_PrintUndefined((dim_type *)Dimensionless());
799 } else {
800 ival = GetIntegerAtomValue(i);
801 Unit_PrintInteger(ival,(dim_type *)Dimensionless());
802 }
803 break;
804 default:
805 break;
806 }
807 return UDS;
808 }
809
810 /* follows exactly the same UDS management protocol as Asc_UnitValue. see
811 comments above */
812 char *Asc_UnitlessValue(CONST struct Instance *i, int si)
813 {
814 double dval;
815 dim_type *dimp = NULL;
816 long ival;
817 enum Expr_enum reltype;
818 if (UDS) {
819 ascfree(UDS);
820 UDS = SNULL;
821 }
822 if (!i) {
823 return SNULL;
824 }
825 switch (InstanceKind(i)) {
826 case REAL_ATOM_INST:
827 case REAL_CONSTANT_INST:
828 case REAL_INST:
829 dimp = (dim_type *)RealAtomDims(i);
830 if (!AtomAssigned(i)) {
831 Unitless_PrintUndefined();
832 } else {
833 dval = RealAtomValue(i);
834 Unitless_PrintReal(dval,dimp,si);
835 }
836 break;
837 case REL_INST:
838 if (GetInstanceRelation(i,&reltype)!=NULL) {
839 dval = RelationResidual(GetInstanceRelation(i,&reltype));
840 dimp = Unit_FindRelDim(i);
841 } else {
842 dval = 0.0;
843 dimp = (dim_type *)WildDimension();
844 }
845 Unitless_PrintReal(dval,dimp,si);
846 break;
847 case INTEGER_INST:
848 case INTEGER_CONSTANT_INST:
849 case INTEGER_ATOM_INST:
850 /* dimp = IntegerAtomDims(i); Doesnotexist. integer inst don't have dim.*/
851 if (!AtomAssigned(i)) {
852 Unit_PrintUndefined((dim_type *)Dimensionless());
853 } else {
854 ival = GetIntegerAtomValue(i);
855 Unit_PrintInteger(ival,(dim_type *)Dimensionless());
856 }
857 break;
858 default:
859 break;
860 }
861 return UDS;
862 }
863 /* follows UDS string convention as for Asc_UnitValue. */
864 char *Asc_UnitString(CONST struct Instance *i, int si)
865 {
866 dim_type *dimp = NULL;
867 struct Units *du;
868 size_t len;
869 enum Expr_enum reltype;
870 if (UDS) {
871 ascfree(UDS);
872 UDS = SNULL;
873 }
874 if (!i) {
875 return SNULL;
876 }
877 switch (InstanceKind(i)) {
878 case REAL_ATOM_INST:
879 case REAL_CONSTANT_INST:
880 case REAL_INST:
881 dimp = (dim_type *)RealAtomDims(i);
882 break;
883 case REL_INST:
884 if (GetInstanceRelation(i,&reltype)!=NULL) {
885 dimp = Unit_FindRelDim(i);
886 } else {
887 dimp = (dim_type *)WildDimension();
888 }
889 break;
890 case INTEGER_INST:
891 case INTEGER_CONSTANT_INST:
892 case INTEGER_ATOM_INST:
893 dimp = (dim_type *)Dimensionless();
894 break;
895 default:
896 break;
897 }
898 if (dimp == NULL) {
899 FPRINTF(stderr,
900 "WARNING: (Asc_UnitString) Called on undimensional instance\n");
901 return UDS;
902 }
903 if (IsWild(dimp)) {
904 UDS = Asc_MakeInitString(1);
905 strcat(UDS,"*");
906 return UDS;
907 }
908 if (CmpDimen(dimp,Dimensionless())==0) {
909 UDS = Asc_MakeInitString(1);
910 sprintf(UDS,"%s","");
911 return UDS;
912 }
913 if (si) {
914 du = Unit_DisplaySI(dimp);
915 } else {
916 du = Unit_DisplayUnits(dimp); /* get units window set */
917 if (du==NULL) { /* if defaulted, use base units */
918 du = Unit_DisplayFund(dimp);
919 }
920 }
921 len = SCLEN(UnitsDescription(du));
922 UDS = Asc_MakeInitString(len);
923 strcat(UDS,SCP(UnitsDescription(du)));
924 return UDS;
925 }
926
927 /* follows UDS string convention as for Asc_UnitValue. */
928 char *Asc_UnitDimString(dim_type *dimp, int si)
929 {
930 struct Units *du;
931 size_t len;
932 if (UDS) {
933 ascfree(UDS);
934 UDS = SNULL;
935 }
936 if (dimp==NULL) {
937 return SNULL;
938 }
939 if (IsWild(dimp)) {
940 UDS = Asc_MakeInitString(1);
941 strcat(UDS,"*");
942 return UDS;
943 }
944 if (CmpDimen(dimp,Dimensionless())==0) {
945 UDS = Asc_MakeInitString(1);
946 sprintf(UDS,"%s","");
947 return UDS;
948 }
949 if (si) {
950 du = Unit_DisplaySI(dimp);
951 } else {
952 du = Unit_DisplayUnits(dimp); /* get units window set */
953 if (du==NULL) { /* if defaulted, use base units */
954 du = Unit_DisplayFund(dimp);
955 }
956 }
957 len = SCLEN(UnitsDescription(du));
958 UDS = Asc_MakeInitString(len);
959 strcat(UDS,SCP(UnitsDescription(du)));
960 return UDS;
961 }
962
963 /* Convert to/from si. if si is TRUE, assumes in is si value and
964 tries to convert value consistent with units given. If si is FALSE
965 assumes in is value in units given and tries to convert to si.
966 */
967 int Asc_UnitConvert(struct Units *u, double in, double *op, int si)
968 {
969
970 if (u==NULL || op == NULL) {
971 return 1;
972 }
973 if (si) {
974 if (Unit_ConvertReal(in,u,op)) {
975 return 1;
976 } else {
977 return 0;
978 }
979 } else {
980 if (Unit_UnconvertReal(in,u,op)) {
981 return 1;
982 } else {
983 return 0;
984 }
985 }
986 }
987 int Asc_UnitSetRealAtomValue(CONST struct Instance *i,
988 char *vstr, char *ustr, unsigned depth)
989 {
990 double dval = 0;
991 char *ends = SNULL;
992
993 /* check instance validity */
994 if (!i || (!(InstanceKind(i)==REAL_INST)
995 && !(InstanceKind(i)==REAL_ATOM_INST)
996 && !(InstanceKind(i)==REAL_CONSTANT_INST)
997 )) {
998 return 4;
999 }
1000 /* get number from vstr */
1001 if (!vstr) {
1002 return 5;
1003 }
1004 dval = strtod(vstr,&ends);
1005 if (ends==vstr) {
1006 return 5;
1007 }
1008
1009 /* get valid units struct */
1010 if (ustr==NULL || strlen(ustr)==0 || strcmp(ustr,"*")==0) {
1011 SetRealAtomValue((struct Instance *)i,dval,depth);
1012 } else {
1013 dim_type *dimp = NULL;
1014 double sival = (double)0.0;
1015 struct Units *up = (struct Units *)LookupUnits(ustr);
1016
1017 if (up==NULL) {
1018 unsigned long pos;
1019 int ecode;
1020 up = (struct Units *)FindOrDefineUnits(ustr,&pos,&ecode);
1021 if (up==NULL) {
1022 return 1;
1023 }
1024 }
1025 dimp = (dim_type *)UnitsDimensions(up);
1026 assert(dimp!=NULL /* null dims returned by FindOrDefineUnits */);
1027
1028 /* assign dimensionality if wild, or check for dim incompatibility. */
1029 if (IsWild(RealAtomDims(i))) {
1030 SetRealAtomDims((struct Instance *)i,dimp);
1031 } else if ( CmpDimen(dimp,RealAtomDims(i)) ) {
1032 return 2;
1033 }
1034 /* convert to SI, and assign if ok */
1035 if (Unit_UnconvertReal(dval,up,&sival)) {
1036 return 3;
1037 }
1038 SetRealAtomValue((struct Instance *)i,sival,depth);
1039 }
1040 return 0;
1041 }
1042
1043 /* assumes the tcl unitsinterp is set before entry. else does nothing.
1044 */
1045 static
1046 void Unit_GetUserSet(struct DisplayUnit *du)
1047 {
1048 if (!unitsinterp) {
1049 return;
1050 }
1051 if (du->u!=NULL && UnitsDescription(du->u)!=NULL) {
1052 Tcl_AppendElement(unitsinterp,(char *)UnitsDescription(du->u));
1053 }
1054 }
1055
1056 /********************* END INTERNALS ******************************/
1057
1058 int Asc_UnitDestroyDisplayList(ClientData cdata, Tcl_Interp *interp,
1059 int argc, CONST84 char *argv[])
1060 {
1061 (void)cdata; /* stop gcc whine about unused parameter */
1062 (void)interp; /* stop gcc whine about unused parameter */
1063 (void)argv; /* stop gcc whine about unused parameter */
1064
1065 if ( argc != 1 ) {
1066 return TCL_ERROR;
1067 }
1068 destroy_DUList();
1069 return TCL_OK;
1070 }
1071
1072
1073 int Asc_UnitDefaultBaseUnits(ClientData cdata, Tcl_Interp *interp,
1074 int argc, CONST84 char *argv[])
1075 {
1076 static int SIset;
1077 int i;
1078
1079 (void)cdata; /* stop gcc whine about unused parameter */
1080 (void)interp; /* stop gcc whine about unused parameter */
1081 (void)argc; /* stop gcc whine about unused parameter */
1082 (void)argv; /* stop gcc whine about unused parameter */
1083
1084 if (!SIset) {
1085 g_SI_units[D_MASS]=
1086 (struct Units *)LookupUnits(UNIT_BASE_MASS);
1087 g_SI_units[D_QUANTITY]=
1088 (struct Units *)LookupUnits(UNIT_BASE_QUANTITY);
1089 g_SI_units[D_LENGTH]=
1090 (struct Units *)LookupUnits(UNIT_BASE_LENGTH);
1091 g_SI_units[D_TIME]=
1092 (struct Units *)LookupUnits(UNIT_BASE_TIME);
1093 g_SI_units[D_TEMPERATURE]=
1094 (struct Units *)LookupUnits(UNIT_BASE_TEMPERATURE);
1095 g_SI_units[D_CURRENCY]=
1096 (struct Units *)LookupUnits(UNIT_BASE_CURRENCY);
1097 g_SI_units[D_ELECTRIC_CURRENT]=
1098 (struct Units *)LookupUnits(UNIT_BASE_ELECTRIC_CURRENT);
1099 g_SI_units[D_LUMINOUS_INTENSITY]=
1100 (struct Units *)LookupUnits(UNIT_BASE_LUMINOUS_INTENSITY);
1101 g_SI_units[D_PLANE_ANGLE]=
1102 (struct Units *)LookupUnits(UNIT_BASE_PLANE_ANGLE);
1103 g_SI_units[D_SOLID_ANGLE]=
1104 (struct Units *)LookupUnits(UNIT_BASE_SOLID_ANGLE);
1105 SIset = 1;
1106 for (i = 0;i<NUM_DIMENS;i++) {
1107 assert(g_SI_units[i]!=NULL);
1108 }
1109 }
1110 for (i = 0;i<NUM_DIMENS;i++) {
1111 g_base_units[i]=g_SI_units[i];
1112 }
1113 return TCL_OK;
1114 }
1115
1116 int Asc_UnitGetBaseUnits(ClientData cdata, Tcl_Interp *interp,
1117 int argc, CONST84 char *argv[])
1118 {
1119 int i;
1120 check_units_set(cdata, interp, argc, argv);
1121 for (i = 0; i<NUM_DIMENS; i++) {
1122 if (g_base_units[i]!=NULL) {
1123 Tcl_AppendElement(interp,(char *)UnitsDescription(g_base_units[i]));
1124 } else {
1125 Tcl_AppendElement(interp,(char *)"undefined!");
1126 }
1127 }
1128 return TCL_OK;
1129 }
1130
1131 int Asc_UnitDump(ClientData cdata, Tcl_Interp *interp,
1132 int argc, CONST84 char *argv[])
1133 {
1134 int dev,status = TCL_OK, tmpi;
1135 FILE * fp;
1136
1137 (void)cdata; /* stop gcc whine about unused parameter */
1138
1139 if (( argc < 2 ) || ( argc > 3 )) {
1140 FPRINTF(stderr,"call is: u_dump <device #> \n");
1141 Tcl_SetResult(interp, "u_dump <arg> expects 0,1,2 for #.", TCL_STATIC);
1142 return TCL_ERROR;
1143 }
1144
1145 tmpi = 3;
1146 status = Tcl_GetInt(interp,argv[1],&tmpi);
1147 if (tmpi<0 || tmpi >2) {
1148 status = TCL_ERROR;
1149 }
1150 if (status!=TCL_OK) {
1151 FPRINTF(stderr,"u_dump: first arg is 0,1, or 2\n");
1152 Tcl_ResetResult(interp);
1153 Tcl_SetResult(interp, "u_dump: invalid output dev #", TCL_STATIC);
1154 return status;
1155 } else {
1156 dev = tmpi;
1157 }
1158
1159 switch (dev) {
1160 case 0: fp = stdout;
1161 break;
1162 case 1: fp = stderr;
1163 break;
1164 case 2: fp = NULL;
1165 break;
1166 default : /* should never be here */
1167 FPRINTF(stderr,"u_dump called with strange i/o option!!\n");
1168 return TCL_ERROR;
1169 }
1170
1171 if (fp==NULL) {
1172 char a[1024];
1173 register unsigned long c;
1174 struct Units *p;
1175 for(c = 0;c<UNITS_HASH_SIZE;c++) {
1176 for(p = g_units_hash_table[c];p!=NULL;p = p->next) {
1177 if ( argc == 3 ) {
1178 sprintf(a,"%20s %20.15g ",
1179 SCP(UnitsDescription(p)),
1180 UnitsConvFactor(p));
1181 } else {
1182 /* pretty was asked not asked for */
1183 char *ussi;
1184 char *dimstr;
1185 ussi = UnitsStringSI(p);
1186 dimstr = WriteDimensionString(UnitsDimensions(p));
1187 sprintf(a,"%p %s %.16g %s %s",
1188 (void *)UnitsDimensions(p),
1189 SCP(UnitsDescription(p)),
1190 UnitsConvFactor(p),
1191 UnitsStringSI(p),
1192 (dimstr==NULL)?"":dimstr);
1193 if (dimstr != NULL) {
1194 ascfree(dimstr);
1195 }
1196 ascfree(ussi);
1197 }
1198
1199 Tcl_AppendElement(interp,a);
1200 }
1201 }
1202 } else {
1203 DumpUnits(fp);
1204 }
1205 return TCL_OK;
1206 }
1207
1208 int Asc_DimenDump(ClientData cdata, Tcl_Interp *interp,
1209 int argc, CONST84 char *argv[])
1210 {
1211 int dev,status = TCL_OK, tmpi;
1212 FILE * fp;
1213
1214 (void)cdata; /* stop gcc whine about unused parameter */
1215
1216 if ( argc != 2 ) {
1217 FPRINTF(stderr,"call is: u_dims <device #> \n");
1218 Tcl_SetResult(interp, "u_dims <arg> expects 0,1,2 for #.", TCL_STATIC);
1219 return TCL_ERROR;
1220 }
1221
1222 tmpi = 3;
1223 status = Tcl_GetInt(interp,argv[1],&tmpi);
1224 if (tmpi<0 || tmpi >2) {
1225 status = TCL_ERROR;
1226 }
1227 if (status!=TCL_OK) {
1228 FPRINTF(stderr,"u_dims: first arg is 0,1, or 2\n");
1229 Tcl_ResetResult(interp);
1230 Tcl_SetResult(interp, "u_dims: invalid output dev #", TCL_STATIC);
1231 return status;
1232 } else {
1233 dev = tmpi;
1234 }
1235
1236 switch (dev) {
1237 case 0: fp = stdout;
1238 break;
1239 case 1: fp = stderr;
1240 break;
1241 case 2: fp = NULL;
1242 break;
1243 default : /* should never be here */
1244 FPRINTF(stderr,"u_dims called with strange i/o option!!\n");
1245 return TCL_ERROR;
1246 }
1247
1248 if (!fp) {
1249 char a[1024];
1250 register unsigned long c,len = gl_length(g_dimen_list);
1251 dim_type *d;
1252 for(c = 1;c<=len;c++) {
1253 d = (dim_type *)gl_fetch(g_dimen_list,c);
1254 if (IsWild(d)) {
1255 sprintf(a,"wild");
1256 } else {
1257 sprintf(a,"%s","\0");
1258 }
1259 if (CmpDimen(d,Dimensionless())!=0) {
1260 Asc_BrowWriteDimensions(a,d);
1261 }
1262 Tcl_AppendResult(interp," {",a,"}",SNULL);
1263 }
1264
1265 } else {
1266 DumpDimens(fp);
1267 }
1268 return TCL_OK;
1269 }
1270
1271 int Asc_DimenRelCheck(ClientData cdata, Tcl_Interp *interp,
1272 int argc, CONST84 char *argv[]) {
1273 int status,tmpi;
1274
1275 (void)cdata; /* stop gcc whine about unused parameter */
1276
1277 if ( argc != 2 ) {
1278 FPRINTF(stderr,"call is: u_dim_setverify <0,1>\n");
1279 Tcl_SetResult(interp, "u_dim_setverify expects a number 0 or 1.",
1280 TCL_STATIC);
1281 return TCL_ERROR;
1282 }
1283 tmpi = 2;
1284 status = Tcl_GetInt(interp,argv[1],&tmpi);
1285 if (tmpi<0 || tmpi>1) {
1286 status = TCL_ERROR;
1287 }
1288 if (status!=TCL_OK) {
1289 FPRINTF(stderr,"u_dim_setverify: value must be 0 or 1");
1290 Tcl_ResetResult(interp);
1291 Tcl_SetResult(interp, "u_dim_setverify: invalid boolean given.",
1292 TCL_STATIC);
1293 return status;
1294 }
1295 g_check_dimensions_noisy = tmpi;
1296 return TCL_OK;
1297 }
1298 int Asc_UnitBaseDimToNum(ClientData cdata, Tcl_Interp *interp,
1299 int argc, CONST84 char *argv[])
1300 {
1301 char tmps[4];
1302 char *c;
1303 int i;
1304
1305 (void)cdata; /* stop gcc whine about unused parameter */
1306
1307 if ( argc != 2 ) {
1308 FPRINTF(stderr,"call is: u_dim2num <M,T,L,C,Q,TMP,P,S,E,LUM> \n");
1309 Tcl_SetResult(interp, "u_dim2num expects 1 argument", TCL_STATIC);
1310 return TCL_ERROR;
1311 }
1312 c = QUIET(argv[1]);
1313 for( i = 0; i < NUM_DIMENS && strcmp(c,DimName(i)); i++ );
1314 if( i == NUM_DIMENS ) {
1315 Tcl_SetResult(interp, "u_dim2num called with unknown base dimension.",
1316 TCL_STATIC);
1317 return TCL_ERROR;
1318 } else {
1319 sprintf(tmps,"%d",i);
1320 }
1321 Tcl_AppendResult(interp,tmps,SNULL);
1322 return TCL_OK;
1323 }
1324
1325 int Asc_UnitNumToBaseDim(ClientData cdata, Tcl_Interp *interp,
1326 int argc, CONST84 char *argv[])
1327 {
1328 int status = TCL_OK, tmpi;
1329
1330 (void)cdata; /* stop gcc whine about unused parameter */
1331
1332 if ( argc != 2 ) {
1333 FPRINTF(stderr,"call is: u_num2dim <num> \n");
1334 Tcl_SetResult(interp, "u_num2dim <arg>", TCL_STATIC);
1335 return TCL_ERROR;
1336 }
1337 tmpi = 100;
1338 status = Tcl_GetInt(interp,argv[1],&tmpi);
1339 if (tmpi<0 || tmpi>=NUM_DIMENS) {
1340 status = TCL_ERROR;
1341 }
1342 if (status!=TCL_OK) {
1343 FPRINTF(stderr,"u_num2dim: arg is in range 0 - %d\n",(NUM_DIMENS-1));
1344 Tcl_ResetResult(interp);
1345 Tcl_SetResult(interp, "u_num2dim: invalid dim #", TCL_STATIC);
1346 return status;
1347 }
1348 Tcl_AppendResult(interp,DimName(tmpi),SNULL);
1349 return TCL_OK;
1350 }
1351
1352 int Asc_UnitMatchBaseDim(ClientData cdata, Tcl_Interp *interp,
1353 int argc, CONST84 char *argv[])
1354 {
1355 int status = TCL_OK;
1356 int tmpi;
1357
1358 if ( argc != 2 ) {
1359 FPRINTF(stderr,"call is: u_num2dim <num> \n");
1360 Tcl_SetResult(interp, "u_num2dim <arg>", TCL_STATIC);
1361 return TCL_ERROR;
1362 }
1363 tmpi = 100;
1364 status = Tcl_GetInt(interp,argv[1],&tmpi);
1365 if (tmpi<0 || tmpi>=NUM_DIMENS) {
1366 status = TCL_ERROR;
1367 }
1368 if (status!=TCL_OK) {
1369 FPRINTF(stderr,"u_frombasedim: arg is in range 0 - %d\n",
1370 (NUM_DIMENS-1));
1371 Tcl_ResetResult(interp);
1372 Tcl_SetResult(interp, "u_frombasedim: invalid dim #", TCL_STATIC);
1373 return status;
1374 }
1375 status = Asc_UnitNumToBaseDim(cdata,interp,argc,argv);
1376 if (status ==TCL_OK) {
1377 dim_type dim;
1378 struct gl_list_t *ulist = gl_create(50L);
1379 register unsigned long c;
1380 struct Units *p;
1381
1382 ClearDimensions(&dim);
1383 ParseDim(&dim,Tcl_GetStringResult(interp));
1384 Tcl_ResetResult(interp);
1385 for(c = 0;c<UNITS_HASH_SIZE;c++) {
1386 for(p = g_units_hash_table[c];p!=NULL;p = p->next) {
1387 if (CmpDimen(&dim,UnitsDimensions(p))==0) {
1388 gl_insert_sorted(ulist,(VOIDPTR)p,(CmpFunc)Unit_CmpConv);
1389 }
1390 }
1391 }
1392 for(c = 1;c<=gl_length(ulist);c++) {
1393 Tcl_AppendElement(interp,
1394 (char *)UnitsDescription((struct Units *)gl_fetch(ulist,c)));
1395 }
1396 gl_destroy(ulist);
1397 } else {
1398 Tcl_AppendResult(interp," called from u_frombasedim",SNULL);
1399 }
1400 return status;
1401 }
1402
1403 int Asc_UnitMatchAtomDim(ClientData cdata, Tcl_Interp *interp,
1404 int argc, CONST84 char *argv[])
1405 {
1406 struct TypeDescription *desc;
1407
1408 (void)cdata; /* stop gcc whine about unused parameter */
1409
1410 if ( argc != 2 ) {
1411 FPRINTF(stderr,"call is: u_fromatomdim <atom_typename> \n");
1412 Tcl_SetResult(interp, "u_fromatomdim: expects atom type.", TCL_STATIC);
1413 return TCL_ERROR;
1414 }
1415 desc = UnitsFindType(argv[1]);
1416 if (desc!=NULL && GetBaseType(desc)==real_type) {
1417 dim_type *dim = (dim_type *)GetRealDimens(desc);
1418 struct gl_list_t *ulist = gl_create(50L);
1419 register unsigned long c;
1420 struct Units *p;
1421
1422 for(c = 0;c<UNITS_HASH_SIZE;c++) {
1423 for(p = g_units_hash_table[c];p!=NULL;p = p->next) {
1424 if (CmpDimen(dim,UnitsDimensions(p))==0) {
1425 gl_insert_sorted(ulist,(VOIDPTR)p,(CmpFunc)Unit_CmpConv);
1426 }
1427 }
1428 }
1429 for(c = 1;c<=gl_length(ulist);c++) {
1430 Tcl_AppendElement(interp,
1431 (char *)UnitsDescription((struct Units *)gl_fetch(ulist,c)));
1432 }
1433 gl_destroy(ulist);
1434 } else {
1435 Tcl_SetResult(interp, "u_fromatomdim called with bad real atom name",
1436 TCL_STATIC);
1437 return TCL_ERROR;
1438 }
1439 return TCL_OK;
1440 }
1441
1442 int Asc_UnitGetAtomList(ClientData cdata, Tcl_Interp *interp,
1443 int argc, CONST84 char *argv[])
1444 {
1445 struct gl_list_t *alist = gl_create(200L);
1446 struct gl_list_t *dlist = NULL;
1447 register struct TypeDescription *desc, *rtdesc;
1448 register dim_type *dim;
1449 register unsigned long c,len;
1450 char a[1024];
1451
1452 (void)cdata; /* stop gcc whine about unused parameter */
1453 (void)argv; /* stop gcc whine about unused parameter */
1454
1455 if ( argc != 1 ) {
1456 FPRINTF(stderr,"call is: u_getdimatoms <no args> \n");
1457 Tcl_SetResult(interp, "u_getdimatoms: unexpected arg found.", TCL_STATIC);
1458 return TCL_ERROR;
1459 }
1460 rtdesc = UnitsFindType("real");
1461 assert(rtdesc);
1462 dlist = DefinitionList();
1463 if (!dlist) {
1464 Tcl_SetResult(interp, "u_getdimatoms found no type definitions.",
1465 TCL_STATIC);
1466 return TCL_ERROR;
1467 }
1468 len = gl_length(dlist);
1469 for(c = 1;c<=len;c++) {
1470 desc = (struct TypeDescription *)gl_fetch(dlist,c);
1471 if (desc) {/* MoreRefined doesn't take kindly to null */
1472 if (MoreRefined(desc,rtdesc)) {
1473 dim = (dim_type *)GetRealDimens(desc);
1474 if (CmpDimen(dim,Dimensionless())!=0 && !IsWild(dim)) {
1475 gl_insert_sorted(alist,(VOIDPTR)desc,(CmpFunc)Unit_CmpAtomName);
1476 }
1477 }
1478 }
1479 }
1480 gl_destroy(dlist);
1481 len = gl_length(alist);
1482 for(c = 1;c<=len;c++) {
1483 desc = (struct TypeDescription *)gl_fetch(alist,c);
1484 sprintf(a,"%s ",(char *)SCP(GetName(desc)));
1485 Asc_BrowWriteDimensions(a,GetRealDimens(desc));
1486 Tcl_AppendElement(interp,a);
1487 }
1488 gl_destroy(alist);
1489 return TCL_OK;
1490 }
1491
1492 int Asc_UnitChangeBaseUnit(ClientData cdata, Tcl_Interp *interp,
1493 int argc, CONST84 char *argv[])
1494 {
1495 struct Units *up = NULL;
1496 if ( argc != 2 ) {
1497 FPRINTF(stderr,"call is: u_change_baseunit <unit>\n");
1498 Tcl_SetResult(interp, "u_change_baseunit wants a simple unit arg",
1499 TCL_STATIC);
1500 return TCL_ERROR;
1501 }
1502 check_units_set(cdata,interp,argc,argv);
1503 check_DU_set();
1504 up = (struct Units *)LookupUnits(argv[1]);
1505 if (up != NULL) {
1506 int c;
1507 for(c = 0;
1508 ((c < (NUM_DIMENS))
1509 && CmpDimen(UnitsDimensions(up),UnitsDimensions(g_base_units[c]))!=0);
1510 c++);
1511 if (c==(NUM_DIMENS)) {
1512 Tcl_SetResult(interp,
1513 "u_change_baseunit called with non-base dimensioned unit",
1514 TCL_STATIC);
1515 return TCL_ERROR;
1516 }
1517 g_base_units[c]=up;
1518 updatefundunitdim = -1;
1519 for (c = 0;updatefundunitdim<0 && c<NUM_DIMENS;c++) {
1520 if (Numerator(GetDimFraction(*(UnitsDimensions(up)),c)) != 0 ) {
1521 updatefundunitdim = c;
1522 }
1523 }
1524 gl_iterate( DUList, (void (*)(VOIDPTR))Unit_UpdateFundUnits );
1525 return TCL_OK;
1526 } else {
1527 Tcl_SetResult(interp, "u_change_baseunit called with unknown unit.",
1528 TCL_STATIC);
1529 return TCL_ERROR;
1530 }
1531 }
1532
1533 int Asc_UnitSetUser(ClientData cdata, Tcl_Interp *interp,
1534 int argc, CONST84 char *argv[])
1535 {
1536 struct Units *up = NULL;
1537 struct DisplayUnit *du;
1538 if ( argc != 2 ) {
1539 FPRINTF(stderr,"call is: u_set_user <unit>\n");
1540 Tcl_SetResult(interp, "u_set_user wants a units string arg", TCL_STATIC);
1541 return TCL_ERROR;
1542 }
1543 check_units_set(cdata,interp,argc,argv);
1544 check_DU_set();
1545 up = (struct Units *)LookupUnits(argv[1]);
1546 if (up ==NULL) {
1547 unsigned long pos;
1548 int ecode;
1549 up = (struct Units *)FindOrDefineUnits(argv[1],&pos,&ecode);
1550 }
1551 if (up!=NULL) {
1552 du = Unit_FindOrAddDU((dim_type *)UnitsDimensions(up));
1553 du->u = up;
1554 return TCL_OK;
1555 }
1556 Tcl_SetResult(interp, "u_set_user unable to parse the units given.",
1557 TCL_STATIC);
1558 return TCL_ERROR;
1559 }
1560
1561 /*
1562 * return all real atoms and real constants which have the units
1563 * given.
1564 */
1565 int Asc_UnitGetAtomsForUnit(ClientData cdata, Tcl_Interp *interp,
1566 int argc, CONST84 char *argv[])
1567 {
1568 struct TypeDescription *desc, *rtdesc, *rcdesc;
1569 struct Units *up = NULL;
1570 struct DisplayUnit *du;
1571 unsigned long c,len;
1572 struct gl_list_t *dlist, *alist, *blist;
1573 dim_type *dim;
1574 unsigned long pos;
1575 int ecode;
1576
1577 if ( argc != 2 ) {
1578 FPRINTF(stderr,"call is: u_get_atoms <unit>\n");
1579 Tcl_SetResult(interp, "u_get_atoms wants a units string arg", TCL_STATIC);
1580 return TCL_ERROR;
1581 }
1582 check_units_set(cdata,interp,argc,argv);
1583 check_DU_set();
1584 up = (struct Units *)LookupUnits(argv[1]);
1585 if (up == NULL) {
1586 up = (struct Units *)FindOrDefineUnits(argv[1],&pos,&ecode);
1587 }
1588 if (up != NULL) {
1589 du = Unit_FindOrAddDU((dim_type *)UnitsDimensions(up));
1590 du->u = up;
1591 } else {
1592 Tcl_SetResult(interp, "u_get_atoms unable to parse the units given.",
1593 TCL_STATIC);
1594 return TCL_ERROR;
1595 }
1596 rtdesc = UnitsFindType("real");
1597 rcdesc = UnitsFindType("real_constant");
1598 assert(rtdesc);
1599 assert(rcdesc);
1600 dlist = DefinitionList();
1601 if (!dlist) {
1602 Tcl_SetResult(interp, "u_get_atoms found no type definitions.",
1603 TCL_STATIC);
1604 return TCL_ERROR;
1605 }
1606 len = gl_length(dlist);
1607 alist = gl_create(len);
1608 blist = gl_create(len);
1609 for(c = 1;c<=len;c++) {
1610 desc = (struct TypeDescription *)gl_fetch(dlist,c);
1611 if (desc != NULL) {/* MoreRefined doesn't take kindly to null */
1612 if (MoreRefined(desc,rtdesc)!= NULL) {
1613 dim = (dim_type *)GetRealDimens(desc);
1614 if (CmpDimen(dim,du->d) == 0 && !IsWild(dim)) {
1615 gl_insert_sorted(alist,(VOIDPTR)desc,(CmpFunc)Unit_CmpAtomName);
1616 }
1617 } else {
1618 if (MoreRefined(desc,rcdesc) != NULL) {
1619 dim = (dim_type *)GetConstantDimens(desc);
1620 if (dim != NULL && CmpDimen(dim,du->d) == 0 && !IsWild(dim)) {
1621 gl_insert_sorted(blist,(VOIDPTR)desc,(CmpFunc)Unit_CmpAtomName);
1622 }
1623 }
1624 }
1625 }
1626 }
1627 gl_destroy(dlist);
1628
1629 len = gl_length(alist);
1630 for(c = 1;c<=len;c++) {
1631 desc = (struct TypeDescription *)gl_fetch(alist,c);
1632 Tcl_AppendElement(interp,(char *)SCP(GetName(desc)));
1633 }
1634 gl_destroy(alist);
1635
1636 len = gl_length(blist);
1637 for(c = 1;c<=len;c++) {
1638 desc = (struct TypeDescription *)gl_fetch(blist,c);
1639 Tcl_AppendElement(interp,(char *)SCP(GetName(desc)));
1640 }
1641 gl_destroy(blist);
1642 return TCL_OK;
1643 }
1644
1645
1646 int Asc_UnitGetPrec(ClientData cdata, Tcl_Interp *interp,
1647 int argc, CONST84 char *argv[])
1648 {
1649 char buf[MAXIMUM_NUMERIC_LENGTH]; /* string to hold integer */
1650 (void)cdata; /* stop gcc whine about unused parameter */
1651 (void)argv; /* stop gcc whine about unused parameter */
1652
1653 if ( argc != 1 ) {
1654 FPRINTF(stderr,"call is: u_getprec <no args>\n");
1655 Tcl_SetResult(interp, "u_getprec expects no arguments.", TCL_STATIC);
1656 return TCL_ERROR;
1657 }
1658 sprintf(buf,"%d",UPREC);
1659 Tcl_SetResult(interp, buf, TCL_VOLATILE);
1660 return TCL_OK;
1661 }
1662
1663 int Asc_UnitGetCPrec()
1664 {
1665 return UPREC;
1666 }
1667
1668 int Asc_UnitSetPrec(ClientData cdata, Tcl_Interp *interp,
1669 int argc, CONST84 char *argv[])
1670 {
1671 int status,tmpi;
1672
1673 (void)cdata; /* stop gcc whine about unused parameter */
1674
1675 if ( argc != 2 ) {
1676 FPRINTF(stderr,"call is: u_setprec <number>\n");
1677 Tcl_SetResult(interp, "u_setprec expects a number 4 to 16.", TCL_STATIC);
1678 return TCL_ERROR;
1679 }
1680 tmpi = 100;
1681 status = Tcl_GetInt(interp,argv[1],&tmpi);
1682 if (tmpi<4 || tmpi>16) {
1683 status = TCL_ERROR;
1684 }
1685 if (status!=TCL_OK) {
1686 FPRINTF(stderr,"u_setprec: Precision must be in range 4 - 16");
1687 Tcl_ResetResult(interp);
1688 Tcl_SetResult(interp, "u_setprec: invalid precision specified.",
1689 TCL_STATIC);
1690 return status;
1691 }
1692 UPREC = tmpi;
1693 return TCL_OK;
1694 }
1695
1696 int Asc_UnitGetUnits(ClientData cdata, Tcl_Interp *interp,
1697 int argc, CONST84 char *argv[])
1698 {
1699 struct TypeDescription *desc;
1700
1701 (void)cdata; /* stop gcc whine about unused parameter */
1702
1703 if ( argc != 2 ) {
1704 FPRINTF(stderr,"call is: u_get_units <atom_typename> \n");
1705 Tcl_SetResult(interp, "u_get_units: expects atom type.", TCL_STATIC);
1706 return TCL_ERROR;
1707 }
1708 desc = UnitsFindType(argv[1]);
1709 if (desc!=NULL && GetBaseType(desc)==real_type) {
1710 dim_type *dim = (dim_type *)GetRealDimens(desc);
1711 struct DisplayUnit *du;
1712 assert(dim!=NULL);
1713 if (IsWild(dim) || CmpDimen(dim,Dimensionless())==0 ) {
1714 return TCL_OK;
1715 }
1716 du = Unit_FindOrAddDU(dim);
1717 if (du->u!=NULL) {
1718 Tcl_AppendResult(interp,UnitsDescription(du->u),SNULL);
1719 return TCL_OK;
1720 }
1721 if (du->fu!=NULL) {
1722 Tcl_AppendResult(interp,UnitsDescription(du->fu),SNULL);
1723 return TCL_OK;
1724 } else {
1725 struct Units *u = Unit_DisplayFund(dim);
1726 if (!u) {
1727 Tcl_SetResult(interp,
1728 "u_get_units: unable to define fundamental units!",
1729 TCL_STATIC);
1730 return TCL_ERROR;
1731 } else {
1732 Tcl_AppendResult(interp,UnitsDescription(u),SNULL);
1733 return TCL_OK;
1734 }
1735 }
1736 } else {
1737 Tcl_SetResult(interp, "u_get_units called with bad real atom name",
1738 TCL_STATIC);
1739 return TCL_ERROR;
1740 }
1741 }
1742
1743 int Asc_UnitGetUser(ClientData cdata, Tcl_Interp *interp,
1744 int argc, CONST84 char *argv[])
1745 {
1746 struct TypeDescription *desc;
1747
1748 (void)cdata; /* stop gcc whine about unused parameter */
1749
1750 if ( argc != 2 ) {
1751 FPRINTF(stderr,"call is: u_get_user <atom_typename> \n");
1752 Tcl_SetResult(interp, "u_get_user: expects atom type.", TCL_STATIC);
1753 return TCL_ERROR;
1754 }
1755 desc = UnitsFindType(argv[1]);
1756 if (desc!=NULL && GetBaseType(desc)==real_type) {
1757 dim_type *dim = (dim_type *)GetRealDimens(desc);
1758 struct Units *u;
1759 assert(dim!=NULL);
1760 if (IsWild(dim) || CmpDimen(dim,Dimensionless())==0 ) {
1761 return TCL_OK;
1762 }
1763 u = Unit_DisplayUnits(dim);
1764 if (u!=NULL) {
1765 Tcl_AppendResult(interp,UnitsDescription(u),SNULL);
1766 } else {
1767 Tcl_SetResult(interp, "default", TCL_STATIC);
1768 }
1769 return TCL_OK;
1770 } else {
1771 Tcl_SetResult(interp, "u_get_user called with bad real atom name",
1772 TCL_STATIC);
1773 return TCL_ERROR;
1774 }
1775 }
1776
1777 int Asc_UnitGetList(ClientData cdata, Tcl_Interp *interp,
1778 int argc, CONST84 char *argv[])
1779 {
1780 (void)cdata; /* stop gcc whine about unused parameter */
1781 (void)argv; /* stop gcc whine about unused parameter */
1782
1783 if ( argc != 1 ) {
1784 FPRINTF(stderr,"call is: u_get_list <no args> \n");
1785 Tcl_SetResult(interp, "u_get_list: expects no arguments.", TCL_STATIC);
1786 return TCL_ERROR;
1787 }
1788 check_DU_set();
1789 unitsinterp = interp;
1790 gl_iterate(DUList,(void (*)(VOIDPTR))Unit_GetUserSet);
1791 return TCL_OK;
1792 }
1793 int Asc_UnitClearUser(ClientData cdata, Tcl_Interp *interp,
1794 int argc, CONST84 char *argv[])
1795 {
1796 struct TypeDescription *desc;
1797
1798 (void)cdata; /* stop gcc whine about unused parameter */
1799
1800 if ( argc != 2 ) {
1801 FPRINTF(stderr,"call is: u_clear_user <atom_typename> \n");
1802 Tcl_SetResult(interp, "u_clear_user: expects atom type.", TCL_STATIC);
1803 return TCL_ERROR;
1804 }
1805 desc = UnitsFindType(argv[1]);
1806 if (desc!=NULL && GetBaseType(desc)==real_type) {
1807 dim_type *dim = (dim_type *)GetRealDimens(desc);
1808 struct DisplayUnit *du;
1809 assert(dim!=NULL);
1810 if (IsWild(dim) || CmpDimen(dim,Dimensionless())==0 ) {
1811 return TCL_OK;
1812 }
1813 du = Unit_FindOrAddDU(dim);
1814 du->u = (struct Units *)NULL;
1815 return TCL_OK;
1816 } else {
1817 Tcl_SetResult(interp, "u_clear_user called with bad real atom name",
1818 TCL_STATIC);
1819 return TCL_ERROR;
1820 }
1821 }
1822
1823 int Asc_UnitGetVal(ClientData cdata, Tcl_Interp *interp,
1824 int argc, CONST84 char *argv[])
1825 {
1826 struct Instance *i;
1827 int status;
1828
1829 (void)cdata; /* stop gcc whine about unused parameter */
1830
1831 if ( argc != 2 ) {
1832 Tcl_SetResult(interp, "u_getval expected <qlfdid>", TCL_STATIC);
1833 return TCL_ERROR;
1834 }
1835 status = Asc_QlfdidSearch3(argv[1],0);
1836 if (status ==0) {
1837 i = g_search_inst;
1838 } else {
1839 Tcl_AppendResult(interp,"u_getval: QlfdidSearchCmd error",
1840 argv[1], " not found.",SNULL);
1841 return TCL_ERROR;
1842 }
1843 if (IsDimInstance(i)) {
1844 Tcl_AppendElement(interp,Asc_UnitValue(i));
1845 } else {
1846 Tcl_SetResult(interp, "u_getval called on undimensioned object.",
1847 TCL_STATIC);
1848 return TCL_ERROR;
1849 }
1850 return TCL_OK;
1851 }
1852
1853 int Asc_UnitBrowGetVal(ClientData cdata, Tcl_Interp *interp,
1854 int argc, CONST84 char *argv[])
1855 {
1856 struct Instance *i;
1857 (void)cdata; /* stop gcc whine about unused parameter */
1858 (void)argv; /* stop gcc whine about unused parameter */
1859
1860 ASCUSE;
1861
1862 if ( argc > 2 ) {
1863 Tcl_SetResult(interp, "u_browgetval [search]", TCL_STATIC);
1864 return TCL_ERROR;
1865 }
1866 if (argc==2) {
1867 if (strncmp(argv[1],"search",3)!=0) {
1868 Tcl_AppendResult(interp, "Error: ",argv[0]," incorrect argument",
1869 argv[1],(char *) NULL);
1870 return TCL_ERROR;
1871 }
1872 i = g_search_inst;
1873 } else {
1874 i = g_curinst;
1875 }
1876 if (IsDimInstance(i)) {
1877 Tcl_AppendElement(interp,Asc_UnitValue(i));
1878 } else {
1879 Tcl_SetResult(interp, "u_browgetval called on undimensioned object.",
1880 TCL_STATIC);
1881 return TCL_ERROR;
1882 }
1883 return TCL_OK;
1884 }
1885
1886 int Asc_UnitSlvGetRelVal(ClientData cdata, Tcl_Interp *interp,
1887 int argc, CONST84 char *argv[])
1888 {
1889 struct rel_relation **rp;
1890 int32 maxrel,relnum;
1891 int status = TCL_OK;
1892
1893 (void)cdata; /* stop gcc whine about unused parameter */
1894
1895 if ( argc != 2 ) {
1896 Tcl_AppendElement(interp,"u_slvgetrelval expects solver relation index.");
1897 return TCL_ERROR;
1898 }
1899 if (g_solvsys_cur==NULL) {
1900 FPRINTF(stderr,"u_slvgetrelval called with NULL pointer\n");
1901 Tcl_AppendElement(interp,"u_slvgetrelval called without slv_system");
1902 return TCL_ERROR;
1903 }
1904 rp = slv_get_solvers_rel_list(g_solvsys_cur);
1905 if (!rp) {
1906 FPRINTF(stderr, "NULL relation list found in u_slvgetrelval\n");
1907 Tcl_AppendElement(interp,"u_slvgetrelval called with null rellist");
1908 return TCL_ERROR;
1909 }
1910 maxrel = (int32)slv_get_num_solvers_rels(g_solvsys_cur);
1911 status = Tcl_GetInt(interp,argv[1],&relnum);
1912 if (relnum>=maxrel||status==TCL_ERROR) {
1913 Tcl_ResetResult(interp);
1914 Tcl_SetResult(interp, "u_slvgetrelval: equation requested does not exist",
1915 TCL_STATIC);
1916 FPRINTF(stderr,"u_slvgetrelval: relation index invalid.\n");
1917 return TCL_ERROR;
1918 }
1919 if ( IsDimInstance( rel_instance(rp[relnum]) ) ) {
1920 Tcl_AppendResult(interp,Asc_UnitValue(rel_instance(rp[relnum])),SNULL);
1921 } else {
1922 Tcl_SetResult(interp, "u_slvgetrelval called on wierd object.",TCL_STATIC);
1923 return TCL_ERROR;
1924 }
1925 return TCL_OK;
1926 }
1927
1928 int Asc_UnitSlvGetVarVal(ClientData cdata, Tcl_Interp *interp,
1929 int argc, CONST84 char *argv[])
1930 {
1931 struct var_variable **vp;
1932 int32 maxvar,varnum;
1933 int status = TCL_OK;
1934
1935 (void)cdata; /* stop gcc whine about unused parameter */
1936
1937 if ( argc != 2 ) {
1938 Tcl_AppendElement(interp,"u_slvgetvarval expects solver variable index.");
1939 return TCL_ERROR;
1940 }
1941 if (g_solvsys_cur==NULL) {
1942 FPRINTF(stderr,"u_slvgetvarval called with NULL pointer\n");
1943 Tcl_AppendElement(interp,"u_slvgetvarval called without slv_system");
1944 return TCL_ERROR;
1945 }
1946 vp = slv_get_solvers_var_list(g_solvsys_cur);
1947 if (!vp) {
1948 FPRINTF(stderr, "NULL variable list found in u_slvgetvarval\n");
1949 Tcl_AppendElement(interp,"u_slvgetvarval called with null varlist");
1950 return TCL_ERROR;
1951 }
1952 maxvar = (int32)slv_get_num_solvers_vars(g_solvsys_cur);
1953 status = Tcl_GetInt(interp,argv[1],&varnum);
1954 if (varnum>=maxvar||status ==TCL_ERROR) {
1955 Tcl_ResetResult(interp);
1956 Tcl_SetResult(interp, "u_slvgetvarval: variable requested does not exist",
1957 TCL_STATIC);
1958 FPRINTF(stderr,"u_slvgetvarval: variable index invalid.\n");
1959 return TCL_ERROR;
1960 }
1961 if (IsDimInstance(var_instance(vp[varnum]))) {
1962 Tcl_AppendResult(interp,Asc_UnitValue(var_instance(vp[varnum])),SNULL);
1963 } else {
1964 Tcl_SetResult(interp, "u_slvgetrelval called on wierd object.",TCL_STATIC);
1965 return TCL_ERROR;
1966 }
1967 return TCL_OK;
1968 }
1969
1970 int Asc_UnitSlvGetObjVal(ClientData cdata, Tcl_Interp *interp,
1971 int argc, CONST84 char *argv[])
1972 {
1973 struct rel_relation **rp;
1974 int32 maxobj,objnum;
1975 int status = TCL_OK;
1976
1977 (void)cdata; /* stop gcc whine about unused parameter */
1978
1979 if ( argc != 2 ) {
1980 Tcl_AppendElement(interp,"u_slvgetobjval expects solver objective index.");
1981 return TCL_ERROR;
1982 }
1983 if (g_solvsys_cur==NULL) {
1984 FPRINTF(stderr,"u_slvgetobjval called with NULL pointer\n");
1985 Tcl_AppendElement(interp,"u_slvgetobjval called without slv_system");
1986 return TCL_ERROR;
1987 }
1988 rp = slv_get_solvers_obj_list(g_solvsys_cur);
1989 if (!rp) {
1990 FPRINTF(stderr, "NULL objective list found in u_slvgetobjval\n");
1991 Tcl_AppendElement(interp,"u_slvgetobjval called with null objlist");
1992 return TCL_ERROR;
1993 }
1994 maxobj = (int32)slv_get_num_solvers_objs(g_solvsys_cur);
1995 status = Tcl_GetInt(interp,argv[1],&objnum);
1996 if (objnum>=maxobj||status==TCL_ERROR) {
1997 Tcl_ResetResult(interp);
1998 Tcl_SetResult(interp, "u_slvgetobjval: objective requested does not exist",
1999 TCL_STATIC);
2000 FPRINTF(stderr,"u_slvgetobjval: objective index invalid.\n");
2001 return TCL_ERROR;
2002 }
2003 if ( IsDimInstance( rel_instance(rp[objnum]) ) ) {
2004 Tcl_AppendResult(interp,Asc_UnitValue(rel_instance(rp[objnum])),SNULL);
2005 } else {
2006 Tcl_SetResult(interp, "u_slvgetobjval called on wierd object.",TCL_STATIC);
2007 return TCL_ERROR;
2008 }
2009 return TCL_OK;
2010
2011
2012
2013 /* OLD CODE HERE TO END
2014 if ( argc != 2 ) {
2015 Tcl_SetResult(interp, "u_slvgetobjval takes no args.", TCL_STATIC);
2016 return TCL_ERROR;
2017 } */
2018 /* write code here when exprdim available */
2019 /* return TCL_OK; */
2020 }
2021
2022
2023 #define LONGHELP(b,ms) ((b)?ms:"")
2024 int Asc_UnitHelpList(ClientData cdata, Tcl_Interp *interp,
2025 int argc, CONST84 char *argv[])
2026 {
2027 boolean detail = 1;
2028
2029 (void)cdata; /* stop gcc whine about unused parameter */
2030
2031 if ( argc > 2 ) {
2032 FPRINTF(stderr,"call is: uhelp [s,l] \n");
2033 Tcl_SetResult(interp, "Too many args to uhelp. Want 0 or 1 args",
2034 TCL_STATIC);
2035 return TCL_ERROR;
2036 }
2037 if ( argc == 2 ) {
2038 if (argv[1][0]=='s') {
2039 detail = 0;
2040 }
2041 if (argv[1][0]=='l') {
2042 detail = 1;
2043 }
2044 PRINTF("%-22s%s\n","u_destroy_list",
2045 LONGHELP(detail,"deallocate display units list"));
2046 PRINTF("%-22s%s\n","u_setSIdef",
2047 LONGHELP(detail,"set SI mks as display base units"));
2048 PRINTF("%-22s%s\n","u_getbasedef",
2049 LONGHELP(detail,"get current display base units list"));
2050 PRINTF("%-22s%s\n","u_dump",
2051 LONGHELP(detail,"dump all global units to out, err or list"));
2052 PRINTF("%-22s%s\n","u_dims",
2053 LONGHELP(detail,"dump all global dims to out, err or list"));
2054 PRINTF("%-22s%s\n","u_dim_setverify",
2055 LONGHELP(detail,"turn relation dim checking noise on or off"));
2056
2057 PRINTF("%-22s%s\n","u_num2dim",
2058 LONGHELP(detail,"return simple dimension corresponding to num"));
2059 PRINTF("%-22s%s\n","u_dim2num",
2060 LONGHELP(detail,"return number of a simple dimension"));
2061 PRINTF("%-22s%s\n","u_frombasedim",
2062 LONGHELP(detail,"return all unit names matching base dimension"));
2063 PRINTF("%-22s%s\n","u_fromatomdim",
2064 LONGHELP(detail,"return unit names matching atom dimension set"));
2065
2066 PRINTF("%-22s%s\n","u_getdimatoms",
2067 LONGHELP(detail,"get list of dimensioned atoms"));
2068 PRINTF("%-22s%s\n","u_get_atoms",
2069 LONGHELP(detail,"get list of atoms matching units given"));
2070 PRINTF("%-22s%s\n","u_change_baseunit",
2071 LONGHELP(detail,"change the display default unit for a dimension"));
2072 PRINTF("%-22s%s\n","u_getprec",
2073 LONGHELP(detail,"get current display value precision"));
2074 PRINTF("%-22s%s\n","u_setprec",
2075 LONGHELP(detail,"set new display value precision"));
2076
2077 PRINTF("%-22s%s\n","u_get_units",
2078 LONGHELP(detail,"get display units of dimensioned atom type"));
2079 PRINTF("%-22s%s\n","u_set_user",
2080 LONGHELP(detail,"set user display units in string given"));
2081 PRINTF("%-22s%s\n","u_get_list",
2082 LONGHELP(detail,"get all user set display units"));
2083 PRINTF("%-22s%s\n","u_get_user",
2084 LONGHELP(detail,"get user set display units of dimensioned atom type"));
2085 PRINTF("%-22s%s\n","u_clear_user",
2086 LONGHELP(detail,"unset user set display units of dimensioned atom"));
2087
2088 PRINTF("%-22s%s\n","u_getval",
2089 LONGHELP(detail,"get value and units of qlfdid"));
2090 PRINTF("%-22s%s\n","u_browgetval",
2091 LONGHELP(detail,"get value and units of g_curinst"));
2092 PRINTF("%-22s%s\n","u_slvgetrelval",
2093 LONGHELP(detail,"get value and units of indexed relation resid"));
2094 PRINTF("%-22s%s\n","u_slvgetvarval",
2095 LONGHELP(detail,"get value and units of indexed variable"));
2096 PRINTF("%-22s%s\n","u_slvgetobjval",
2097 LONGHELP(detail,"get value and units of objective"));
2098
2099 PRINTF("%-22s%s\n","uhelp",
2100 LONGHELP(detail,"uhelp s(=names only) l(=this list)."));
2101
2102 PRINTF("\n");
2103 }
2104 if ( argc == 1 ) {
2105 char * tmps;
2106 tmps = (char *)ascmalloc((MAXIMUM_NUMERIC_LENGTH+1)*sizeof(char));
2107
2108 sprintf(tmps,"u_destroy_list");
2109 Tcl_AppendElement(interp,tmps);
2110 sprintf(tmps,"u_setSIdef");
2111 Tcl_AppendElement(interp,tmps);
2112 sprintf(tmps,"u_getbasedef");
2113 Tcl_AppendElement(interp,tmps);
2114 sprintf(tmps,"u_dump");
2115 Tcl_AppendElement(interp,tmps);
2116 sprintf(tmps,"u_dims");
2117 Tcl_AppendElement(interp,tmps);
2118 sprintf(tmps,"u_dim_setverify");
2119 Tcl_AppendElement(interp,tmps);
2120
2121 sprintf(tmps,"u_num2dim");
2122 Tcl_AppendElement(interp,tmps);
2123 sprintf(tmps,"u_dim2num");
2124 Tcl_AppendElement(interp,tmps);
2125 sprintf(tmps,"u_frombasedim");
2126 Tcl_AppendElement(interp,tmps);
2127 sprintf(tmps,"u_fromatomdim");
2128 Tcl_AppendElement(interp,tmps);
2129
2130 sprintf(tmps,"u_getdimatoms");
2131 Tcl_AppendElement(interp,tmps);
2132 sprintf(tmps,"u_get_atoms");
2133 Tcl_AppendElement(interp,tmps);
2134 sprintf(tmps,"u_change_baseunit");
2135 Tcl_AppendElement(interp,tmps);
2136 sprintf(tmps,"u_getprec");
2137 Tcl_AppendElement(interp,tmps);
2138 sprintf(tmps,"u_setprec");
2139 Tcl_AppendElement(interp,tmps);
2140
2141 sprintf(tmps,"u_get_units");
2142 Tcl_AppendElement(interp,tmps);
2143 sprintf(tmps,"u_set_user");
2144 Tcl_AppendElement(interp,tmps);
2145 sprintf(tmps,"u_get_user");
2146 Tcl_AppendElement(interp,tmps);
2147 sprintf(tmps,"u_get_list");
2148 Tcl_AppendElement(interp,tmps);
2149 sprintf(tmps,"u_clear_user");
2150 Tcl_AppendElement(interp,tmps);
2151
2152 sprintf(tmps,"u_getval");
2153 Tcl_AppendElement(interp,tmps);
2154 sprintf(tmps,"u_browgetval");
2155 Tcl_AppendElement(interp,tmps);
2156
2157 sprintf(tmps,"u_slvgetrelval");
2158 Tcl_AppendElement(interp,tmps);
2159 sprintf(tmps,"u_slvgetvarval");
2160 Tcl_AppendElement(interp,tmps);
2161 sprintf(tmps,"u_slvgetobjval");
2162 Tcl_AppendElement(interp,tmps);
2163
2164 sprintf(tmps,"uhelp");
2165 Tcl_AppendElement(interp,tmps);
2166 ascfree(tmps);
2167 }
2168 return TCL_OK;
2169 }
2170

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