Initial commit

1 files changed, 362 insertions, 0 deletions

diff --git a/pkg/xtools/inlfit/ingcolonr.x b/pkg/xtools/inlfit/ingcolonr.x
new file mode 100644
index 00000000..b9179fc6
--- /dev/null
+++ b/pkg/xtools/inlfit/ingcolonr.x
@@ -0,0 +1,362 @@
+include	<gset.h>
+include	<error.h>
+include	<pkg/inlfit.h>
+
+# 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_colonr (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
+real	x[ARB]				# Independent variabels (npts * nvars)
+real	y[npts]				# dependent variables
+real	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
+real	fval
+pointer	sp, cmd
+
+int	nscan(), strdic()
+int	in_geti()
+real	in_getr()
+
+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_showr (in, "STDOUT")
+		call greactivate (gp, AW_PAUSE)
+	    } else {
+		iferr {
+		    call ing_title (in, Memc[cmd], gt)
+		    call ing_showr (in, Memc[cmd])
+		} then
+		    call erract (EA_WARN)
+	    }
+
+	case LOW_REJECT: # :low_reject - List or set lower rejection factor.
+	    call gargr (fval)
+	    if (nscan() == 1) {
+		call printf ("low_reject = %g\n")
+		    call pargr (in_getr (in, INLLOW))
+	    } else
+		call in_putr (in, INLLOW, fval)
+
+	case HIGH_REJECT: # :high_reject - List or set high rejection factor.
+	    call gargr (fval)
+	    if (nscan() == 1) {
+		call printf ("high_reject = %g\n")
+		    call pargr (in_getr (in, INLHIGH))
+	    } else
+		call in_putr (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 gargr (fval)
+	    if (nscan() == 1) {
+		call printf ("grow = %g\n")
+		    call pargr (in_getr (in, INLGROW))
+	    } else
+		call in_putr (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_showr (in, "STDOUT")
+		call ing_errorsr (in, "STDOUT", nl, x, y, wts, npts, nvars)
+		call greactivate (gp, AW_PAUSE)
+	    } else {
+		iferr {
+		    call ing_title (in, Memc[cmd], gt)
+		    call ing_showr (in, Memc[cmd])
+		    call ing_errorsr (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_vshowr (in, "STDOUT", nl, x, y, wts, names, npts,
+		    nvars, len_name, gt)
+		call greactivate (gp, AW_PAUSE)
+	    } else {
+		iferr {
+		    call ing_vshowr (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_changer (in, CONSTANT)
+
+	case FIT:	# Set fitting parameter.
+	    call ing_changer (in, FIT)
+
+	case TOL:	# Set or show tolerance.
+	    call gargr (fval)
+	    if (nscan() == 1) {
+		call printf ("tol = %g\n")
+		    call pargr (in_getr (in, INLTOLERANCE))
+	    } else
+		call in_putr (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_variablesr (in, "STDOUT", nvars)
+		call greactivate (gp, AW_PAUSE)
+	    } else {
+		iferr {
+		    call ing_title (in, Memc[cmd], gt)
+		    call ing_variablesr (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_datar (in, "STDOUT", x, names, npts, nvars, len_name)
+		call greactivate (gp, AW_PAUSE)
+	    } else {
+		iferr {
+		    call ing_title (in, Memc[cmd], gt)
+		    call ing_datar (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_resultsr (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_resultsr (in, Memc[cmd], nl, x, y, wts, names,
+		        npts, nvars, len_name)
+		} then 
+		    call erract (EA_WARN)
+	    }
+
+	default:	# User definable action.
+	    call ing_ucolonr (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_changer (in, type)
+
+pointer	in			# INLFIT descriptor
+int	type			# parameter type (fit, constant)
+
+bool	isfit
+int	ip, pos, number, npars
+real	rval
+pointer	param, value, pname
+pointer	pvalues, plist, plabels
+pointer	sp
+
+bool	streq()
+int	ctoi(), ctor()
+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], ""))
+	    rval = Memr[pvalues + number - 1]
+	else {
+	    ip = 1
+	    if (ctor (Memc[value], ip, rval) == 0) {
+	        call eprintf ("Bad parameter value (%s)\n")
+		    call pargstr (Memc[value])
+	        call sfree (sp)
+	        return
+	    }
+	}
+
+	# Update parameter value.
+	Memr[pvalues + number - 1] = rval
+
+	# 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 pargr (rval)
+
+	# Free memory.
+	call sfree (sp)
+end