From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001 From: Joseph Hunkeler Date: Wed, 8 Jul 2015 20:46:52 -0400 Subject: Initial commit --- pkg/xtools/inlfit/ingcolon.gx | 362 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 362 insertions(+) create mode 100644 pkg/xtools/inlfit/ingcolon.gx (limited to 'pkg/xtools/inlfit/ingcolon.gx') diff --git a/pkg/xtools/inlfit/ingcolon.gx b/pkg/xtools/inlfit/ingcolon.gx new file mode 100644 index 00000000..5b9f7bfb --- /dev/null +++ b/pkg/xtools/inlfit/ingcolon.gx @@ -0,0 +1,362 @@ +include +include +include + +# List of colon commands. +define CMDS "|show|low_reject|high_reject|nreject|grow|errors|vshow|constant|\ +fit|tolerance|maxiter|variables|data|page|results|" + +define SHOW 1 # Show fit information +define LOW_REJECT 2 # Set or show lower rejection factor +define HIGH_REJECT 3 # Set or show upper rejection factor +define NREJECT 4 # Set or show rejection iterations +define GROW 5 # Set or show rejection growing radius +define ERRORS 6 # Show fit errors +define VSHOW 7 # Show verbose information +define CONSTANT 8 # Set constant parameter +define FIT 9 # Set fitting parameter +define TOL 10 # Set or show fitting tolerance +define MAXITER 11 # Set or show max number of iterations +define VARIABLES 12 # List the variables +define DATA 13 # List of data +define PAGE 14 # Page through a file +define RESULTS 15 # List the results of the fit + + +# ING_COLON -- Processes colon commands. The common flags and newgraph +# signal changes in fitting parameters or the need to redraw the graph. + +procedure ing_colon$t (in, cmdstr, gp, gt, nl, x, y, wts, names, npts, nvars, + len_name, newgraph) + +pointer in # INLFIT pointer +char cmdstr[ARB] # Command string +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer for error listing +PIXEL x[ARB] # Independent variabels (npts * nvars) +PIXEL y[npts] # dependent variables +PIXEL wts[npts] # Weights +char names[ARB] # Object names +int npts # Number of data points +int nvars # Number of variables +int len_name # Length of object name +int newgraph # New graph ? + +int ncmd, ival +PIXEL fval +pointer sp, cmd + +int nscan(), strdic() +int in_geti() +PIXEL in_get$t() + +begin + # Allocate string space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Use formated scan to parse the command string. + # The first word is the command and it may be minimum match + # abbreviated with the list of commands. + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, CMDS) + + # Branch on command code. + switch (ncmd) { + case SHOW: # :show - Show the values of the fitting parameters. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_show$t (in, "STDOUT") + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_show$t (in, Memc[cmd]) + } then + call erract (EA_WARN) + } + + case LOW_REJECT: # :low_reject - List or set lower rejection factor. + call garg$t (fval) + if (nscan() == 1) { + call printf ("low_reject = %g\n") + call parg$t (in_get$t (in, INLLOW)) + } else + call in_put$t (in, INLLOW, fval) + + case HIGH_REJECT: # :high_reject - List or set high rejection factor. + call garg$t (fval) + if (nscan() == 1) { + call printf ("high_reject = %g\n") + call parg$t (in_get$t (in, INLHIGH)) + } else + call in_put$t (in, INLHIGH, fval) + + case NREJECT: # :nreject - List or set the rejection iterations. + call gargi (ival) + if (nscan() == 1) { + call printf ("nreject = %d\n") + call pargi (in_geti (in, INLNREJECT)) + } else + call in_puti (in, INLNREJECT, ival) + + case GROW: # :grow - List or set the rejection growing. + call garg$t (fval) + if (nscan() == 1) { + call printf ("grow = %g\n") + call parg$t (in_get$t (in, INLGROW)) + } else + call in_put$t (in, INLGROW, fval) + + case ERRORS: # :errors - print errors analysis of fit + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_show$t (in, "STDOUT") + call ing_errors$t (in, "STDOUT", nl, x, y, wts, npts, nvars) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_show$t (in, Memc[cmd]) + call ing_errors$t (in, Memc[cmd], nl, x, y, wts, npts, + nvars) + } then + call erract (EA_WARN) + } + + case VSHOW: # Verbose list of the fitting parameters and results. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_vshow$t (in, "STDOUT", nl, x, y, wts, names, npts, + nvars, len_name, gt) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_vshow$t (in, Memc[cmd], nl, x, y, wts, names, + npts, nvars, len_name, gt) + } then + call erract (EA_WARN) + } + + case CONSTANT: # Set constant parameter. + call ing_change$t (in, CONSTANT) + + case FIT: # Set fitting parameter. + call ing_change$t (in, FIT) + + case TOL: # Set or show tolerance. + call garg$t (fval) + if (nscan() == 1) { + call printf ("tol = %g\n") + call parg$t (in_get$t (in, INLTOLERANCE)) + } else + call in_put$t (in, INLTOLERANCE, fval) + + case MAXITER: # Set or show max number of iterations. + call gargi (ival) + if (nscan() == 1) { + call printf ("maxiter = %d\n") + call pargi (in_geti (in, INLMAXITER)) + } else + call in_puti (in, INLMAXITER, ival) + + case VARIABLES: # Show the list of variables. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_variables$t (in, "STDOUT", nvars) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_variables$t (in, Memc[cmd], nvars) + } then + call erract (EA_WARN) + } + + case DATA: # List the raw data. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_data$t (in, "STDOUT", x, names, npts, nvars, len_name) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_data$t (in, Memc[cmd], x, names, npts, nvars, + len_name) + } then + call erract (EA_WARN) + } + + case PAGE: # Page through a file. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) + call printf ("File to be paged is undefined\n") + else + call gpagefile (gp, Memc[cmd], "") + + case RESULTS: # List the results of the fit. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_results$t (in, "STDOUT", nl, x, y, wts, names, npts, + nvars, len_name) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_results$t (in, Memc[cmd], nl, x, y, wts, names, + npts, nvars, len_name) + } then + call erract (EA_WARN) + } + + default: # User definable action. + call ing_ucolon$t (in, gp, gt, nl, x, y, wts, npts, nvars, newgraph) + } + + # Free memory + call sfree (sp) +end + + +# ING_CHANGE -- Change fitting parameter into constant parameter, and +# viceversa. Parameters can be specified either by a name, supplied in +# the parameter labels, or just by a sequence number. + +procedure ing_change$t (in, type) + +pointer in # INLFIT descriptor +int type # parameter type (fit, constant) + +bool isfit +int ip, pos, number, npars +PIXEL $tval +pointer param, value, pname +pointer pvalues, plist, plabels +pointer sp + +bool streq() +int ctoi(), cto$t() +int strdic() +int in_geti() +pointer in_getp() + +begin + # Allocate string space. + call smark (sp) + call salloc (param, SZ_LINE, TY_CHAR) + call salloc (value, SZ_LINE, TY_CHAR) + call salloc (pname, SZ_LINE, TY_CHAR) + call salloc (plabels, SZ_LINE, TY_CHAR) + + # Get parameter name. + Memc[param] = EOS + call gargwrd (Memc[param], SZ_LINE) + if (streq (Memc[param], "")) { + call eprintf ("Parameter not specified\n") + call sfree (sp) + return + } + + # Try to find the parameter name in the parameter labels. + call in_gstr (in, INLPLABELS, Memc[plabels], SZ_LINE) + number = strdic (Memc[param], Memc[pname], SZ_LINE, Memc[plabels]) + + # Try to find the parameter by number if it was not found + # by name in the dictionary. + if (number == 0) { + ip = 1 + if (ctoi (Memc[param], ip, number) == 0) { + call eprintf ("Parameter not found (%s)\n") + call pargstr (Memc[param]) + call sfree (sp) + return + } + } + + # Test parameter number. + npars = in_geti (in, INLNPARAMS) + if (number < 1 || number > npars) { + call eprintf ("Parameter out of range (%d)\n") + call pargi (number) + call sfree (sp) + return + } + + # Get pointers to parameter values and list. + pvalues = in_getp (in, INLPARAM) + plist = in_getp (in, INLPLIST) + + # Get new value if specified. Otherwise assume + # old parameter value. + Memc[value] = EOS + call gargwrd (Memc[value], SZ_LINE) + if (streq (Memc[value], "")) + $tval = Mem$t[pvalues + number - 1] + else { + ip = 1 + if (cto$t (Memc[value], ip, $tval) == 0) { + call eprintf ("Bad parameter value (%s)\n") + call pargstr (Memc[value]) + call sfree (sp) + return + } + } + + # Update parameter value. + Mem$t[pvalues + number - 1] = $tval + + # Find the parameter position in the parameter list. + do pos = 1, npars { + if (Memi[plist + pos - 1] >= number || + Memi[plist + pos - 1] == 0) + break + } + + # Insert or remove parameter from the parameter list + # according with its type, i.e., with the type of change. + # The list is not changed if it's not necesary to do so. + + if (type == FIT) { + if (Memi[plist + pos - 1] != number) { + do ip = npars, pos + 1, -1 + Memi[plist + ip - 1] = Memi[plist + ip - 2] + Memi[plist + pos - 1] = number + call in_puti (in, INLNFPARAMS, in_geti (in, INLNFPARAMS) + 1) + } + isfit = true + } else { + if (Memi[plist + pos - 1] == number) { + do ip = pos, npars - 1 + Memi[plist + ip - 1] = Memi[plist + ip] + Memi[plist + npars - 1] = 0 + call in_puti (in, INLNFPARAMS, in_geti (in, INLNFPARAMS) - 1) + } + isfit = false + } + + # Print setting. + call printf ("(%s) changed to %s parameter, with value=%g\n") + call pargstr (Memc[pname]) + if (isfit) + call pargstr ("fitting") + else + call pargstr ("constant") + call parg$t ($tval) + + # Free memory. + call sfree (sp) +end -- cgit