1 files changed, 457 insertions, 0 deletions
diff --git a/pkg/images/tv/iis/src/zscale.x b/pkg/images/tv/iis/src/zscale.x
new file mode 100644
index 00000000..bfb0b116
--- /dev/null
+++ b/pkg/images/tv/iis/src/zscale.x
@@ -0,0 +1,457 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<imhdr.h>
+
+.help zscale
+.nf ___________________________________________________________________________
+ZSCALE -- Compute the optimal Z1, Z2 (range of greyscale values to be
+displayed) of an image.  For efficiency a statistical subsample of an image
+is used.  The pixel sample evenly subsamples the image in x and y.  The entire
+image is used if the number of pixels in the image is smaller than the desired
+sample.
+
+The sample is accumulated in a buffer and sorted by greyscale value.
+The median value is the central value of the sorted array.  The slope of a
+straight line fitted to the sorted sample is a measure of the standard
+deviation of the sample about the median value.  Our algorithm is to sort
+the sample and perform an iterative fit of a straight line to the sample,
+using pixel rejection to omit gross deviants near the endpoints.  The fitted
+straight line is the transfer function used to map image Z into display Z.
+If more than half the pixels are rejected the full range is used.  The slope
+of the fitted line is divided by the user-supplied contrast factor and the
+final Z1 and Z2 are computed, taking the origin of the fitted line at the
+median value.
+.endhelp ______________________________________________________________________
+
+define	MIN_NPIXELS	5		# smallest permissible sample
+define	MAX_REJECT	0.5		# max frac. of pixels to be rejected
+define	GOOD_PIXEL	0		# use pixel in fit
+define	BAD_PIXEL	1		# ignore pixel in all computations
+define	REJECT_PIXEL	2		# reject pixel after a bit
+define	KREJ		2.5		# k-sigma pixel rejection factor
+define	MAX_ITERATIONS	5		# maximum number of fitline iterations
+
+
+# ZSCALE -- Sample the image and compute Z1 and Z2.
+
+procedure zscale (im, z1, z2, contrast, optimal_sample_size, len_stdline)
+
+pointer	im			# image to be sampled
+real	z1, z2			# output min and max greyscale values
+real	contrast		# adj. to slope of transfer function
+int	optimal_sample_size	# desired number of pixels in sample
+int	len_stdline		# optimal number of pixels per line
+
+int	npix, minpix, ngoodpix, center_pixel, ngrow
+real	zmin, zmax, median
+real	zstart, zslope
+pointer	sample, left
+int	zsc_sample_image(), zsc_fit_line()
+
+begin
+	# Subsample the image.
+	npix = zsc_sample_image (im, sample, optimal_sample_size, len_stdline)
+	center_pixel = max (1, (npix + 1) / 2)
+
+	# Sort the sample, compute the minimum, maximum, and median pixel
+	# values.
+
+	call asrtr (Memr[sample], Memr[sample], npix)
+	zmin = Memr[sample]
+	zmax = Memr[sample+npix-1]
+
+	# The median value is the average of the two central values if there 
+	# are an even number of pixels in the sample.
+
+	left = sample + center_pixel - 1
+	if (mod (npix, 2) == 1 || center_pixel >= npix)
+	    median = Memr[left]
+	else
+	    median = (Memr[left] + Memr[left+1]) / 2
+
+	# Fit a line to the sorted sample vector.  If more than half of the
+	# pixels in the sample are rejected give up and return the full range.
+	# If the user-supplied contrast factor is not 1.0 adjust the scale
+	# accordingly and compute Z1 and Z2, the y intercepts at indices 1 and
+	# npix.
+
+	minpix = max (MIN_NPIXELS, int (npix * MAX_REJECT))
+	ngrow = max (1, nint (npix * .01))
+	ngoodpix = zsc_fit_line (Memr[sample], npix, zstart, zslope,
+	    KREJ, ngrow, MAX_ITERATIONS)
+
+	if (ngoodpix < minpix) {
+	    z1 = zmin
+	    z2 = zmax
+	} else {
+	    if (contrast > 0)
+		zslope = zslope / contrast
+	    z1 = max (zmin, median - (center_pixel - 1) * zslope)
+	    z2 = min (zmax, median + (npix - center_pixel) * zslope)
+	}
+
+	call mfree (sample, TY_REAL)
+end
+
+
+# ZSC_SAMPLE_IMAGE -- Extract an evenly gridded subsample of the pixels from
+# a two-dimensional image into a one-dimensional vector.
+
+int procedure zsc_sample_image (im, sample, optimal_sample_size, len_stdline)
+
+pointer	im			# image to be sampled
+pointer	sample			# output vector containing the sample
+int	optimal_sample_size	# desired number of pixels in sample
+int	len_stdline		# optimal number of pixels per line
+
+int	ncols, nlines, col_step, line_step, maxpix, line
+int	opt_npix_per_line, npix_per_line
+int	opt_nlines_in_sample, min_nlines_in_sample, max_nlines_in_sample
+pointer	op
+pointer	imgl2r()
+
+begin
+	ncols  = IM_LEN(im,1)
+	nlines = IM_LEN(im,2)
+
+	# Compute the number of pixels each line will contribute to the sample,
+	# and the subsampling step size for a line.  The sampling grid must
+	# span the whole line on a uniform grid.
+
+	opt_npix_per_line = min (ncols, len_stdline)
+	col_step = (ncols + opt_npix_per_line-1) / opt_npix_per_line
+	npix_per_line = (ncols + col_step-1) / col_step
+
+	# Compute the number of lines to sample and the spacing between lines.
+	# We must ensure that the image is adequately sampled despite its
+	# size, hence there is a lower limit on the number of lines in the
+	# sample.  We also want to minimize the number of lines accessed when
+	# accessing a large image, because each disk seek and read is expensive.
+	# The number of lines extracted will be roughly the sample size divided
+	# by len_stdline, possibly more if the lines are very short.
+
+	min_nlines_in_sample = max (1, optimal_sample_size / len_stdline)
+	opt_nlines_in_sample = max(min_nlines_in_sample, min(nlines,
+	    (optimal_sample_size + npix_per_line-1) / npix_per_line))
+	line_step = max (1, nlines / (opt_nlines_in_sample))
+	max_nlines_in_sample = (nlines + line_step-1) / line_step
+
+	# Allocate space for the output vector.  Buffer must be freed by our
+	# caller.
+
+	maxpix = npix_per_line * max_nlines_in_sample
+	call malloc (sample, maxpix, TY_REAL)
+
+# call eprintf ("sample: x[%d:%d:%d] y[%d:%d:%d]\n")
+# call pargi(1);call pargi(ncols); call pargi(col_step)
+# call pargi((line_step+1)/2); call pargi(nlines); call pargi(line_step)
+
+	# Extract the vector.
+	op = sample
+	do line = (line_step + 1) / 2, nlines, line_step {
+	    call zsc_subsample (Memr[imgl2r(im,line)], Memr[op],
+		npix_per_line, col_step)
+	    op = op + npix_per_line
+	    if (op - sample + npix_per_line > maxpix)
+		break
+	}
+
+	return (op - sample)
+end
+
+
+# ZSC_SUBSAMPLE -- Subsample an image line.  Extract the first pixel and
+# every "step"th pixel thereafter for a total of npix pixels.
+
+procedure zsc_subsample (a, b, npix, step)
+
+real	a[ARB]
+real	b[npix]
+int	npix, step
+int	ip, i
+
+begin
+	if (step <= 1)
+	    call amovr (a, b, npix)
+	else {
+	    ip = 1
+	    do i = 1, npix {
+		b[i] = a[ip]
+		ip = ip + step
+	    }
+	}
+end
+
+
+# ZSC_FIT_LINE -- Fit a straight line to a data array of type real.  This is
+# an iterative fitting algorithm, wherein points further than ksigma from the
+# current fit are excluded from the next fit.  Convergence occurs when the
+# next iteration does not decrease the number of pixels in the fit, or when
+# there are no pixels left.  The number of pixels left after pixel rejection
+# is returned as the function value.
+
+int procedure zsc_fit_line (data, npix, zstart, zslope, krej, ngrow, maxiter)
+
+real	data[npix]		# data to be fitted
+int	npix			# number of pixels before rejection
+real	zstart			# Z-value of pixel data[1]	(output)
+real	zslope			# dz/pixel			(output)
+real	krej			# k-sigma pixel rejection factor
+int	ngrow			# number of pixels of growing
+int	maxiter			# max iterations
+
+int	i, ngoodpix, last_ngoodpix, minpix, niter
+real	xscale, z0, dz, x, z, mean, sigma, threshold
+double	sumxsqr, sumxz, sumz, sumx, rowrat
+pointer	sp, flat, badpix, normx
+int	zsc_reject_pixels(), zsc_compute_sigma()
+
+begin
+	call smark (sp)
+
+	if (npix <= 0)
+	    return (0)
+	else if (npix == 1) {
+	    zstart = data[1]
+	    zslope = 0.0
+	    return (1)
+	} else
+	    xscale = 2.0 / (npix - 1)
+
+	# Allocate a buffer for data minus fitted curve, another for the
+	# normalized X values, and another to flag rejected pixels.
+
+	call salloc (flat, npix, TY_REAL)
+	call salloc (normx, npix, TY_REAL)
+	call salloc (badpix, npix, TY_SHORT)
+	call aclrs (Mems[badpix], npix)
+
+	# Compute normalized X vector.  The data X values [1:npix] are
+	# normalized to the range [-1:1].  This diagonalizes the lsq matrix
+	# and reduces its condition number.
+
+	do i = 0, npix - 1
+	    Memr[normx+i] = i * xscale - 1.0
+
+	# Fit a line with no pixel rejection.  Accumulate the elements of the
+	# matrix and data vector.  The matrix M is diagonal with
+	# M[1,1] = sum x**2 and M[2,2] = ngoodpix.  The data vector is
+	# DV[1] = sum (data[i] * x[i]) and DV[2] = sum (data[i]).
+
+	sumxsqr = 0
+	sumxz = 0
+	sumx = 0
+	sumz = 0
+
+	do i = 1, npix {
+	    x = Memr[normx+i-1]
+	    z = data[i]
+	    sumxsqr = sumxsqr + (x ** 2)
+	    sumxz   = sumxz + z * x
+	    sumz    = sumz + z
+	}
+# call eprintf ("\t%10g %10g %10g\n")
+# call pargd(sumxsqr); call pargd(sumxz); call pargd(sumz)
+
+	# Solve for the coefficients of the fitted line.
+	z0 = sumz / npix
+	dz = sumxz / sumxsqr
+
+# call eprintf ("fit: z0=%g, dz=%g\n")
+# call pargr(z0); call pargr(dz)
+
+	# Iterate, fitting a new line in each iteration.  Compute the flattened
+	# data vector and the sigma of the flat vector.  Compute the lower and
+	# upper k-sigma pixel rejection thresholds.  Run down the flat array
+	# and detect pixels to be rejected from the fit.  Reject pixels from
+	# the fit by subtracting their contributions from the matrix sums and
+	# marking the pixel as rejected.
+
+	ngoodpix = npix
+	minpix = max (MIN_NPIXELS, int (npix * MAX_REJECT))
+
+	for (niter=1;  niter <= maxiter;  niter=niter+1) {
+	    last_ngoodpix = ngoodpix
+
+	    # Subtract the fitted line from the data array.
+	    call zsc_flatten_data (data, Memr[flat], Memr[normx], npix, z0, dz)
+
+	    # Compute the k-sigma rejection threshold.  In principle this
+	    # could be more efficiently computed using the matrix sums
+	    # accumulated when the line was fitted, but there are problems with
+	    # numerical stability with that approach.
+
+	    ngoodpix = zsc_compute_sigma (Memr[flat], Mems[badpix], npix,
+		mean, sigma)
+	    threshold = sigma * krej
+
+	    # Detect and reject pixels further than ksigma from the fitted
+	    # line.
+	    ngoodpix = zsc_reject_pixels (data, Memr[flat], Memr[normx],
+		Mems[badpix], npix, sumxsqr, sumxz, sumx, sumz, threshold,
+		ngrow)
+
+	    # Solve for the coefficients of the fitted line.  Note that after
+	    # pixel rejection the sum of the X values need no longer be zero.
+
+	    if (ngoodpix > 0) {
+		rowrat = sumx / sumxsqr
+		z0 = (sumz - rowrat * sumxz) / (ngoodpix - rowrat * sumx)
+		dz = (sumxz - z0 * sumx) / sumxsqr
+	    }
+
+# call eprintf ("fit: z0=%g, dz=%g, threshold=%g, npix=%d\n")
+# call pargr(z0); call pargr(dz); call pargr(threshold); call pargi(ngoodpix)
+
+	    if (ngoodpix >= last_ngoodpix || ngoodpix < minpix)
+		break
+	}
+
+	# Transform the line coefficients back to the X range [1:npix].
+	zstart = z0 - dz
+	zslope = dz * xscale
+
+	call sfree (sp)
+	return (ngoodpix)
+end
+
+
+# ZSC_FLATTEN_DATA -- Compute and subtract the fitted line from the data array,
+# returned the flattened data in FLAT.
+
+procedure zsc_flatten_data (data, flat, x, npix, z0, dz)
+
+real	data[npix]		# raw data array
+real	flat[npix]		# flattened data  (output)
+real	x[npix]			# x value of each pixel
+int	npix			# number of pixels
+real	z0, dz			# z-intercept, dz/dx of fitted line
+int	i
+
+begin
+	do i = 1, npix
+	    flat[i] = data[i] - (x[i] * dz + z0)
+end
+
+
+# ZSC_COMPUTE_SIGMA -- Compute the root mean square deviation from the
+# mean of a flattened array.  Ignore rejected pixels.
+
+int procedure zsc_compute_sigma (a, badpix, npix, mean, sigma)
+
+real	a[npix]			# flattened data array
+short	badpix[npix]		# bad pixel flags (!= 0 if bad pixel)
+int	npix
+real	mean, sigma		# (output)
+
+real	pixval
+int	i, ngoodpix
+double	sum, sumsq, temp
+
+begin
+	sum = 0
+	sumsq = 0
+	ngoodpix = 0
+
+	# Accumulate sum and sum of squares.
+	do i = 1, npix
+	    if (badpix[i] == GOOD_PIXEL) {
+		pixval = a[i]
+		ngoodpix = ngoodpix + 1
+		sum = sum + pixval
+		sumsq = sumsq + pixval ** 2
+	    }
+
+	# Compute mean and sigma.
+	switch (ngoodpix) {
+	case 0:
+	    mean = INDEF
+	    sigma = INDEF
+	case 1:
+	    mean = sum
+	    sigma = INDEF
+	default:
+	    mean = sum / ngoodpix
+	    temp = sumsq / (ngoodpix - 1) - sum**2 / (ngoodpix * (ngoodpix - 1))
+	    if (temp < 0)		# possible with roundoff error
+		sigma = 0.0
+	    else
+		sigma = sqrt (temp)
+	}
+
+	return (ngoodpix)
+end
+
+
+# ZSC_REJECT_PIXELS -- Detect and reject pixels more than "threshold" greyscale
+# units from the fitted line.  The residuals about the fitted line are given
+# by the "flat" array, while the raw data is in "data".  Each time a pixel
+# is rejected subtract its contributions from the matrix sums and flag the
+# pixel as rejected.  When a pixel is rejected reject its neighbors out to
+# a specified radius as well.  This speeds up convergence considerably and
+# produces a more stringent rejection criteria which takes advantage of the
+# fact that bad pixels tend to be clumped.  The number of pixels left in the
+# fit is returned as the function value.
+
+int procedure zsc_reject_pixels (data, flat, normx, badpix, npix,
+				 sumxsqr, sumxz, sumx, sumz, threshold, ngrow)
+
+real	data[npix]		# raw data array
+real	flat[npix]		# flattened data array
+real	normx[npix]		# normalized x values of pixels
+short	badpix[npix]		# bad pixel flags (!= 0 if bad pixel)
+int	npix
+double	sumxsqr,sumxz,sumx,sumz	# matrix sums
+real	threshold		# threshold for pixel rejection
+int	ngrow			# number of pixels of growing
+
+int	ngoodpix, i, j
+real	residual, lcut, hcut
+double	x, z
+
+begin
+	ngoodpix = npix
+	lcut = -threshold
+	hcut = threshold
+
+	do i = 1, npix
+	    if (badpix[i] == BAD_PIXEL)
+		ngoodpix = ngoodpix - 1
+	    else {
+		residual = flat[i]
+		if (residual < lcut || residual > hcut) {
+		    # Reject the pixel and its neighbors out to the growing
+		    # radius.  We must be careful how we do this to avoid
+		    # directional effects.  Do not turn off thresholding on
+		    # pixels in the forward direction; mark them for rejection
+		    # but do not reject until they have been thresholded.
+		    # If this is not done growing will not be symmetric.
+
+		    do j = max(1,i-ngrow), min(npix,i+ngrow) {
+#call eprintf ("\t\t%d->%d\tcheck\n");call pargi(j); call pargs(badpix[j])
+			if (badpix[j] != BAD_PIXEL) {
+			    if (j <= i) {
+				x = normx[j]
+				z = data[j]
+#call eprintf ("\treject [%d:%6g]=%6g sum[xsqr,xz,z]\n")
+#call pargi(j); call pargd(x); call pargd(z)
+#call eprintf ("\t%10g %10g %10g\n")
+#call pargd(sumxsqr); call pargd(sumxz); call pargd(sumz)
+				sumxsqr = sumxsqr - (x ** 2)
+				sumxz = sumxz - z * x
+				sumx = sumx - x
+				sumz = sumz - z
+#call eprintf ("\t%10g %10g %10g\n")
+#call pargd(sumxsqr); call pargd(sumxz); call pargd(sumz)
+				badpix[j] = BAD_PIXEL
+				ngoodpix = ngoodpix - 1
+			    } else
+				badpix[j] = REJECT_PIXEL
+#call eprintf ("\t\t%d->%d\tset\n");call pargi(j); call pargs(badpix[j])
+			}
+		    }
+		}
+	    }
+
+	return (ngoodpix)
+end