Repatch (from linux) of OSX IRAF

1 files changed, 288 insertions, 0 deletions

diff --git a/math/gsurfit/gs_fder.gx b/math/gsurfit/gs_fder.gx
new file mode 100644
index 00000000..1620e189
--- /dev/null
+++ b/math/gsurfit/gs_fder.gx
@@ -0,0 +1,288 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <math/gsurfit.h>
+
+# GS_DERPOLY -- Evaluate the new polynomial derivative surface.
+
+procedure $tgs_derpoly (coeff, x, y, zfit, npts, xterms, xorder, yorder, nxder,
+	nyder, k1x, k2x, k1y, k2y)
+
+PIXEL	coeff[ARB]		# 1D array of coefficients
+PIXEL	x[npts]			# x values of points to be evaluated
+PIXEL	y[npts]
+PIXEL	zfit[npts]		# the fitted points
+int	npts			# number of points to be evaluated
+int	xterms			# cross terms ?
+int	xorder,yorder		# order of the polynomials in x and y
+int	nxder,nyder		# order of the derivatives in x and y
+PIXEL	k1x, k2x		# normalizing constants
+PIXEL	k1y, k2y
+
+int	i, k, cptr, maxorder, xincr
+pointer	sp, xb, yb, xbptr, ybptr, accum
+
+begin
+	# allocate temporary space for the basis functions
+	call smark (sp)
+	$if (datatype == r)
+	call salloc (xb, xorder * npts, TY_REAL)
+	call salloc (yb, yorder * npts, TY_REAL)
+	call salloc (accum, npts, TY_REAL)
+	$else
+	call salloc (xb, xorder * npts, TY_DOUBLE)
+	call salloc (yb, yorder * npts, TY_DOUBLE)
+	call salloc (accum, npts, TY_DOUBLE)
+	$endif
+
+	# calculate basis functions
+	call $tgs_dpol (x, npts, xorder, nxder, k1x, k2x, Mem$t[xb])
+	call $tgs_dpol (y, npts, yorder, nyder, k1y, k2y, Mem$t[yb])
+
+	# accumulate the output vector
+	cptr = 0
+	call aclr$t (zfit, npts)
+	if (xterms != GS_XNONE) {
+	    maxorder = max (xorder + 1, yorder + 1)
+	    xincr = xorder
+	    ybptr = yb
+	    do i = 1, yorder {
+	        call aclr$t (Mem$t[accum], npts)
+	        xbptr = xb
+	        do k = 1, xincr {
+		    $if (datatype == r)
+		    call awsu$t (Mem$t[accum], Mem$t[xbptr], Mem$t[accum], npts,
+		        1.0, coeff[cptr+k])
+		    $else
+		    call awsu$t (Mem$t[accum], Mem$t[xbptr], Mem$t[accum], npts,
+		        1.0d0, coeff[cptr+k])
+		    $endif
+		    xbptr = xbptr + npts
+	        }
+	        call gs_asumvp$t (Mem$t[accum], Mem$t[ybptr], zfit, zfit, npts)
+	        cptr = cptr + xincr
+	        ybptr = ybptr + npts
+		switch (xterms) {
+		case GS_XHALF:
+		    if ((i + xorder + 1) > maxorder)
+			xincr = xincr - 1
+		default:
+		    ;
+		}
+	    }
+	} else {
+	    call amul$t (Mem$t[xb], Mem$t[yb], zfit, npts)
+	    call amulk$t (zfit, coeff[1], zfit, npts)
+	    xbptr = xb + npts
+	    do k = 1, xorder - 1 {
+		$if (datatype == r)
+		call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k+1])
+		$else
+		call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k+1])
+		$endif
+		xbptr = xbptr + npts
+	    }
+	    ybptr = yb + npts
+	    do k = 1, yorder - 1 {
+		$if (datatype == r)
+		call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k])
+		$else
+		call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0,
+		    coeff[xorder+k])
+		$endif
+		ybptr = ybptr + npts
+	    }
+	}
+
+
+	call sfree (sp)
+end
+
+# GS_DERCHEB -- Evaluate the new Chebyshev polynomial derivative surface.
+
+procedure $tgs_dercheb (coeff, x, y, zfit, npts, xterms, xorder, yorder,
+	nxder, nyder, k1x, k2x, k1y, k2y)
+
+PIXEL	coeff[ARB]		# 1D array of coefficients
+PIXEL	x[npts]			# x values of points to be evaluated
+PIXEL	y[npts]
+PIXEL	zfit[npts]		# the fitted points
+int	npts			# number of points to be evaluated
+int	xterms			# cross terms ?
+int	xorder,yorder		# order of the polynomials in x and y
+int	nxder,nyder		# order of the derivatives in x and y
+PIXEL	k1x, k2x		# normalizing constants
+PIXEL	k1y, k2y
+
+int	i, k, cptr, maxorder, xincr
+pointer	sp, xb, yb, xbptr, ybptr, accum
+
+begin
+	# allocate temporary space for the basis functions
+	call smark (sp)
+	$if (datatype == r)
+	call salloc (xb, xorder * npts, TY_REAL)
+	call salloc (yb, yorder * npts, TY_REAL)
+	call salloc (accum, npts, TY_REAL)
+	$else
+	call salloc (xb, xorder * npts, TY_DOUBLE)
+	call salloc (yb, yorder * npts, TY_DOUBLE)
+	call salloc (accum, npts, TY_DOUBLE)
+	$endif
+
+	# calculate basis functions
+	call $tgs_dcheb (x, npts, xorder, nxder, k1x, k2x, Mem$t[xb])
+	call $tgs_dcheb (y, npts, yorder, nyder, k1y, k2y, Mem$t[yb])
+
+	# accumulate thr output vector
+	cptr = 0
+	call aclr$t (zfit, npts)
+	if (xterms != GS_XNONE) {
+	    maxorder = max (xorder + 1, yorder + 1)
+	    xincr = xorder
+	    ybptr = yb
+	    do i = 1, yorder {
+	        call aclr$t (Mem$t[accum], npts)
+	        xbptr = xb
+	        do k = 1, xincr {
+		    $if (datatype == r)
+		    call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts,
+		        1.0, coeff[cptr+k])
+		    $else
+		    call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts,
+		        1.0d0, coeff[cptr+k])
+		    $endif
+		    xbptr = xbptr + npts
+	        }
+	        call gs_asumvp$t (Mem$t[accum], Mem$t[ybptr], zfit, zfit, npts)
+	        cptr = cptr + xincr
+	        ybptr = ybptr + npts
+		switch (xterms) {
+		case GS_XHALF:
+		    if ((i + xorder + 1) > maxorder)
+			xincr = xincr - 1
+		default:
+		    ;
+		}
+	    }
+	} else {
+	    call amul$t (Mem$t[xb], Mem$t[yb], zfit, npts)
+	    call amulk$t (zfit, coeff[1], zfit, npts)
+	    xbptr = xb + npts
+	    do k = 1, xorder - 1 {
+		$if (datatype == r)
+		call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k+1])
+		$else
+		call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k+1])
+		$endif
+		xbptr = xbptr + npts
+	    }
+	    ybptr = yb + npts
+	    do k = 1, yorder - 1 {
+		$if (datatype == r)
+		call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k])
+		$else
+		call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0,
+		    coeff[xorder+k])
+		$endif
+		ybptr = ybptr + npts
+	    }
+	}
+
+	# free temporary space
+	call sfree (sp)
+end
+
+
+# GS_DERLEG -- Evaluate the new Legendre polynomial derivative surface.
+
+procedure $tgs_derleg (coeff, x, y, zfit, npts, xterms, xorder, yorder,
+	nxder, nyder, k1x, k2x, k1y, k2y)
+
+PIXEL	coeff[ARB]		# 1D array of coefficients
+PIXEL	x[npts]			# x values of points to be evaluated
+PIXEL	y[npts]
+PIXEL	zfit[npts]		# the fitted points
+int	npts			# number of points to be evaluated
+int	xterms			# cross terms ?
+int	xorder,yorder		# order of the polynomials in x and y
+int	nxder,nyder		# order of the derivatives in x and y
+PIXEL	k1x, k2x		# normalizing constants
+PIXEL	k1y, k2y
+
+int	i, k, cptr, maxorder, xincr
+pointer	sp, xb, yb, accum, xbptr, ybptr
+
+begin
+	# allocate temporary space for the basis functions
+	call smark (sp)
+	$if (datatype == r)
+	call salloc (xb, xorder * npts, TY_REAL)
+	call salloc (yb, yorder * npts, TY_REAL)
+	call salloc (accum, npts, TY_REAL)
+	$else
+	call salloc (xb, xorder * npts, TY_DOUBLE)
+	call salloc (yb, yorder * npts, TY_DOUBLE)
+	call salloc (accum, npts, TY_DOUBLE)
+	$endif
+
+	# calculate basis functions
+	call $tgs_dleg (x, npts, xorder, nxder, k1x, k2x, Mem$t[xb])
+	call $tgs_dleg (y, npts, yorder, nyder, k1y, k2y, Mem$t[yb])
+
+	cptr = 0
+	call aclr$t (zfit, npts)
+	if (xterms != GS_XNONE) {
+	    maxorder = max (xorder + 1, yorder + 1)
+	    xincr = xorder
+	    ybptr = yb
+	    do i = 1, yorder {
+	        xbptr = xb
+	        call aclr$t (Mem$t[accum], npts)
+	        do k = 1, xincr {
+		    $if (datatype == r)
+		    call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts,
+		        1.0, coeff[cptr+k])
+		    $else
+		    call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts,
+		        1.0d0, coeff[cptr+k])
+		    $endif
+		    xbptr = xbptr + npts
+	        }
+	        call gs_asumvp$t (Mem$t[accum], Mem$t[ybptr], zfit, zfit, npts)
+	        cptr = cptr + xincr
+	        ybptr = ybptr + npts
+		switch (xterms) {
+		case GS_XHALF:
+		    if ((i + xorder + 1) > maxorder)
+			xincr = xincr - 1
+		default:
+		    ;
+		}
+	    }
+	} else {
+	    call amul$t (Mem$t[xb], Mem$t[yb], zfit, npts)
+	    call amulk$t (zfit, coeff[1], zfit, npts)
+	    xbptr = xb + npts
+	    do k = 1, xorder - 1 {
+		$if (datatype == r)
+		call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k+1])
+		$else
+		call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k+1])
+		$endif
+		xbptr = xbptr + npts
+	    }
+	    ybptr = yb + npts
+	    do k = 1, yorder - 1 {
+		$if (datatype == r)
+		call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k])
+		$else
+		call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0,
+		    coeff[xorder+k])
+		$endif
+		ybptr = ybptr + npts
+	    }
+	}
+
+	# free temporary space
+	call sfree (sp)
+end