Repatch (from linux) of OSX IRAF

1 files changed, 226 insertions, 0 deletions

diff --git a/pkg/xtools/icfit/icggraph.gx b/pkg/xtools/icfit/icggraph.gx
new file mode 100644
index 00000000..393582db
--- /dev/null
+++ b/pkg/xtools/icfit/icggraph.gx
@@ -0,0 +1,226 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<gset.h>
+include	<pkg/gtools.h>
+include	"names.h"
+include	"icfit.h"
+
+define	NGRAPH		100		# Number of fit points to graph
+define	MSIZE		2.		# Mark size
+
+# ICG_GRAPH -- Graph data and fit.
+
+procedure icg_graph$t (ic, gp, gt, cv, x, y, wts, npts)
+
+pointer	ic				# ICFIT pointer
+pointer	gp				# GIO pointer
+pointer	gt				# GTOOLS pointers
+pointer	cv				# Curfit pointer
+PIXEL	x[npts]				# Independent variable
+PIXEL	y[npts]				# Dependent variable
+PIXEL	wts[npts]			# Weights
+int	npts				# Number of points
+
+pointer	xout, yout
+real	size
+
+begin
+	call malloc (xout, npts, TY_PIXEL)
+	call malloc (yout, npts, TY_PIXEL)
+	call icg_axes$t (ic, gt, cv, 1, x, y, Mem$t[xout], npts)
+	call icg_axes$t (ic, gt, cv, 2, x, y, Mem$t[yout], npts)
+	call icg_params$t (ic, cv, x, y, wts, npts, gt)
+
+	call icg_g1$t (ic, gp, gt, Mem$t[xout], Mem$t[yout], wts, npts)
+
+ 	# Symbol size for averaged ranges.
+ 	size = abs(IC_NAVERAGE(ic) * (Mem$t[xout+npts-1] - Mem$t[xout]) / 
+ 	       float(npts))
+ 
+	if (npts != IC_NFIT(ic)) {
+	    if ((abs (IC_NAVERAGE(ic)) > 1) || (IC_NREJECT(ic) > 0)) {
+	        call realloc (xout, IC_NFIT(ic), TY_PIXEL)
+		call realloc (yout, IC_NFIT(ic), TY_PIXEL)
+		call icg_axes$t (ic, gt, cv, 1, Mem$t[IC_XFIT(ic)],
+		    Mem$t[IC_YFIT(ic)], Mem$t[xout], IC_NFIT(ic))
+		call icg_axes$t (ic, gt, cv, 2, Mem$t[IC_XFIT(ic)],
+		    Mem$t[IC_YFIT(ic)], Mem$t[yout], IC_NFIT(ic))
+		call icg_g2$t (ic, gp, gt, Mem$t[xout], Mem$t[yout],
+		    IC_NFIT(ic), size)
+	    }
+
+	} else if (IC_NREJECT(ic) > 0)
+	    call icg_g2$t (ic, gp, gt, Mem$t[xout], Mem$t[yout], npts, size)
+
+	call icg_gf$t (ic, gp, gt, cv, max (npts, NGRAPH))
+
+	# Mark the the sample regions.
+
+	call icg_sample$t (ic, gp, gt, x, npts, 1)
+
+	# Send the wcs to the gui.
+	call ic_gui (ic, "wcs")
+
+	call mfree (xout, TY_PIXEL)
+	call mfree (yout, TY_PIXEL)
+end
+
+procedure icg_g1$t (ic, gp, gt, x, y, wts, npts)
+
+pointer	ic				# ICFIT pointer
+pointer	gp				# GIO pointer
+pointer	gt				# GTOOLS pointer
+PIXEL	x[npts]				# Ordinates
+PIXEL	y[npts]				# Abscissas
+PIXEL	wts[npts]			# Weights
+int	npts				# Number of points
+
+int	i
+pointer	sp, xr, yr, xr1, yr1, gt1
+
+begin
+	call smark (sp)
+	call salloc (xr, npts, TY_REAL)
+	call salloc (yr, npts, TY_REAL)
+	call salloc (xr1, 2, TY_REAL)
+	call salloc (yr1, 2, TY_REAL)
+	call acht$tr (x, Memr[xr], npts)
+	call acht$tr (y, Memr[yr], npts)
+
+	call gt_copy (gt, gt1)
+	call gt_sets (gt1, GTTYPE, "mark")
+	call gt_sets (gt1, GTMARK, "cross")
+
+	if (IC_OVERPLOT(ic) == NO) {
+	    # Start a new plot.
+
+	    call gclear (gp)
+
+	    # Set the graph scale and axes.
+
+	    call gascale (gp, Memr[xr], npts, 1)
+	    call gascale (gp, Memr[yr], npts, 2)
+	    call gt_swind (gp, gt)
+	    call gt_labax (gp, gt)
+	}
+
+	if (IC_OVERPLOT(ic) == NO) {
+	    Memr[xr1] = Memr[xr]
+	    Memr[yr1] = Memr[yr]
+	    do i = 1, npts {
+		if (wts[i] == 0.) {
+		    call gt_plot (gp, gt1, Memr[xr+i-1], Memr[yr+i-1], 1) 
+		} else {
+		    Memr[xr1+1] = Memr[xr+i-1]
+		    Memr[yr1+1] = Memr[yr+i-1]
+		    call gt_plot (gp, gt, Memr[xr1], Memr[yr1], 2)
+		    Memr[xr1] = Memr[xr1+1]
+		    Memr[yr1] = Memr[yr1+1]
+		}
+	    }
+	}
+
+	# Reset status flags.
+
+	IC_OVERPLOT(ic) = NO
+
+	call sfree (sp)
+	call gt_free (gt1)
+end
+
+procedure icg_g2$t (ic, gp, gt, x, y, npts, size)
+
+pointer	ic			# ICFIT pointer
+pointer	gp			# GIO pointer
+pointer	gt			# GTOOLS pointer
+PIXEL	x[npts], y[npts]	# Data points
+int	npts			# Number of data points
+real	size			# Symbol size
+
+int	i
+pointer	sp, xr, yr, gt1
+
+begin
+	call smark (sp)
+	call salloc (xr, npts, TY_REAL)
+	call salloc (yr, npts, TY_REAL)
+	call acht$tr (x, Memr[xr], npts)
+	call acht$tr (y, Memr[yr], npts)
+
+	call gt_copy (gt, gt1)
+	call gt_sets (gt1, GTTYPE, "mark")
+
+	# Mark the sample points.
+
+	if (abs (IC_NAVERAGE(ic)) > 1) {
+	    call gt_sets (gt1, GTMARK, "plus")
+ 	    call gt_setr (gt1, GTXSIZE, -size)
+	    call gt_setr (gt1, GTYSIZE, 1.)
+	    call gt_plot (gp, gt1, Memr[xr], Memr[yr], npts)
+	}
+
+	# Mark the rejected points.
+
+	if (IC_NREJECT(ic) > 0 && IC_MARKREJ(ic) == YES) {
+	    call gt_sets (gt1, GTMARK, "diamond")
+	    call gt_setr (gt1, GTXSIZE, MSIZE)
+	    call gt_setr (gt1, GTYSIZE, MSIZE)
+	    do i = 1, npts {
+		if (Memi[IC_REJPTS(ic)+i-1] == YES)
+	            call gt_plot (gp, gt1, Memr[xr+i-1], Memr[yr+i-1], 1)
+	    }
+	}
+
+	call gt_free (gt1)
+	call sfree (sp)
+end
+
+procedure icg_gf$t (ic, gp, gt, cv, npts)
+
+pointer	ic			# ICFIT pointer
+pointer	gp			# GIO pointer
+pointer	gt			# GTOOL pointer
+pointer	cv			# CURFIT pointer
+int	npts			# Number of points to plot
+
+pointer	sp, xr, yr, x, y, xo, yo, gt1
+int	i
+PIXEL	dx
+
+begin
+	if (IC_FITERROR(ic) == YES)
+	    return
+
+	call smark (sp)
+
+	call salloc (xr, npts, TY_REAL)
+	call salloc (yr, npts, TY_REAL)
+	call salloc (x,  npts, TY_PIXEL)
+	call salloc (y,  npts, TY_PIXEL)
+	call salloc (xo, npts, TY_PIXEL)
+	call salloc (yo, npts, TY_PIXEL)
+
+	# Generate vector of independent variable values
+	dx = (IC_XMAX(ic) - IC_XMIN(ic)) / (npts - 1)
+	do i = 1, npts
+	    Mem$t[x+i-1] = IC_XMIN(ic) + (i-1) * dx
+
+	# Calculate vector of fit values. 
+	call $tcvvector (cv, Mem$t[x], Mem$t[y], npts)
+
+	# Convert to user function or transpose axes.  Change type to reals
+	# for plotting.
+	call icg_axes$t (ic, gt, cv, 1, Mem$t[x], Mem$t[y], Mem$t[xo], npts)
+	call icg_axes$t (ic, gt, cv, 2, Mem$t[x], Mem$t[y], Mem$t[yo], npts)
+	call acht$tr (Mem$t[xo], Memr[xr], npts)
+	call acht$tr (Mem$t[yo], Memr[yr], npts)
+
+	call gt_copy (gt, gt1)
+	call gt_sets (gt1, GTTYPE, "line")
+	call gt_seti (gt1, GTLINE, GL_DASHED)
+	call gt_seti (gt1, GTCOLOR, max (0, min (9, IC_COLOR(ic))))
+	call gt_plot (gp, gt1, Memr[xr], Memr[yr], npts)
+	call gt_free (gt1)
+
+	call sfree (sp)
+end