aboutsummaryrefslogtreecommitdiff
path: root/pkg/obsolete/imcombine
diff options
context:
space:
mode:
authorJoseph Hunkeler <jhunkeler@gmail.com>2015-07-08 20:46:52 -0400
committerJoseph Hunkeler <jhunkeler@gmail.com>2015-07-08 20:46:52 -0400
commitfa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 (patch)
treebdda434976bc09c864f2e4fa6f16ba1952b1e555 /pkg/obsolete/imcombine
downloadiraf-linux-fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4.tar.gz
Initial commit
Diffstat (limited to 'pkg/obsolete/imcombine')
-rw-r--r--pkg/obsolete/imcombine/generic/icaclip.x2198
-rw-r--r--pkg/obsolete/imcombine/generic/icaverage.x337
-rw-r--r--pkg/obsolete/imcombine/generic/iccclip.x1790
-rw-r--r--pkg/obsolete/imcombine/generic/icgdata.x918
-rw-r--r--pkg/obsolete/imcombine/generic/icgrow.x251
-rw-r--r--pkg/obsolete/imcombine/generic/icmedian.x556
-rw-r--r--pkg/obsolete/imcombine/generic/icmm.x612
-rw-r--r--pkg/obsolete/imcombine/generic/icombine.x1645
-rw-r--r--pkg/obsolete/imcombine/generic/icpclip.x878
-rw-r--r--pkg/obsolete/imcombine/generic/icsclip.x1922
-rw-r--r--pkg/obsolete/imcombine/generic/icsigma.x405
-rw-r--r--pkg/obsolete/imcombine/generic/icsort.x1096
-rw-r--r--pkg/obsolete/imcombine/generic/icstat.x880
-rw-r--r--pkg/obsolete/imcombine/generic/mkpkg23
-rw-r--r--pkg/obsolete/imcombine/icaclip.gx573
-rw-r--r--pkg/obsolete/imcombine/icaverage.gx97
-rw-r--r--pkg/obsolete/imcombine/iccclip.gx471
-rw-r--r--pkg/obsolete/imcombine/icgdata.gx235
-rw-r--r--pkg/obsolete/imcombine/icgrow.gx123
-rw-r--r--pkg/obsolete/imcombine/icimstack.x129
-rw-r--r--pkg/obsolete/imcombine/iclog.x384
-rw-r--r--pkg/obsolete/imcombine/icmask.com8
-rw-r--r--pkg/obsolete/imcombine/icmask.x314
-rw-r--r--pkg/obsolete/imcombine/icmedian.gx180
-rw-r--r--pkg/obsolete/imcombine/icmm.gx181
-rw-r--r--pkg/obsolete/imcombine/icombine.com38
-rw-r--r--pkg/obsolete/imcombine/icombine.gx580
-rw-r--r--pkg/obsolete/imcombine/icombine.h52
-rw-r--r--pkg/obsolete/imcombine/icpclip.gx233
-rw-r--r--pkg/obsolete/imcombine/icrmasks.x41
-rw-r--r--pkg/obsolete/imcombine/icscale.x358
-rw-r--r--pkg/obsolete/imcombine/icsclip.gx504
-rw-r--r--pkg/obsolete/imcombine/icsection.x94
-rw-r--r--pkg/obsolete/imcombine/icsetout.x273
-rw-r--r--pkg/obsolete/imcombine/icsigma.gx115
-rw-r--r--pkg/obsolete/imcombine/icsort.gx386
-rw-r--r--pkg/obsolete/imcombine/icstat.gx237
-rw-r--r--pkg/obsolete/imcombine/mkpkg54
-rw-r--r--pkg/obsolete/imcombine/t_imcombine.x501
39 files changed, 19672 insertions, 0 deletions
diff --git a/pkg/obsolete/imcombine/generic/icaclip.x b/pkg/obsolete/imcombine/generic/icaclip.x
new file mode 100644
index 00000000..2dd4d31e
--- /dev/null
+++ b/pkg/obsolete/imcombine/generic/icaclip.x
@@ -0,0 +1,2198 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include "../icombine.h"
+
+define MINCLIP 3 # Minimum number of images for this algorithm
+
+
+# IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average
+# The average sigma is normalized by the expected poisson sigma.
+
+procedure ic_aavsigclips (d, m, n, scales, zeros, nimages, npts, average)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+real average[npts] # Average
+
+int i, j, k, l, jj, n1, n2, nin, nk, maxkeep
+real d1, low, high, sum, a, s, s1, r, one
+data one /1.0/
+pointer sp, sums, resid, dp1, dp2, mp1, mp2
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (sums, npts, TY_REAL)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Since the unweighted average is computed here possibly skip combining
+ if (dowts || combine != AVERAGE)
+ docombine = true
+ else
+ docombine = false
+
+ # Compute the unweighted average with the high and low rejected and
+ # the poisson scaled average sigma. There must be at least three
+ # pixels at each point to define the average and contributions to
+ # the mean sigma. Corrections for differences in the image
+ # scale factors are selected by the doscale1 flag.
+
+ nin = n[1]
+ s = 0.
+ n2 = 0
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (n1 < 3)
+ next
+
+ # Unweighted average with the high and low rejected
+ low = Mems[d[1]+k]
+ high = Mems[d[2]+k]
+ if (low > high) {
+ d1 = low
+ low = high
+ high = d1
+ }
+ sum = 0.
+ do j = 3, n1 {
+ d1 = Mems[d[j]+k]
+ if (d1 < low) {
+ sum = sum + low
+ low = d1
+ } else if (d1 > high) {
+ sum = sum + high
+ high = d1
+ } else
+ sum = sum + d1
+ }
+ a = sum / (n1 - 2)
+ sum = sum + low + high
+
+ # Poisson scaled sigma accumulation
+ if (doscale1) {
+ do j = 1, n1 {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+
+ d1 = Mems[dp1]
+ l = Memi[mp1]
+ s1 = max (one, (a + zeros[l]) / scales[l])
+ s = s + (d1 - a) ** 2 / s1
+ }
+ } else {
+ s1 = max (one, a)
+ do j = 1, n1
+ s = s + (Mems[d[j]+k] - a) ** 2 / s1
+ }
+ n2 = n2 + n1
+
+ # Save the average and sum for later.
+ average[i] = a
+ Memr[sums+k] = sum
+ }
+
+ # Here is the final sigma.
+ if (n2 > 1)
+ s = sqrt (s / (n2 - 1))
+
+ # Reject pixels and compute the final average (if needed).
+ # There must be at least three pixels at each point for rejection.
+ # Iteratively scale the mean sigma and reject pixels
+ # Compact the data and keep track of the image IDs if needed.
+
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 <= max (2, maxkeep)) {
+ if (!docombine) {
+ if (n1 == 0)
+ average[i] = blank
+ else {
+ sum = Mems[d[1]+k]
+ do j = 2, n1
+ sum = sum + Mems[d[j]+k]
+ average[i] = sum / n1
+ }
+ }
+ next
+ }
+
+ a = average[i]
+ sum = Memr[sums+k]
+
+ repeat {
+ n2 = n1
+ if (s > 0.) {
+ if (doscale1) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+
+ d1 = Mems[dp1]
+ l = Memi[mp1]
+ s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l]))
+ r = (d1 - a) / s1
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Mems[dp1] = Mems[dp2]
+ Mems[dp2] = d1
+ mp2 = m[n1] + k
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ } else {
+ s1 = s * sqrt (max (one, a))
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ d1 = Mems[dp1]
+ r = (d1 - a) / s1
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Mems[dp1] = Mems[dp2]
+ Mems[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ }
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ }
+ if (n1 > 1)
+ a = sum / n1
+ } until (n1 == n2 || n1 <= max (2, maxkeep))
+
+ # If too many are rejected add some back in.
+ # Pixels with equal residuals are added together.
+ if (n1 < maxkeep) {
+ nk = maxkeep
+ if (doscale1) {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Mems[dp1]
+ Mems[dp1] = Mems[dp2]
+ Mems[dp2] = d1
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ sum = sum + Mems[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ } else {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Mems[dp1]
+ Mems[dp1] = Mems[dp2]
+ Mems[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ }
+ sum = sum + Mems[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ }
+ if (n1 > 1)
+ a = sum / n1
+ }
+
+ # Save the average if needed.
+ n[i] = n1
+ if (!docombine) {
+ if (n1 > 0)
+ average[i] = a
+ else
+ average[i] = blank
+ }
+ }
+
+ # Check if the data flag has to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median
+# The average sigma is normalized by the expected poisson sigma.
+
+procedure ic_mavsigclips (d, m, n, scales, zeros, nimages, npts, median)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+real median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep
+pointer sp, resid, mp1, mp2
+real med, low, high, r, s, s1, one
+data one /1.0/
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Compute the poisson scaled average sigma about the median.
+ # There must be at least three pixels at each point to define
+ # the mean sigma. Corrections for differences in the image
+ # scale factors are selected by the doscale1 flag.
+
+ s = 0.
+ n2 = 0
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (n1 < 3) {
+ if (n1 == 0)
+ median[i] = blank
+ else if (n1 == 1)
+ median[i] = Mems[d[1]+k]
+ else {
+ low = Mems[d[1]+k]
+ high = Mems[d[2]+k]
+ median[i] = (low + high) / 2.
+ }
+ next
+ }
+
+ # Median
+ n3 = 1 + n1 / 2
+ if (mod (n1, 2) == 0) {
+ low = Mems[d[n3-1]+k]
+ high = Mems[d[n3]+k]
+ med = (low + high) / 2.
+ } else
+ med = Mems[d[n3]+k]
+
+ # Poisson scaled sigma accumulation
+ if (doscale1) {
+ do j = 1, n1 {
+ l = Memi[m[j]+k]
+ s1 = max (one, (med + zeros[l]) / scales[l])
+ s = s + (Mems[d[j]+k] - med) ** 2 / s1
+ }
+ } else {
+ s1 = max (one, med)
+ do j = 1, n1
+ s = s + (Mems[d[j]+k] - med) ** 2 / s1
+ }
+ n2 = n2 + n1
+
+ # Save the median for later.
+ median[i] = med
+ }
+
+ # Here is the final sigma.
+ if (n2 > 1)
+ s = sqrt (s / (n2 - 1))
+ else
+ return
+
+ # Compute individual sigmas and iteratively clip.
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 < max (3, maxkeep+1))
+ next
+ nl = 1
+ nh = n1
+ med = median[i]
+
+ repeat {
+ n2 = n1
+ n3 = nl + n1 / 2
+
+ if (n1 >= max (MINCLIP, maxkeep+1) && s > 0.) {
+ if (doscale1) {
+ for (; nl <= n2; nl = nl + 1) {
+ l = Memi[m[nl]+k]
+ s1 = s * sqrt (max (one, (med+zeros[l])/scales[l]))
+ r = (med - Mems[d[nl]+k]) / s1
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ l = Memi[m[nh]+k]
+ s1 = s * sqrt (max (one, (med+zeros[l])/scales[l]))
+ r = (Mems[d[nh]+k] - med) / s1
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ } else {
+ s1 = s * sqrt (max (one, med))
+ for (; nl <= n2; nl = nl + 1) {
+ r = (med - Mems[d[nl]+k]) / s1
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ r = (Mems[d[nh]+k] - med) / s1
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+
+ # Recompute median
+ if (n1 < n2) {
+ if (n1 > 0) {
+ n3 = nl + n1 / 2
+ if (mod (n1, 2) == 0) {
+ low = Mems[d[n3-1]+k]
+ high = Mems[d[n3]+k]
+ med = (low + high) / 2.
+ } else
+ med = Mems[d[n3]+k]
+ } else
+ med = blank
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ # If too many are rejected add some back in.
+ # Pixels with equal residuals are added together.
+ while (n1 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n1 = nh - nl + 1
+
+ # Recompute median
+ if (n1 < n2) {
+ if (n1 > 0) {
+ n3 = nl + n1 / 2
+ if (mod (n1, 2) == 0) {
+ low = Mems[d[n3-1]+k]
+ high = Mems[d[n3]+k]
+ med = (low + high) / 2.
+ } else
+ med = Mems[d[n3]+k]
+ } else
+ med = blank
+ }
+ }
+
+ # Only set median and reorder if needed
+ n[i] = n1
+ if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ j = max (nl, n1 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Mems[d[l]+k] = Mems[d[j]+k]
+ if (grow >= 1.) {
+ mp1 = m[l] + k
+ mp2 = m[j] + k
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+k] = Memi[m[j]+k]
+ j = j + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Mems[d[l]+k] = Mems[d[j]+k]
+ j = j + 1
+ }
+ }
+ }
+
+ if (combine == MEDIAN)
+ median[i] = med
+ }
+
+ # Check if data flag needs to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag that the median is computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+
+# IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average
+# The average sigma is normalized by the expected poisson sigma.
+
+procedure ic_aavsigclipi (d, m, n, scales, zeros, nimages, npts, average)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+real average[npts] # Average
+
+int i, j, k, l, jj, n1, n2, nin, nk, maxkeep
+real d1, low, high, sum, a, s, s1, r, one
+data one /1.0/
+pointer sp, sums, resid, dp1, dp2, mp1, mp2
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (sums, npts, TY_REAL)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Since the unweighted average is computed here possibly skip combining
+ if (dowts || combine != AVERAGE)
+ docombine = true
+ else
+ docombine = false
+
+ # Compute the unweighted average with the high and low rejected and
+ # the poisson scaled average sigma. There must be at least three
+ # pixels at each point to define the average and contributions to
+ # the mean sigma. Corrections for differences in the image
+ # scale factors are selected by the doscale1 flag.
+
+ nin = n[1]
+ s = 0.
+ n2 = 0
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (n1 < 3)
+ next
+
+ # Unweighted average with the high and low rejected
+ low = Memi[d[1]+k]
+ high = Memi[d[2]+k]
+ if (low > high) {
+ d1 = low
+ low = high
+ high = d1
+ }
+ sum = 0.
+ do j = 3, n1 {
+ d1 = Memi[d[j]+k]
+ if (d1 < low) {
+ sum = sum + low
+ low = d1
+ } else if (d1 > high) {
+ sum = sum + high
+ high = d1
+ } else
+ sum = sum + d1
+ }
+ a = sum / (n1 - 2)
+ sum = sum + low + high
+
+ # Poisson scaled sigma accumulation
+ if (doscale1) {
+ do j = 1, n1 {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+
+ d1 = Memi[dp1]
+ l = Memi[mp1]
+ s1 = max (one, (a + zeros[l]) / scales[l])
+ s = s + (d1 - a) ** 2 / s1
+ }
+ } else {
+ s1 = max (one, a)
+ do j = 1, n1
+ s = s + (Memi[d[j]+k] - a) ** 2 / s1
+ }
+ n2 = n2 + n1
+
+ # Save the average and sum for later.
+ average[i] = a
+ Memr[sums+k] = sum
+ }
+
+ # Here is the final sigma.
+ if (n2 > 1)
+ s = sqrt (s / (n2 - 1))
+
+ # Reject pixels and compute the final average (if needed).
+ # There must be at least three pixels at each point for rejection.
+ # Iteratively scale the mean sigma and reject pixels
+ # Compact the data and keep track of the image IDs if needed.
+
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 <= max (2, maxkeep)) {
+ if (!docombine) {
+ if (n1 == 0)
+ average[i] = blank
+ else {
+ sum = Memi[d[1]+k]
+ do j = 2, n1
+ sum = sum + Memi[d[j]+k]
+ average[i] = sum / n1
+ }
+ }
+ next
+ }
+
+ a = average[i]
+ sum = Memr[sums+k]
+
+ repeat {
+ n2 = n1
+ if (s > 0.) {
+ if (doscale1) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+
+ d1 = Memi[dp1]
+ l = Memi[mp1]
+ s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l]))
+ r = (d1 - a) / s1
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memi[dp1] = Memi[dp2]
+ Memi[dp2] = d1
+ mp2 = m[n1] + k
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ } else {
+ s1 = s * sqrt (max (one, a))
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ d1 = Memi[dp1]
+ r = (d1 - a) / s1
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memi[dp1] = Memi[dp2]
+ Memi[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ }
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ }
+ if (n1 > 1)
+ a = sum / n1
+ } until (n1 == n2 || n1 <= max (2, maxkeep))
+
+ # If too many are rejected add some back in.
+ # Pixels with equal residuals are added together.
+ if (n1 < maxkeep) {
+ nk = maxkeep
+ if (doscale1) {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memi[dp1]
+ Memi[dp1] = Memi[dp2]
+ Memi[dp2] = d1
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ sum = sum + Memi[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ } else {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memi[dp1]
+ Memi[dp1] = Memi[dp2]
+ Memi[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ }
+ sum = sum + Memi[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ }
+ if (n1 > 1)
+ a = sum / n1
+ }
+
+ # Save the average if needed.
+ n[i] = n1
+ if (!docombine) {
+ if (n1 > 0)
+ average[i] = a
+ else
+ average[i] = blank
+ }
+ }
+
+ # Check if the data flag has to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median
+# The average sigma is normalized by the expected poisson sigma.
+
+procedure ic_mavsigclipi (d, m, n, scales, zeros, nimages, npts, median)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+real median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep
+pointer sp, resid, mp1, mp2
+real med, low, high, r, s, s1, one
+data one /1.0/
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Compute the poisson scaled average sigma about the median.
+ # There must be at least three pixels at each point to define
+ # the mean sigma. Corrections for differences in the image
+ # scale factors are selected by the doscale1 flag.
+
+ s = 0.
+ n2 = 0
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (n1 < 3) {
+ if (n1 == 0)
+ median[i] = blank
+ else if (n1 == 1)
+ median[i] = Memi[d[1]+k]
+ else {
+ low = Memi[d[1]+k]
+ high = Memi[d[2]+k]
+ median[i] = (low + high) / 2.
+ }
+ next
+ }
+
+ # Median
+ n3 = 1 + n1 / 2
+ if (mod (n1, 2) == 0) {
+ low = Memi[d[n3-1]+k]
+ high = Memi[d[n3]+k]
+ med = (low + high) / 2.
+ } else
+ med = Memi[d[n3]+k]
+
+ # Poisson scaled sigma accumulation
+ if (doscale1) {
+ do j = 1, n1 {
+ l = Memi[m[j]+k]
+ s1 = max (one, (med + zeros[l]) / scales[l])
+ s = s + (Memi[d[j]+k] - med) ** 2 / s1
+ }
+ } else {
+ s1 = max (one, med)
+ do j = 1, n1
+ s = s + (Memi[d[j]+k] - med) ** 2 / s1
+ }
+ n2 = n2 + n1
+
+ # Save the median for later.
+ median[i] = med
+ }
+
+ # Here is the final sigma.
+ if (n2 > 1)
+ s = sqrt (s / (n2 - 1))
+ else
+ return
+
+ # Compute individual sigmas and iteratively clip.
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 < max (3, maxkeep+1))
+ next
+ nl = 1
+ nh = n1
+ med = median[i]
+
+ repeat {
+ n2 = n1
+ n3 = nl + n1 / 2
+
+ if (n1 >= max (MINCLIP, maxkeep+1) && s > 0.) {
+ if (doscale1) {
+ for (; nl <= n2; nl = nl + 1) {
+ l = Memi[m[nl]+k]
+ s1 = s * sqrt (max (one, (med+zeros[l])/scales[l]))
+ r = (med - Memi[d[nl]+k]) / s1
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ l = Memi[m[nh]+k]
+ s1 = s * sqrt (max (one, (med+zeros[l])/scales[l]))
+ r = (Memi[d[nh]+k] - med) / s1
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ } else {
+ s1 = s * sqrt (max (one, med))
+ for (; nl <= n2; nl = nl + 1) {
+ r = (med - Memi[d[nl]+k]) / s1
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ r = (Memi[d[nh]+k] - med) / s1
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+
+ # Recompute median
+ if (n1 < n2) {
+ if (n1 > 0) {
+ n3 = nl + n1 / 2
+ if (mod (n1, 2) == 0) {
+ low = Memi[d[n3-1]+k]
+ high = Memi[d[n3]+k]
+ med = (low + high) / 2.
+ } else
+ med = Memi[d[n3]+k]
+ } else
+ med = blank
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ # If too many are rejected add some back in.
+ # Pixels with equal residuals are added together.
+ while (n1 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n1 = nh - nl + 1
+
+ # Recompute median
+ if (n1 < n2) {
+ if (n1 > 0) {
+ n3 = nl + n1 / 2
+ if (mod (n1, 2) == 0) {
+ low = Memi[d[n3-1]+k]
+ high = Memi[d[n3]+k]
+ med = (low + high) / 2.
+ } else
+ med = Memi[d[n3]+k]
+ } else
+ med = blank
+ }
+ }
+
+ # Only set median and reorder if needed
+ n[i] = n1
+ if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ j = max (nl, n1 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Memi[d[l]+k] = Memi[d[j]+k]
+ if (grow >= 1.) {
+ mp1 = m[l] + k
+ mp2 = m[j] + k
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+k] = Memi[m[j]+k]
+ j = j + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Memi[d[l]+k] = Memi[d[j]+k]
+ j = j + 1
+ }
+ }
+ }
+
+ if (combine == MEDIAN)
+ median[i] = med
+ }
+
+ # Check if data flag needs to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag that the median is computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+
+# IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average
+# The average sigma is normalized by the expected poisson sigma.
+
+procedure ic_aavsigclipr (d, m, n, scales, zeros, nimages, npts, average)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+real average[npts] # Average
+
+int i, j, k, l, jj, n1, n2, nin, nk, maxkeep
+real d1, low, high, sum, a, s, s1, r, one
+data one /1.0/
+pointer sp, sums, resid, dp1, dp2, mp1, mp2
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (sums, npts, TY_REAL)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Since the unweighted average is computed here possibly skip combining
+ if (dowts || combine != AVERAGE)
+ docombine = true
+ else
+ docombine = false
+
+ # Compute the unweighted average with the high and low rejected and
+ # the poisson scaled average sigma. There must be at least three
+ # pixels at each point to define the average and contributions to
+ # the mean sigma. Corrections for differences in the image
+ # scale factors are selected by the doscale1 flag.
+
+ nin = n[1]
+ s = 0.
+ n2 = 0
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (n1 < 3)
+ next
+
+ # Unweighted average with the high and low rejected
+ low = Memr[d[1]+k]
+ high = Memr[d[2]+k]
+ if (low > high) {
+ d1 = low
+ low = high
+ high = d1
+ }
+ sum = 0.
+ do j = 3, n1 {
+ d1 = Memr[d[j]+k]
+ if (d1 < low) {
+ sum = sum + low
+ low = d1
+ } else if (d1 > high) {
+ sum = sum + high
+ high = d1
+ } else
+ sum = sum + d1
+ }
+ a = sum / (n1 - 2)
+ sum = sum + low + high
+
+ # Poisson scaled sigma accumulation
+ if (doscale1) {
+ do j = 1, n1 {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+
+ d1 = Memr[dp1]
+ l = Memi[mp1]
+ s1 = max (one, (a + zeros[l]) / scales[l])
+ s = s + (d1 - a) ** 2 / s1
+ }
+ } else {
+ s1 = max (one, a)
+ do j = 1, n1
+ s = s + (Memr[d[j]+k] - a) ** 2 / s1
+ }
+ n2 = n2 + n1
+
+ # Save the average and sum for later.
+ average[i] = a
+ Memr[sums+k] = sum
+ }
+
+ # Here is the final sigma.
+ if (n2 > 1)
+ s = sqrt (s / (n2 - 1))
+
+ # Reject pixels and compute the final average (if needed).
+ # There must be at least three pixels at each point for rejection.
+ # Iteratively scale the mean sigma and reject pixels
+ # Compact the data and keep track of the image IDs if needed.
+
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 <= max (2, maxkeep)) {
+ if (!docombine) {
+ if (n1 == 0)
+ average[i] = blank
+ else {
+ sum = Memr[d[1]+k]
+ do j = 2, n1
+ sum = sum + Memr[d[j]+k]
+ average[i] = sum / n1
+ }
+ }
+ next
+ }
+
+ a = average[i]
+ sum = Memr[sums+k]
+
+ repeat {
+ n2 = n1
+ if (s > 0.) {
+ if (doscale1) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+
+ d1 = Memr[dp1]
+ l = Memi[mp1]
+ s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l]))
+ r = (d1 - a) / s1
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memr[dp1] = Memr[dp2]
+ Memr[dp2] = d1
+ mp2 = m[n1] + k
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ } else {
+ s1 = s * sqrt (max (one, a))
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ d1 = Memr[dp1]
+ r = (d1 - a) / s1
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memr[dp1] = Memr[dp2]
+ Memr[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ }
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ }
+ if (n1 > 1)
+ a = sum / n1
+ } until (n1 == n2 || n1 <= max (2, maxkeep))
+
+ # If too many are rejected add some back in.
+ # Pixels with equal residuals are added together.
+ if (n1 < maxkeep) {
+ nk = maxkeep
+ if (doscale1) {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memr[dp1]
+ Memr[dp1] = Memr[dp2]
+ Memr[dp2] = d1
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ sum = sum + Memr[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ } else {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memr[dp1]
+ Memr[dp1] = Memr[dp2]
+ Memr[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ }
+ sum = sum + Memr[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ }
+ if (n1 > 1)
+ a = sum / n1
+ }
+
+ # Save the average if needed.
+ n[i] = n1
+ if (!docombine) {
+ if (n1 > 0)
+ average[i] = a
+ else
+ average[i] = blank
+ }
+ }
+
+ # Check if the data flag has to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median
+# The average sigma is normalized by the expected poisson sigma.
+
+procedure ic_mavsigclipr (d, m, n, scales, zeros, nimages, npts, median)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+real median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep
+pointer sp, resid, mp1, mp2
+real med, low, high, r, s, s1, one
+data one /1.0/
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Compute the poisson scaled average sigma about the median.
+ # There must be at least three pixels at each point to define
+ # the mean sigma. Corrections for differences in the image
+ # scale factors are selected by the doscale1 flag.
+
+ s = 0.
+ n2 = 0
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (n1 < 3) {
+ if (n1 == 0)
+ median[i] = blank
+ else if (n1 == 1)
+ median[i] = Memr[d[1]+k]
+ else {
+ low = Memr[d[1]+k]
+ high = Memr[d[2]+k]
+ median[i] = (low + high) / 2.
+ }
+ next
+ }
+
+ # Median
+ n3 = 1 + n1 / 2
+ if (mod (n1, 2) == 0) {
+ low = Memr[d[n3-1]+k]
+ high = Memr[d[n3]+k]
+ med = (low + high) / 2.
+ } else
+ med = Memr[d[n3]+k]
+
+ # Poisson scaled sigma accumulation
+ if (doscale1) {
+ do j = 1, n1 {
+ l = Memi[m[j]+k]
+ s1 = max (one, (med + zeros[l]) / scales[l])
+ s = s + (Memr[d[j]+k] - med) ** 2 / s1
+ }
+ } else {
+ s1 = max (one, med)
+ do j = 1, n1
+ s = s + (Memr[d[j]+k] - med) ** 2 / s1
+ }
+ n2 = n2 + n1
+
+ # Save the median for later.
+ median[i] = med
+ }
+
+ # Here is the final sigma.
+ if (n2 > 1)
+ s = sqrt (s / (n2 - 1))
+ else
+ return
+
+ # Compute individual sigmas and iteratively clip.
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 < max (3, maxkeep+1))
+ next
+ nl = 1
+ nh = n1
+ med = median[i]
+
+ repeat {
+ n2 = n1
+ n3 = nl + n1 / 2
+
+ if (n1 >= max (MINCLIP, maxkeep+1) && s > 0.) {
+ if (doscale1) {
+ for (; nl <= n2; nl = nl + 1) {
+ l = Memi[m[nl]+k]
+ s1 = s * sqrt (max (one, (med+zeros[l])/scales[l]))
+ r = (med - Memr[d[nl]+k]) / s1
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ l = Memi[m[nh]+k]
+ s1 = s * sqrt (max (one, (med+zeros[l])/scales[l]))
+ r = (Memr[d[nh]+k] - med) / s1
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ } else {
+ s1 = s * sqrt (max (one, med))
+ for (; nl <= n2; nl = nl + 1) {
+ r = (med - Memr[d[nl]+k]) / s1
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ r = (Memr[d[nh]+k] - med) / s1
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+
+ # Recompute median
+ if (n1 < n2) {
+ if (n1 > 0) {
+ n3 = nl + n1 / 2
+ if (mod (n1, 2) == 0) {
+ low = Memr[d[n3-1]+k]
+ high = Memr[d[n3]+k]
+ med = (low + high) / 2.
+ } else
+ med = Memr[d[n3]+k]
+ } else
+ med = blank
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ # If too many are rejected add some back in.
+ # Pixels with equal residuals are added together.
+ while (n1 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n1 = nh - nl + 1
+
+ # Recompute median
+ if (n1 < n2) {
+ if (n1 > 0) {
+ n3 = nl + n1 / 2
+ if (mod (n1, 2) == 0) {
+ low = Memr[d[n3-1]+k]
+ high = Memr[d[n3]+k]
+ med = (low + high) / 2.
+ } else
+ med = Memr[d[n3]+k]
+ } else
+ med = blank
+ }
+ }
+
+ # Only set median and reorder if needed
+ n[i] = n1
+ if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ j = max (nl, n1 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Memr[d[l]+k] = Memr[d[j]+k]
+ if (grow >= 1.) {
+ mp1 = m[l] + k
+ mp2 = m[j] + k
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+k] = Memi[m[j]+k]
+ j = j + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Memr[d[l]+k] = Memr[d[j]+k]
+ j = j + 1
+ }
+ }
+ }
+
+ if (combine == MEDIAN)
+ median[i] = med
+ }
+
+ # Check if data flag needs to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag that the median is computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+
+# IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average
+# The average sigma is normalized by the expected poisson sigma.
+
+procedure ic_aavsigclipd (d, m, n, scales, zeros, nimages, npts, average)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+double average[npts] # Average
+
+int i, j, k, l, jj, n1, n2, nin, nk, maxkeep
+double d1, low, high, sum, a, s, s1, r, one
+data one /1.0D0/
+pointer sp, sums, resid, dp1, dp2, mp1, mp2
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (sums, npts, TY_REAL)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Since the unweighted average is computed here possibly skip combining
+ if (dowts || combine != AVERAGE)
+ docombine = true
+ else
+ docombine = false
+
+ # Compute the unweighted average with the high and low rejected and
+ # the poisson scaled average sigma. There must be at least three
+ # pixels at each point to define the average and contributions to
+ # the mean sigma. Corrections for differences in the image
+ # scale factors are selected by the doscale1 flag.
+
+ nin = n[1]
+ s = 0.
+ n2 = 0
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (n1 < 3)
+ next
+
+ # Unweighted average with the high and low rejected
+ low = Memd[d[1]+k]
+ high = Memd[d[2]+k]
+ if (low > high) {
+ d1 = low
+ low = high
+ high = d1
+ }
+ sum = 0.
+ do j = 3, n1 {
+ d1 = Memd[d[j]+k]
+ if (d1 < low) {
+ sum = sum + low
+ low = d1
+ } else if (d1 > high) {
+ sum = sum + high
+ high = d1
+ } else
+ sum = sum + d1
+ }
+ a = sum / (n1 - 2)
+ sum = sum + low + high
+
+ # Poisson scaled sigma accumulation
+ if (doscale1) {
+ do j = 1, n1 {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+
+ d1 = Memd[dp1]
+ l = Memi[mp1]
+ s1 = max (one, (a + zeros[l]) / scales[l])
+ s = s + (d1 - a) ** 2 / s1
+ }
+ } else {
+ s1 = max (one, a)
+ do j = 1, n1
+ s = s + (Memd[d[j]+k] - a) ** 2 / s1
+ }
+ n2 = n2 + n1
+
+ # Save the average and sum for later.
+ average[i] = a
+ Memr[sums+k] = sum
+ }
+
+ # Here is the final sigma.
+ if (n2 > 1)
+ s = sqrt (s / (n2 - 1))
+
+ # Reject pixels and compute the final average (if needed).
+ # There must be at least three pixels at each point for rejection.
+ # Iteratively scale the mean sigma and reject pixels
+ # Compact the data and keep track of the image IDs if needed.
+
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 <= max (2, maxkeep)) {
+ if (!docombine) {
+ if (n1 == 0)
+ average[i] = blank
+ else {
+ sum = Memd[d[1]+k]
+ do j = 2, n1
+ sum = sum + Memd[d[j]+k]
+ average[i] = sum / n1
+ }
+ }
+ next
+ }
+
+ a = average[i]
+ sum = Memr[sums+k]
+
+ repeat {
+ n2 = n1
+ if (s > 0.) {
+ if (doscale1) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+
+ d1 = Memd[dp1]
+ l = Memi[mp1]
+ s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l]))
+ r = (d1 - a) / s1
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memd[dp1] = Memd[dp2]
+ Memd[dp2] = d1
+ mp2 = m[n1] + k
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ } else {
+ s1 = s * sqrt (max (one, a))
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ d1 = Memd[dp1]
+ r = (d1 - a) / s1
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memd[dp1] = Memd[dp2]
+ Memd[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ }
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ }
+ if (n1 > 1)
+ a = sum / n1
+ } until (n1 == n2 || n1 <= max (2, maxkeep))
+
+ # If too many are rejected add some back in.
+ # Pixels with equal residuals are added together.
+ if (n1 < maxkeep) {
+ nk = maxkeep
+ if (doscale1) {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memd[dp1]
+ Memd[dp1] = Memd[dp2]
+ Memd[dp2] = d1
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ sum = sum + Memd[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ } else {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memd[dp1]
+ Memd[dp1] = Memd[dp2]
+ Memd[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ }
+ sum = sum + Memd[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ }
+ if (n1 > 1)
+ a = sum / n1
+ }
+
+ # Save the average if needed.
+ n[i] = n1
+ if (!docombine) {
+ if (n1 > 0)
+ average[i] = a
+ else
+ average[i] = blank
+ }
+ }
+
+ # Check if the data flag has to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median
+# The average sigma is normalized by the expected poisson sigma.
+
+procedure ic_mavsigclipd (d, m, n, scales, zeros, nimages, npts, median)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+double median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep
+pointer sp, resid, mp1, mp2
+double med, low, high, r, s, s1, one
+data one /1.0D0/
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Compute the poisson scaled average sigma about the median.
+ # There must be at least three pixels at each point to define
+ # the mean sigma. Corrections for differences in the image
+ # scale factors are selected by the doscale1 flag.
+
+ s = 0.
+ n2 = 0
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (n1 < 3) {
+ if (n1 == 0)
+ median[i] = blank
+ else if (n1 == 1)
+ median[i] = Memd[d[1]+k]
+ else {
+ low = Memd[d[1]+k]
+ high = Memd[d[2]+k]
+ median[i] = (low + high) / 2.
+ }
+ next
+ }
+
+ # Median
+ n3 = 1 + n1 / 2
+ if (mod (n1, 2) == 0) {
+ low = Memd[d[n3-1]+k]
+ high = Memd[d[n3]+k]
+ med = (low + high) / 2.
+ } else
+ med = Memd[d[n3]+k]
+
+ # Poisson scaled sigma accumulation
+ if (doscale1) {
+ do j = 1, n1 {
+ l = Memi[m[j]+k]
+ s1 = max (one, (med + zeros[l]) / scales[l])
+ s = s + (Memd[d[j]+k] - med) ** 2 / s1
+ }
+ } else {
+ s1 = max (one, med)
+ do j = 1, n1
+ s = s + (Memd[d[j]+k] - med) ** 2 / s1
+ }
+ n2 = n2 + n1
+
+ # Save the median for later.
+ median[i] = med
+ }
+
+ # Here is the final sigma.
+ if (n2 > 1)
+ s = sqrt (s / (n2 - 1))
+ else
+ return
+
+ # Compute individual sigmas and iteratively clip.
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 < max (3, maxkeep+1))
+ next
+ nl = 1
+ nh = n1
+ med = median[i]
+
+ repeat {
+ n2 = n1
+ n3 = nl + n1 / 2
+
+ if (n1 >= max (MINCLIP, maxkeep+1) && s > 0.) {
+ if (doscale1) {
+ for (; nl <= n2; nl = nl + 1) {
+ l = Memi[m[nl]+k]
+ s1 = s * sqrt (max (one, (med+zeros[l])/scales[l]))
+ r = (med - Memd[d[nl]+k]) / s1
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ l = Memi[m[nh]+k]
+ s1 = s * sqrt (max (one, (med+zeros[l])/scales[l]))
+ r = (Memd[d[nh]+k] - med) / s1
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ } else {
+ s1 = s * sqrt (max (one, med))
+ for (; nl <= n2; nl = nl + 1) {
+ r = (med - Memd[d[nl]+k]) / s1
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ r = (Memd[d[nh]+k] - med) / s1
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+
+ # Recompute median
+ if (n1 < n2) {
+ if (n1 > 0) {
+ n3 = nl + n1 / 2
+ if (mod (n1, 2) == 0) {
+ low = Memd[d[n3-1]+k]
+ high = Memd[d[n3]+k]
+ med = (low + high) / 2.
+ } else
+ med = Memd[d[n3]+k]
+ } else
+ med = blank
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ # If too many are rejected add some back in.
+ # Pixels with equal residuals are added together.
+ while (n1 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n1 = nh - nl + 1
+
+ # Recompute median
+ if (n1 < n2) {
+ if (n1 > 0) {
+ n3 = nl + n1 / 2
+ if (mod (n1, 2) == 0) {
+ low = Memd[d[n3-1]+k]
+ high = Memd[d[n3]+k]
+ med = (low + high) / 2.
+ } else
+ med = Memd[d[n3]+k]
+ } else
+ med = blank
+ }
+ }
+
+ # Only set median and reorder if needed
+ n[i] = n1
+ if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ j = max (nl, n1 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Memd[d[l]+k] = Memd[d[j]+k]
+ if (grow >= 1.) {
+ mp1 = m[l] + k
+ mp2 = m[j] + k
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+k] = Memi[m[j]+k]
+ j = j + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Memd[d[l]+k] = Memd[d[j]+k]
+ j = j + 1
+ }
+ }
+ }
+
+ if (combine == MEDIAN)
+ median[i] = med
+ }
+
+ # Check if data flag needs to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag that the median is computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
diff --git a/pkg/obsolete/imcombine/generic/icaverage.x b/pkg/obsolete/imcombine/generic/icaverage.x
new file mode 100644
index 00000000..a2f6498d
--- /dev/null
+++ b/pkg/obsolete/imcombine/generic/icaverage.x
@@ -0,0 +1,337 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include "../icombine.h"
+
+
+# IC_AVERAGE -- Compute the average image line.
+# Options include a weight average.
+
+procedure ic_averages (d, m, n, wts, npts, doblank, average)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image ID pointers
+int n[npts] # Number of points
+real wts[ARB] # Weights
+int npts # Number of output points per line
+int doblank # Set blank values?
+real average[npts] # Average (returned)
+
+int i, j, k
+real sumwt, wt
+real sum
+
+include "../icombine.com"
+
+begin
+ # If no data has been excluded do the average without checking the
+ # number of points and using the fact that the weights are normalized.
+ # If all the data has been excluded set the average to the blank value
+ # if requested.
+
+ if (dflag == D_ALL) {
+ if (dowts) {
+ do i = 1, npts {
+ k = i - 1
+ wt = wts[Memi[m[1]+k]]
+ sum = Mems[d[1]+k] * wt
+ do j = 2, n[i] {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + Mems[d[j]+k] * wt
+ }
+ average[i] = sum
+ }
+ } else {
+ do i = 1, npts {
+ k = i - 1
+ sum = Mems[d[1]+k]
+ do j = 2, n[i]
+ sum = sum + Mems[d[j]+k]
+ average[i] = sum / n[i]
+ }
+ }
+ } else if (dflag == D_NONE) {
+ if (doblank == YES) {
+ do i = 1, npts
+ average[i] = blank
+ }
+ } else {
+ if (dowts) {
+ do i = 1, npts {
+ if (n[i] > 0) {
+ k = i - 1
+ wt = wts[Memi[m[1]+k]]
+ sum = Mems[d[1]+k] * wt
+ sumwt = wt
+ do j = 2, n[i] {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + Mems[d[j]+k] * wt
+ sumwt = sumwt + wt
+ }
+ average[i] = sum / sumwt
+ } else if (doblank == YES)
+ average[i] = blank
+ }
+ } else {
+ do i = 1, npts {
+ if (n[i] > 0) {
+ k = i - 1
+ sum = Mems[d[1]+k]
+ do j = 2, n[i]
+ sum = sum + Mems[d[j]+k]
+ average[i] = sum / n[i]
+ } else if (doblank == YES)
+ average[i] = blank
+ }
+ }
+ }
+end
+
+# IC_AVERAGE -- Compute the average image line.
+# Options include a weight average.
+
+procedure ic_averagei (d, m, n, wts, npts, doblank, average)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image ID pointers
+int n[npts] # Number of points
+real wts[ARB] # Weights
+int npts # Number of output points per line
+int doblank # Set blank values?
+real average[npts] # Average (returned)
+
+int i, j, k
+real sumwt, wt
+real sum
+
+include "../icombine.com"
+
+begin
+ # If no data has been excluded do the average without checking the
+ # number of points and using the fact that the weights are normalized.
+ # If all the data has been excluded set the average to the blank value
+ # if requested.
+
+ if (dflag == D_ALL) {
+ if (dowts) {
+ do i = 1, npts {
+ k = i - 1
+ wt = wts[Memi[m[1]+k]]
+ sum = Memi[d[1]+k] * wt
+ do j = 2, n[i] {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + Memi[d[j]+k] * wt
+ }
+ average[i] = sum
+ }
+ } else {
+ do i = 1, npts {
+ k = i - 1
+ sum = Memi[d[1]+k]
+ do j = 2, n[i]
+ sum = sum + Memi[d[j]+k]
+ average[i] = sum / n[i]
+ }
+ }
+ } else if (dflag == D_NONE) {
+ if (doblank == YES) {
+ do i = 1, npts
+ average[i] = blank
+ }
+ } else {
+ if (dowts) {
+ do i = 1, npts {
+ if (n[i] > 0) {
+ k = i - 1
+ wt = wts[Memi[m[1]+k]]
+ sum = Memi[d[1]+k] * wt
+ sumwt = wt
+ do j = 2, n[i] {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + Memi[d[j]+k] * wt
+ sumwt = sumwt + wt
+ }
+ average[i] = sum / sumwt
+ } else if (doblank == YES)
+ average[i] = blank
+ }
+ } else {
+ do i = 1, npts {
+ if (n[i] > 0) {
+ k = i - 1
+ sum = Memi[d[1]+k]
+ do j = 2, n[i]
+ sum = sum + Memi[d[j]+k]
+ average[i] = sum / n[i]
+ } else if (doblank == YES)
+ average[i] = blank
+ }
+ }
+ }
+end
+
+# IC_AVERAGE -- Compute the average image line.
+# Options include a weight average.
+
+procedure ic_averager (d, m, n, wts, npts, doblank, average)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image ID pointers
+int n[npts] # Number of points
+real wts[ARB] # Weights
+int npts # Number of output points per line
+int doblank # Set blank values?
+real average[npts] # Average (returned)
+
+int i, j, k
+real sumwt, wt
+real sum
+
+include "../icombine.com"
+
+begin
+ # If no data has been excluded do the average without checking the
+ # number of points and using the fact that the weights are normalized.
+ # If all the data has been excluded set the average to the blank value
+ # if requested.
+
+ if (dflag == D_ALL) {
+ if (dowts) {
+ do i = 1, npts {
+ k = i - 1
+ wt = wts[Memi[m[1]+k]]
+ sum = Memr[d[1]+k] * wt
+ do j = 2, n[i] {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + Memr[d[j]+k] * wt
+ }
+ average[i] = sum
+ }
+ } else {
+ do i = 1, npts {
+ k = i - 1
+ sum = Memr[d[1]+k]
+ do j = 2, n[i]
+ sum = sum + Memr[d[j]+k]
+ average[i] = sum / n[i]
+ }
+ }
+ } else if (dflag == D_NONE) {
+ if (doblank == YES) {
+ do i = 1, npts
+ average[i] = blank
+ }
+ } else {
+ if (dowts) {
+ do i = 1, npts {
+ if (n[i] > 0) {
+ k = i - 1
+ wt = wts[Memi[m[1]+k]]
+ sum = Memr[d[1]+k] * wt
+ sumwt = wt
+ do j = 2, n[i] {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + Memr[d[j]+k] * wt
+ sumwt = sumwt + wt
+ }
+ average[i] = sum / sumwt
+ } else if (doblank == YES)
+ average[i] = blank
+ }
+ } else {
+ do i = 1, npts {
+ if (n[i] > 0) {
+ k = i - 1
+ sum = Memr[d[1]+k]
+ do j = 2, n[i]
+ sum = sum + Memr[d[j]+k]
+ average[i] = sum / n[i]
+ } else if (doblank == YES)
+ average[i] = blank
+ }
+ }
+ }
+end
+
+# IC_AVERAGE -- Compute the average image line.
+# Options include a weight average.
+
+procedure ic_averaged (d, m, n, wts, npts, doblank, average)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image ID pointers
+int n[npts] # Number of points
+real wts[ARB] # Weights
+int npts # Number of output points per line
+int doblank # Set blank values?
+double average[npts] # Average (returned)
+
+int i, j, k
+real sumwt, wt
+double sum
+
+include "../icombine.com"
+
+begin
+ # If no data has been excluded do the average without checking the
+ # number of points and using the fact that the weights are normalized.
+ # If all the data has been excluded set the average to the blank value
+ # if requested.
+
+ if (dflag == D_ALL) {
+ if (dowts) {
+ do i = 1, npts {
+ k = i - 1
+ wt = wts[Memi[m[1]+k]]
+ sum = Memd[d[1]+k] * wt
+ do j = 2, n[i] {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + Memd[d[j]+k] * wt
+ }
+ average[i] = sum
+ }
+ } else {
+ do i = 1, npts {
+ k = i - 1
+ sum = Memd[d[1]+k]
+ do j = 2, n[i]
+ sum = sum + Memd[d[j]+k]
+ average[i] = sum / n[i]
+ }
+ }
+ } else if (dflag == D_NONE) {
+ if (doblank == YES) {
+ do i = 1, npts
+ average[i] = blank
+ }
+ } else {
+ if (dowts) {
+ do i = 1, npts {
+ if (n[i] > 0) {
+ k = i - 1
+ wt = wts[Memi[m[1]+k]]
+ sum = Memd[d[1]+k] * wt
+ sumwt = wt
+ do j = 2, n[i] {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + Memd[d[j]+k] * wt
+ sumwt = sumwt + wt
+ }
+ average[i] = sum / sumwt
+ } else if (doblank == YES)
+ average[i] = blank
+ }
+ } else {
+ do i = 1, npts {
+ if (n[i] > 0) {
+ k = i - 1
+ sum = Memd[d[1]+k]
+ do j = 2, n[i]
+ sum = sum + Memd[d[j]+k]
+ average[i] = sum / n[i]
+ } else if (doblank == YES)
+ average[i] = blank
+ }
+ }
+ }
+end
diff --git a/pkg/obsolete/imcombine/generic/iccclip.x b/pkg/obsolete/imcombine/generic/iccclip.x
new file mode 100644
index 00000000..bf655477
--- /dev/null
+++ b/pkg/obsolete/imcombine/generic/iccclip.x
@@ -0,0 +1,1790 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include "../icombine.h"
+
+define MINCLIP 2 # Mininum number of images for algorithm
+
+
+# IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average
+
+procedure ic_accdclips (d, m, n, scales, zeros, nm, nimages, npts, average)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+real nm[3,nimages] # Noise model parameters
+int nimages # Number of images
+int npts # Number of output points per line
+real average[npts] # Average
+
+int i, j, k, l, jj, n1, n2, nin, nk, maxkeep
+real d1, low, high, sum, a, s, r, zero
+data zero /0.0/
+pointer sp, resid, dp1, dp2, mp1, mp2
+
+include "../icombine.com"
+
+begin
+ # If there are no pixels go on to the combining. Since the unweighted
+ # average is computed here possibly skip the combining later.
+
+ # There must be at least max (1, nkeep) pixels.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ } else if (dowts || combine != AVERAGE)
+ docombine = true
+ else
+ docombine = false
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # There must be at least two pixels for rejection. The initial
+ # average is the low/high rejected average except in the case of
+ # just two pixels. The rejections are iterated and the average
+ # is recomputed. Corrections for scaling may be performed.
+ # Depending on other flags the image IDs may also need to be adjusted.
+
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 <= max (MINCLIP-1, maxkeep)) {
+ if (!docombine) {
+ if (n1 == 0)
+ average[i] = blank
+ else {
+ sum = Mems[d[1]+k]
+ do j = 2, n1
+ sum = sum + Mems[d[j]+k]
+ average[i] = sum / n1
+ }
+ }
+ next
+ }
+
+ repeat {
+ if (n1 == 2) {
+ sum = Mems[d[1]+k]
+ sum = sum + Mems[d[2]+k]
+ a = sum / 2
+ } else {
+ low = Mems[d[1]+k]
+ high = Mems[d[2]+k]
+ if (low > high) {
+ d1 = low
+ low = high
+ high = d1
+ }
+ sum = 0.
+ do j = 3, n1 {
+ d1 = Mems[d[j]+k]
+ if (d1 < low) {
+ sum = sum + low
+ low = d1
+ } else if (d1 > high) {
+ sum = sum + high
+ high = d1
+ } else
+ sum = sum + d1
+ }
+ a = sum / (n1 - 2)
+ sum = sum + low + high
+ }
+ n2 = n1
+ if (doscale1) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+
+ l = Memi[mp1]
+ s = scales[l]
+ d1 = max (zero, s * (a + zeros[l]))
+ s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s
+
+ d1 = Mems[dp1]
+ r = (d1 - a) / s
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Mems[dp1] = Mems[dp2]
+ Mems[dp2] = d1
+ mp2 = m[n1] + k
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ } else {
+ if (!keepids) {
+ s = max (zero, a)
+ s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2)
+ }
+ for (j=1; j<=n1; j=j+1) {
+ if (keepids) {
+ l = Memi[m[j]+k]
+ s = max (zero, a)
+ s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2)
+ }
+ dp1 = d[j] + k
+ d1 = Mems[dp1]
+ r = (d1 - a) / s
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Mems[dp1] = Mems[dp2]
+ Mems[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ }
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ if (n1 < maxkeep) {
+ nk = maxkeep
+ if (doscale1) {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Mems[dp1]
+ Mems[dp1] = Mems[dp2]
+ Mems[dp2] = d1
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ sum = sum + Mems[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ } else {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Mems[dp1]
+ Mems[dp1] = Mems[dp2]
+ Mems[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ }
+ sum = sum + Mems[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ }
+ }
+
+ n[i] = n1
+ if (!docombine)
+ if (n1 > 0)
+ average[i] = sum / n1
+ else
+ average[i] = blank
+ }
+
+ # Check if the data flag has to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median
+
+procedure ic_mccdclips (d, m, n, scales, zeros, nm, nimages, npts, median)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+real nm[3,nimages] # Noise model
+int nimages # Number of images
+int npts # Number of output points per line
+real median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep
+real r, s
+pointer sp, resid, mp1, mp2
+real med, zero
+data zero /0.0/
+
+include "../icombine.com"
+
+begin
+ # There must be at least max (MINCLIP, nkeep+1) pixels.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Compute median and sigma and iteratively clip.
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ nl = 1
+ nh = n1
+
+ repeat {
+ n2 = n1
+ n3 = nl + n1 / 2
+
+ if (n1 == 0)
+ med = blank
+ else if (mod (n1, 2) == 0) {
+ med = Mems[d[n3-1]+k]
+ med = (med + Mems[d[n3]+k]) / 2.
+ } else
+ med = Mems[d[n3]+k]
+
+ if (n1 >= max (MINCLIP, maxkeep+1)) {
+ if (doscale1) {
+ for (; nl <= n2; nl = nl + 1) {
+ l = Memi[m[nl]+k]
+ s = scales[l]
+ r = max (zero, s * (med + zeros[l]))
+ s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s
+ r = (med - Mems[d[nl]+k]) / s
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ l = Memi[m[nh]+k]
+ s = scales[l]
+ r = max (zero, s * (med + zeros[l]))
+ s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s
+ r = (Mems[d[nh]+k] - med) / s
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ } else {
+ if (!keepids) {
+ s = max (zero, med)
+ s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2)
+ }
+ for (; nl <= n2; nl = nl + 1) {
+ if (keepids) {
+ l = Memi[m[nl]+k]
+ s = max (zero, med)
+ s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2)
+ }
+ r = (med - Mems[d[nl]+k]) / s
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ if (keepids) {
+ l = Memi[m[nh]+k]
+ s = max (zero, med)
+ s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2)
+ }
+ r = (Mems[d[nh]+k] - med) / s
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ while (n1 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n1 = nh - nl + 1
+ }
+
+ # Only set median and reorder if needed
+ n[i] = n1
+ if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ j = max (nl, n1 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Mems[d[l]+k] = Mems[d[j]+k]
+ if (grow >= 1.) {
+ mp1 = m[l] + k
+ mp2 = m[j] + k
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+k] = Memi[m[j]+k]
+ j = j + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Mems[d[l]+k] = Mems[d[j]+k]
+ j = j + 1
+ }
+ }
+ }
+
+ if (combine == MEDIAN)
+ median[i] = med
+ }
+
+ # Check if data flag needs to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag that the median is computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+
+# IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average
+
+procedure ic_accdclipi (d, m, n, scales, zeros, nm, nimages, npts, average)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+real nm[3,nimages] # Noise model parameters
+int nimages # Number of images
+int npts # Number of output points per line
+real average[npts] # Average
+
+int i, j, k, l, jj, n1, n2, nin, nk, maxkeep
+real d1, low, high, sum, a, s, r, zero
+data zero /0.0/
+pointer sp, resid, dp1, dp2, mp1, mp2
+
+include "../icombine.com"
+
+begin
+ # If there are no pixels go on to the combining. Since the unweighted
+ # average is computed here possibly skip the combining later.
+
+ # There must be at least max (1, nkeep) pixels.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ } else if (dowts || combine != AVERAGE)
+ docombine = true
+ else
+ docombine = false
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # There must be at least two pixels for rejection. The initial
+ # average is the low/high rejected average except in the case of
+ # just two pixels. The rejections are iterated and the average
+ # is recomputed. Corrections for scaling may be performed.
+ # Depending on other flags the image IDs may also need to be adjusted.
+
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 <= max (MINCLIP-1, maxkeep)) {
+ if (!docombine) {
+ if (n1 == 0)
+ average[i] = blank
+ else {
+ sum = Memi[d[1]+k]
+ do j = 2, n1
+ sum = sum + Memi[d[j]+k]
+ average[i] = sum / n1
+ }
+ }
+ next
+ }
+
+ repeat {
+ if (n1 == 2) {
+ sum = Memi[d[1]+k]
+ sum = sum + Memi[d[2]+k]
+ a = sum / 2
+ } else {
+ low = Memi[d[1]+k]
+ high = Memi[d[2]+k]
+ if (low > high) {
+ d1 = low
+ low = high
+ high = d1
+ }
+ sum = 0.
+ do j = 3, n1 {
+ d1 = Memi[d[j]+k]
+ if (d1 < low) {
+ sum = sum + low
+ low = d1
+ } else if (d1 > high) {
+ sum = sum + high
+ high = d1
+ } else
+ sum = sum + d1
+ }
+ a = sum / (n1 - 2)
+ sum = sum + low + high
+ }
+ n2 = n1
+ if (doscale1) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+
+ l = Memi[mp1]
+ s = scales[l]
+ d1 = max (zero, s * (a + zeros[l]))
+ s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s
+
+ d1 = Memi[dp1]
+ r = (d1 - a) / s
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memi[dp1] = Memi[dp2]
+ Memi[dp2] = d1
+ mp2 = m[n1] + k
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ } else {
+ if (!keepids) {
+ s = max (zero, a)
+ s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2)
+ }
+ for (j=1; j<=n1; j=j+1) {
+ if (keepids) {
+ l = Memi[m[j]+k]
+ s = max (zero, a)
+ s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2)
+ }
+ dp1 = d[j] + k
+ d1 = Memi[dp1]
+ r = (d1 - a) / s
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memi[dp1] = Memi[dp2]
+ Memi[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ }
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ if (n1 < maxkeep) {
+ nk = maxkeep
+ if (doscale1) {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memi[dp1]
+ Memi[dp1] = Memi[dp2]
+ Memi[dp2] = d1
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ sum = sum + Memi[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ } else {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memi[dp1]
+ Memi[dp1] = Memi[dp2]
+ Memi[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ }
+ sum = sum + Memi[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ }
+ }
+
+ n[i] = n1
+ if (!docombine)
+ if (n1 > 0)
+ average[i] = sum / n1
+ else
+ average[i] = blank
+ }
+
+ # Check if the data flag has to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median
+
+procedure ic_mccdclipi (d, m, n, scales, zeros, nm, nimages, npts, median)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+real nm[3,nimages] # Noise model
+int nimages # Number of images
+int npts # Number of output points per line
+real median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep
+real r, s
+pointer sp, resid, mp1, mp2
+real med, zero
+data zero /0.0/
+
+include "../icombine.com"
+
+begin
+ # There must be at least max (MINCLIP, nkeep+1) pixels.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Compute median and sigma and iteratively clip.
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ nl = 1
+ nh = n1
+
+ repeat {
+ n2 = n1
+ n3 = nl + n1 / 2
+
+ if (n1 == 0)
+ med = blank
+ else if (mod (n1, 2) == 0) {
+ med = Memi[d[n3-1]+k]
+ med = (med + Memi[d[n3]+k]) / 2.
+ } else
+ med = Memi[d[n3]+k]
+
+ if (n1 >= max (MINCLIP, maxkeep+1)) {
+ if (doscale1) {
+ for (; nl <= n2; nl = nl + 1) {
+ l = Memi[m[nl]+k]
+ s = scales[l]
+ r = max (zero, s * (med + zeros[l]))
+ s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s
+ r = (med - Memi[d[nl]+k]) / s
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ l = Memi[m[nh]+k]
+ s = scales[l]
+ r = max (zero, s * (med + zeros[l]))
+ s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s
+ r = (Memi[d[nh]+k] - med) / s
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ } else {
+ if (!keepids) {
+ s = max (zero, med)
+ s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2)
+ }
+ for (; nl <= n2; nl = nl + 1) {
+ if (keepids) {
+ l = Memi[m[nl]+k]
+ s = max (zero, med)
+ s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2)
+ }
+ r = (med - Memi[d[nl]+k]) / s
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ if (keepids) {
+ l = Memi[m[nh]+k]
+ s = max (zero, med)
+ s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2)
+ }
+ r = (Memi[d[nh]+k] - med) / s
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ while (n1 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n1 = nh - nl + 1
+ }
+
+ # Only set median and reorder if needed
+ n[i] = n1
+ if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ j = max (nl, n1 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Memi[d[l]+k] = Memi[d[j]+k]
+ if (grow >= 1.) {
+ mp1 = m[l] + k
+ mp2 = m[j] + k
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+k] = Memi[m[j]+k]
+ j = j + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Memi[d[l]+k] = Memi[d[j]+k]
+ j = j + 1
+ }
+ }
+ }
+
+ if (combine == MEDIAN)
+ median[i] = med
+ }
+
+ # Check if data flag needs to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag that the median is computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+
+# IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average
+
+procedure ic_accdclipr (d, m, n, scales, zeros, nm, nimages, npts, average)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+real nm[3,nimages] # Noise model parameters
+int nimages # Number of images
+int npts # Number of output points per line
+real average[npts] # Average
+
+int i, j, k, l, jj, n1, n2, nin, nk, maxkeep
+real d1, low, high, sum, a, s, r, zero
+data zero /0.0/
+pointer sp, resid, dp1, dp2, mp1, mp2
+
+include "../icombine.com"
+
+begin
+ # If there are no pixels go on to the combining. Since the unweighted
+ # average is computed here possibly skip the combining later.
+
+ # There must be at least max (1, nkeep) pixels.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ } else if (dowts || combine != AVERAGE)
+ docombine = true
+ else
+ docombine = false
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # There must be at least two pixels for rejection. The initial
+ # average is the low/high rejected average except in the case of
+ # just two pixels. The rejections are iterated and the average
+ # is recomputed. Corrections for scaling may be performed.
+ # Depending on other flags the image IDs may also need to be adjusted.
+
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 <= max (MINCLIP-1, maxkeep)) {
+ if (!docombine) {
+ if (n1 == 0)
+ average[i] = blank
+ else {
+ sum = Memr[d[1]+k]
+ do j = 2, n1
+ sum = sum + Memr[d[j]+k]
+ average[i] = sum / n1
+ }
+ }
+ next
+ }
+
+ repeat {
+ if (n1 == 2) {
+ sum = Memr[d[1]+k]
+ sum = sum + Memr[d[2]+k]
+ a = sum / 2
+ } else {
+ low = Memr[d[1]+k]
+ high = Memr[d[2]+k]
+ if (low > high) {
+ d1 = low
+ low = high
+ high = d1
+ }
+ sum = 0.
+ do j = 3, n1 {
+ d1 = Memr[d[j]+k]
+ if (d1 < low) {
+ sum = sum + low
+ low = d1
+ } else if (d1 > high) {
+ sum = sum + high
+ high = d1
+ } else
+ sum = sum + d1
+ }
+ a = sum / (n1 - 2)
+ sum = sum + low + high
+ }
+ n2 = n1
+ if (doscale1) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+
+ l = Memi[mp1]
+ s = scales[l]
+ d1 = max (zero, s * (a + zeros[l]))
+ s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s
+
+ d1 = Memr[dp1]
+ r = (d1 - a) / s
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memr[dp1] = Memr[dp2]
+ Memr[dp2] = d1
+ mp2 = m[n1] + k
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ } else {
+ if (!keepids) {
+ s = max (zero, a)
+ s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2)
+ }
+ for (j=1; j<=n1; j=j+1) {
+ if (keepids) {
+ l = Memi[m[j]+k]
+ s = max (zero, a)
+ s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2)
+ }
+ dp1 = d[j] + k
+ d1 = Memr[dp1]
+ r = (d1 - a) / s
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memr[dp1] = Memr[dp2]
+ Memr[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ }
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ if (n1 < maxkeep) {
+ nk = maxkeep
+ if (doscale1) {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memr[dp1]
+ Memr[dp1] = Memr[dp2]
+ Memr[dp2] = d1
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ sum = sum + Memr[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ } else {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memr[dp1]
+ Memr[dp1] = Memr[dp2]
+ Memr[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ }
+ sum = sum + Memr[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ }
+ }
+
+ n[i] = n1
+ if (!docombine)
+ if (n1 > 0)
+ average[i] = sum / n1
+ else
+ average[i] = blank
+ }
+
+ # Check if the data flag has to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median
+
+procedure ic_mccdclipr (d, m, n, scales, zeros, nm, nimages, npts, median)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+real nm[3,nimages] # Noise model
+int nimages # Number of images
+int npts # Number of output points per line
+real median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep
+real r, s
+pointer sp, resid, mp1, mp2
+real med, zero
+data zero /0.0/
+
+include "../icombine.com"
+
+begin
+ # There must be at least max (MINCLIP, nkeep+1) pixels.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Compute median and sigma and iteratively clip.
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ nl = 1
+ nh = n1
+
+ repeat {
+ n2 = n1
+ n3 = nl + n1 / 2
+
+ if (n1 == 0)
+ med = blank
+ else if (mod (n1, 2) == 0) {
+ med = Memr[d[n3-1]+k]
+ med = (med + Memr[d[n3]+k]) / 2.
+ } else
+ med = Memr[d[n3]+k]
+
+ if (n1 >= max (MINCLIP, maxkeep+1)) {
+ if (doscale1) {
+ for (; nl <= n2; nl = nl + 1) {
+ l = Memi[m[nl]+k]
+ s = scales[l]
+ r = max (zero, s * (med + zeros[l]))
+ s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s
+ r = (med - Memr[d[nl]+k]) / s
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ l = Memi[m[nh]+k]
+ s = scales[l]
+ r = max (zero, s * (med + zeros[l]))
+ s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s
+ r = (Memr[d[nh]+k] - med) / s
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ } else {
+ if (!keepids) {
+ s = max (zero, med)
+ s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2)
+ }
+ for (; nl <= n2; nl = nl + 1) {
+ if (keepids) {
+ l = Memi[m[nl]+k]
+ s = max (zero, med)
+ s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2)
+ }
+ r = (med - Memr[d[nl]+k]) / s
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ if (keepids) {
+ l = Memi[m[nh]+k]
+ s = max (zero, med)
+ s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2)
+ }
+ r = (Memr[d[nh]+k] - med) / s
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ while (n1 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n1 = nh - nl + 1
+ }
+
+ # Only set median and reorder if needed
+ n[i] = n1
+ if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ j = max (nl, n1 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Memr[d[l]+k] = Memr[d[j]+k]
+ if (grow >= 1.) {
+ mp1 = m[l] + k
+ mp2 = m[j] + k
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+k] = Memi[m[j]+k]
+ j = j + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Memr[d[l]+k] = Memr[d[j]+k]
+ j = j + 1
+ }
+ }
+ }
+
+ if (combine == MEDIAN)
+ median[i] = med
+ }
+
+ # Check if data flag needs to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag that the median is computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+
+# IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average
+
+procedure ic_accdclipd (d, m, n, scales, zeros, nm, nimages, npts, average)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+real nm[3,nimages] # Noise model parameters
+int nimages # Number of images
+int npts # Number of output points per line
+double average[npts] # Average
+
+int i, j, k, l, jj, n1, n2, nin, nk, maxkeep
+double d1, low, high, sum, a, s, r, zero
+data zero /0.0D0/
+pointer sp, resid, dp1, dp2, mp1, mp2
+
+include "../icombine.com"
+
+begin
+ # If there are no pixels go on to the combining. Since the unweighted
+ # average is computed here possibly skip the combining later.
+
+ # There must be at least max (1, nkeep) pixels.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ } else if (dowts || combine != AVERAGE)
+ docombine = true
+ else
+ docombine = false
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # There must be at least two pixels for rejection. The initial
+ # average is the low/high rejected average except in the case of
+ # just two pixels. The rejections are iterated and the average
+ # is recomputed. Corrections for scaling may be performed.
+ # Depending on other flags the image IDs may also need to be adjusted.
+
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 <= max (MINCLIP-1, maxkeep)) {
+ if (!docombine) {
+ if (n1 == 0)
+ average[i] = blank
+ else {
+ sum = Memd[d[1]+k]
+ do j = 2, n1
+ sum = sum + Memd[d[j]+k]
+ average[i] = sum / n1
+ }
+ }
+ next
+ }
+
+ repeat {
+ if (n1 == 2) {
+ sum = Memd[d[1]+k]
+ sum = sum + Memd[d[2]+k]
+ a = sum / 2
+ } else {
+ low = Memd[d[1]+k]
+ high = Memd[d[2]+k]
+ if (low > high) {
+ d1 = low
+ low = high
+ high = d1
+ }
+ sum = 0.
+ do j = 3, n1 {
+ d1 = Memd[d[j]+k]
+ if (d1 < low) {
+ sum = sum + low
+ low = d1
+ } else if (d1 > high) {
+ sum = sum + high
+ high = d1
+ } else
+ sum = sum + d1
+ }
+ a = sum / (n1 - 2)
+ sum = sum + low + high
+ }
+ n2 = n1
+ if (doscale1) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+
+ l = Memi[mp1]
+ s = scales[l]
+ d1 = max (zero, s * (a + zeros[l]))
+ s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s
+
+ d1 = Memd[dp1]
+ r = (d1 - a) / s
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memd[dp1] = Memd[dp2]
+ Memd[dp2] = d1
+ mp2 = m[n1] + k
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ } else {
+ if (!keepids) {
+ s = max (zero, a)
+ s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2)
+ }
+ for (j=1; j<=n1; j=j+1) {
+ if (keepids) {
+ l = Memi[m[j]+k]
+ s = max (zero, a)
+ s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2)
+ }
+ dp1 = d[j] + k
+ d1 = Memd[dp1]
+ r = (d1 - a) / s
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memd[dp1] = Memd[dp2]
+ Memd[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ }
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ if (n1 < maxkeep) {
+ nk = maxkeep
+ if (doscale1) {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memd[dp1]
+ Memd[dp1] = Memd[dp2]
+ Memd[dp2] = d1
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ sum = sum + Memd[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ } else {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memd[dp1]
+ Memd[dp1] = Memd[dp2]
+ Memd[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ }
+ sum = sum + Memd[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ }
+ }
+
+ n[i] = n1
+ if (!docombine)
+ if (n1 > 0)
+ average[i] = sum / n1
+ else
+ average[i] = blank
+ }
+
+ # Check if the data flag has to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median
+
+procedure ic_mccdclipd (d, m, n, scales, zeros, nm, nimages, npts, median)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+real nm[3,nimages] # Noise model
+int nimages # Number of images
+int npts # Number of output points per line
+double median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep
+real r, s
+pointer sp, resid, mp1, mp2
+double med, zero
+data zero /0.0D0/
+
+include "../icombine.com"
+
+begin
+ # There must be at least max (MINCLIP, nkeep+1) pixels.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Compute median and sigma and iteratively clip.
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ nl = 1
+ nh = n1
+
+ repeat {
+ n2 = n1
+ n3 = nl + n1 / 2
+
+ if (n1 == 0)
+ med = blank
+ else if (mod (n1, 2) == 0) {
+ med = Memd[d[n3-1]+k]
+ med = (med + Memd[d[n3]+k]) / 2.
+ } else
+ med = Memd[d[n3]+k]
+
+ if (n1 >= max (MINCLIP, maxkeep+1)) {
+ if (doscale1) {
+ for (; nl <= n2; nl = nl + 1) {
+ l = Memi[m[nl]+k]
+ s = scales[l]
+ r = max (zero, s * (med + zeros[l]))
+ s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s
+ r = (med - Memd[d[nl]+k]) / s
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ l = Memi[m[nh]+k]
+ s = scales[l]
+ r = max (zero, s * (med + zeros[l]))
+ s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s
+ r = (Memd[d[nh]+k] - med) / s
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ } else {
+ if (!keepids) {
+ s = max (zero, med)
+ s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2)
+ }
+ for (; nl <= n2; nl = nl + 1) {
+ if (keepids) {
+ l = Memi[m[nl]+k]
+ s = max (zero, med)
+ s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2)
+ }
+ r = (med - Memd[d[nl]+k]) / s
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ if (keepids) {
+ l = Memi[m[nh]+k]
+ s = max (zero, med)
+ s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2)
+ }
+ r = (Memd[d[nh]+k] - med) / s
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ while (n1 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n1 = nh - nl + 1
+ }
+
+ # Only set median and reorder if needed
+ n[i] = n1
+ if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ j = max (nl, n1 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Memd[d[l]+k] = Memd[d[j]+k]
+ if (grow >= 1.) {
+ mp1 = m[l] + k
+ mp2 = m[j] + k
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+k] = Memi[m[j]+k]
+ j = j + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Memd[d[l]+k] = Memd[d[j]+k]
+ j = j + 1
+ }
+ }
+ }
+
+ if (combine == MEDIAN)
+ median[i] = med
+ }
+
+ # Check if data flag needs to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag that the median is computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
diff --git a/pkg/obsolete/imcombine/generic/icgdata.x b/pkg/obsolete/imcombine/generic/icgdata.x
new file mode 100644
index 00000000..264acc34
--- /dev/null
+++ b/pkg/obsolete/imcombine/generic/icgdata.x
@@ -0,0 +1,918 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include <mach.h>
+include "../icombine.h"
+
+
+# IC_GDATA -- Get line of image and mask data and apply threshold and scaling.
+# Entirely empty lines are excluded. The data are compacted within the
+# input data buffers. If it is required, the connection to the original
+# image index is kept in the returned m data pointers.
+
+procedure ic_gdatas (in, out, dbuf, d, id, n, m, lflag, offsets, scales,
+ zeros, nimages, npts, v1, v2)
+
+pointer in[nimages] # Input images
+pointer out[3] # Output images
+pointer dbuf[nimages] # Data buffers
+pointer d[nimages] # Data pointers
+pointer id[nimages] # ID pointers
+int n[npts] # Number of good pixels
+pointer m[nimages] # Mask pointers
+int lflag[nimages] # Empty mask flags
+int offsets[nimages,ARB] # Image offsets
+real scales[nimages] # Scale factors
+real zeros[nimages] # Zero offset factors
+int nimages # Number of input images
+int npts # NUmber of output points per line
+long v1[ARB], v2[ARB] # Line vectors
+
+int i, j, k, l, ndim, nused
+real a, b
+pointer buf, dp, ip, mp, imgnls()
+
+include "../icombine.com"
+
+begin
+ # Get masks and return if there is no data
+ call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages)
+ if (dflag == D_NONE) {
+ call aclri (n, npts)
+ return
+ }
+
+ # Get data and fill data buffers. Correct for offsets if needed.
+ ndim = IM_NDIM(out[1])
+ do i = 1, nimages {
+ if (lflag[i] == D_NONE)
+ next
+ if (dbuf[i] == NULL) {
+ call amovl (v1, v2, IM_MAXDIM)
+ if (project)
+ v2[ndim+1] = i
+ j = imgnls (in[i], d[i], v2)
+ } else {
+ v2[1] = v1[1]
+ do j = 2, ndim
+ v2[j] = v1[j] - offsets[i,j]
+ if (project)
+ v2[ndim+1] = i
+ j = imgnls (in[i], buf, v2)
+ call amovs (Mems[buf], Mems[dbuf[i]+offsets[i,1]],
+ IM_LEN(in[i],1))
+ d[i] = dbuf[i]
+ }
+ }
+
+ # Apply threshold if needed
+ if (dothresh) {
+ do i = 1, nimages {
+ dp = d[i]
+ if (lflag[i] == D_ALL) {
+ do j = 1, npts {
+ a = Mems[dp]
+ if (a < lthresh || a > hthresh) {
+ Memi[m[i]+j-1] = 1
+ lflag[i] = D_MIX
+ dflag = D_MIX
+ }
+ dp = dp + 1
+ }
+ } else if (lflag[i] == D_MIX) {
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ a = Mems[dp]
+ if (a < lthresh || a > hthresh) {
+ Memi[m[i]+j-1] = 1
+ dflag = D_MIX
+ }
+ }
+ dp = dp + 1
+ mp = mp + 1
+ }
+ }
+
+ # Check for completely empty lines
+ if (lflag[i] == D_MIX) {
+ lflag[i] = D_NONE
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ lflag[i] = D_MIX
+ break
+ }
+ mp = mp + 1
+ }
+ }
+ }
+ }
+
+ # Apply scaling (avoiding masked pixels which might overflow?)
+ if (doscale) {
+ if (dflag == D_ALL) {
+ do i = 1, nimages {
+ dp = d[i]
+ a = scales[i]
+ b = -zeros[i]
+ do j = 1, npts {
+ Mems[dp] = Mems[dp] / a + b
+ dp = dp + 1
+ }
+ }
+ } else if (dflag == D_MIX) {
+ do i = 1, nimages {
+ dp = d[i]
+ a = scales[i]
+ b = -zeros[i]
+ if (lflag[i] == D_ALL) {
+ do j = 1, npts {
+ Mems[dp] = Mems[dp] / a + b
+ dp = dp + 1
+ }
+ } else if (lflag[i] == D_MIX) {
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0)
+ Mems[dp] = Mems[dp] / a + b
+ dp = dp + 1
+ mp = mp + 1
+ }
+ }
+ }
+ }
+ }
+
+ # Sort pointers to exclude unused images.
+ # Use the lflag array to keep track of the image index.
+
+ if (dflag == D_ALL)
+ nused = nimages
+ else {
+ nused = 0
+ do i = 1, nimages
+ if (lflag[i] != D_NONE) {
+ nused = nused + 1
+ d[nused] = d[i]
+ m[nused] = m[i]
+ lflag[nused] = i
+ }
+ if (nused == 0)
+ dflag = D_NONE
+ }
+
+ # Compact data to remove bad pixels
+ # Keep track of the image indices if needed
+ # If growing mark the end of the included image indices with zero
+
+ if (dflag == D_ALL) {
+ call amovki (nused, n, npts)
+ if (keepids)
+ do i = 1, nimages
+ call amovki (i, Memi[id[i]], npts)
+ } else if (dflag == D_NONE)
+ call aclri (n, npts)
+ else {
+ call aclri (n, npts)
+ if (keepids) {
+ do i = 1, nused {
+ l = lflag[i]
+ dp = d[i]
+ ip = id[i]
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ n[j] = n[j] + 1
+ k = n[j]
+ if (k < i) {
+ Mems[d[k]+j-1] = Mems[dp]
+ Memi[id[k]+j-1] = l
+ } else
+ Memi[ip] = l
+ }
+ dp = dp + 1
+ ip = ip + 1
+ mp = mp + 1
+ }
+ }
+ if (grow >= 1.) {
+ do j = 1, npts {
+ do i = n[j]+1, nimages
+ Memi[id[i]+j-1] = 0
+ }
+ }
+ } else {
+ do i = 1, nused {
+ dp = d[i]
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ n[j] = n[j] + 1
+ k = n[j]
+ if (k < i)
+ Mems[d[k]+j-1] = Mems[dp]
+ }
+ dp = dp + 1
+ mp = mp + 1
+ }
+ }
+ }
+ }
+
+ # Sort the pixels and IDs if needed
+ if (mclip) {
+ call malloc (dp, nimages, TY_SHORT)
+ if (keepids) {
+ call malloc (ip, nimages, TY_INT)
+ call ic_2sorts (d, Mems[dp], id, Memi[ip], n, npts)
+ call mfree (ip, TY_INT)
+ } else
+ call ic_sorts (d, Mems[dp], n, npts)
+ call mfree (dp, TY_SHORT)
+ }
+end
+
+# IC_GDATA -- Get line of image and mask data and apply threshold and scaling.
+# Entirely empty lines are excluded. The data are compacted within the
+# input data buffers. If it is required, the connection to the original
+# image index is kept in the returned m data pointers.
+
+procedure ic_gdatai (in, out, dbuf, d, id, n, m, lflag, offsets, scales,
+ zeros, nimages, npts, v1, v2)
+
+pointer in[nimages] # Input images
+pointer out[3] # Output images
+pointer dbuf[nimages] # Data buffers
+pointer d[nimages] # Data pointers
+pointer id[nimages] # ID pointers
+int n[npts] # Number of good pixels
+pointer m[nimages] # Mask pointers
+int lflag[nimages] # Empty mask flags
+int offsets[nimages,ARB] # Image offsets
+real scales[nimages] # Scale factors
+real zeros[nimages] # Zero offset factors
+int nimages # Number of input images
+int npts # NUmber of output points per line
+long v1[ARB], v2[ARB] # Line vectors
+
+int i, j, k, l, ndim, nused
+real a, b
+pointer buf, dp, ip, mp, imgnli()
+
+include "../icombine.com"
+
+begin
+ # Get masks and return if there is no data
+ call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages)
+ if (dflag == D_NONE) {
+ call aclri (n, npts)
+ return
+ }
+
+ # Get data and fill data buffers. Correct for offsets if needed.
+ ndim = IM_NDIM(out[1])
+ do i = 1, nimages {
+ if (lflag[i] == D_NONE)
+ next
+ if (dbuf[i] == NULL) {
+ call amovl (v1, v2, IM_MAXDIM)
+ if (project)
+ v2[ndim+1] = i
+ j = imgnli (in[i], d[i], v2)
+ } else {
+ v2[1] = v1[1]
+ do j = 2, ndim
+ v2[j] = v1[j] - offsets[i,j]
+ if (project)
+ v2[ndim+1] = i
+ j = imgnli (in[i], buf, v2)
+ call amovi (Memi[buf], Memi[dbuf[i]+offsets[i,1]],
+ IM_LEN(in[i],1))
+ d[i] = dbuf[i]
+ }
+ }
+
+ # Apply threshold if needed
+ if (dothresh) {
+ do i = 1, nimages {
+ dp = d[i]
+ if (lflag[i] == D_ALL) {
+ do j = 1, npts {
+ a = Memi[dp]
+ if (a < lthresh || a > hthresh) {
+ Memi[m[i]+j-1] = 1
+ lflag[i] = D_MIX
+ dflag = D_MIX
+ }
+ dp = dp + 1
+ }
+ } else if (lflag[i] == D_MIX) {
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ a = Memi[dp]
+ if (a < lthresh || a > hthresh) {
+ Memi[m[i]+j-1] = 1
+ dflag = D_MIX
+ }
+ }
+ dp = dp + 1
+ mp = mp + 1
+ }
+ }
+
+ # Check for completely empty lines
+ if (lflag[i] == D_MIX) {
+ lflag[i] = D_NONE
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ lflag[i] = D_MIX
+ break
+ }
+ mp = mp + 1
+ }
+ }
+ }
+ }
+
+ # Apply scaling (avoiding masked pixels which might overflow?)
+ if (doscale) {
+ if (dflag == D_ALL) {
+ do i = 1, nimages {
+ dp = d[i]
+ a = scales[i]
+ b = -zeros[i]
+ do j = 1, npts {
+ Memi[dp] = Memi[dp] / a + b
+ dp = dp + 1
+ }
+ }
+ } else if (dflag == D_MIX) {
+ do i = 1, nimages {
+ dp = d[i]
+ a = scales[i]
+ b = -zeros[i]
+ if (lflag[i] == D_ALL) {
+ do j = 1, npts {
+ Memi[dp] = Memi[dp] / a + b
+ dp = dp + 1
+ }
+ } else if (lflag[i] == D_MIX) {
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0)
+ Memi[dp] = Memi[dp] / a + b
+ dp = dp + 1
+ mp = mp + 1
+ }
+ }
+ }
+ }
+ }
+
+ # Sort pointers to exclude unused images.
+ # Use the lflag array to keep track of the image index.
+
+ if (dflag == D_ALL)
+ nused = nimages
+ else {
+ nused = 0
+ do i = 1, nimages
+ if (lflag[i] != D_NONE) {
+ nused = nused + 1
+ d[nused] = d[i]
+ m[nused] = m[i]
+ lflag[nused] = i
+ }
+ if (nused == 0)
+ dflag = D_NONE
+ }
+
+ # Compact data to remove bad pixels
+ # Keep track of the image indices if needed
+ # If growing mark the end of the included image indices with zero
+
+ if (dflag == D_ALL) {
+ call amovki (nused, n, npts)
+ if (keepids)
+ do i = 1, nimages
+ call amovki (i, Memi[id[i]], npts)
+ } else if (dflag == D_NONE)
+ call aclri (n, npts)
+ else {
+ call aclri (n, npts)
+ if (keepids) {
+ do i = 1, nused {
+ l = lflag[i]
+ dp = d[i]
+ ip = id[i]
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ n[j] = n[j] + 1
+ k = n[j]
+ if (k < i) {
+ Memi[d[k]+j-1] = Memi[dp]
+ Memi[id[k]+j-1] = l
+ } else
+ Memi[ip] = l
+ }
+ dp = dp + 1
+ ip = ip + 1
+ mp = mp + 1
+ }
+ }
+ if (grow >= 1.) {
+ do j = 1, npts {
+ do i = n[j]+1, nimages
+ Memi[id[i]+j-1] = 0
+ }
+ }
+ } else {
+ do i = 1, nused {
+ dp = d[i]
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ n[j] = n[j] + 1
+ k = n[j]
+ if (k < i)
+ Memi[d[k]+j-1] = Memi[dp]
+ }
+ dp = dp + 1
+ mp = mp + 1
+ }
+ }
+ }
+ }
+
+ # Sort the pixels and IDs if needed
+ if (mclip) {
+ call malloc (dp, nimages, TY_INT)
+ if (keepids) {
+ call malloc (ip, nimages, TY_INT)
+ call ic_2sorti (d, Memi[dp], id, Memi[ip], n, npts)
+ call mfree (ip, TY_INT)
+ } else
+ call ic_sorti (d, Memi[dp], n, npts)
+ call mfree (dp, TY_INT)
+ }
+end
+
+# IC_GDATA -- Get line of image and mask data and apply threshold and scaling.
+# Entirely empty lines are excluded. The data are compacted within the
+# input data buffers. If it is required, the connection to the original
+# image index is kept in the returned m data pointers.
+
+procedure ic_gdatar (in, out, dbuf, d, id, n, m, lflag, offsets, scales,
+ zeros, nimages, npts, v1, v2)
+
+pointer in[nimages] # Input images
+pointer out[3] # Output images
+pointer dbuf[nimages] # Data buffers
+pointer d[nimages] # Data pointers
+pointer id[nimages] # ID pointers
+int n[npts] # Number of good pixels
+pointer m[nimages] # Mask pointers
+int lflag[nimages] # Empty mask flags
+int offsets[nimages,ARB] # Image offsets
+real scales[nimages] # Scale factors
+real zeros[nimages] # Zero offset factors
+int nimages # Number of input images
+int npts # NUmber of output points per line
+long v1[ARB], v2[ARB] # Line vectors
+
+int i, j, k, l, ndim, nused
+real a, b
+pointer buf, dp, ip, mp, imgnlr()
+
+include "../icombine.com"
+
+begin
+ # Get masks and return if there is no data
+ call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages)
+ if (dflag == D_NONE) {
+ call aclri (n, npts)
+ return
+ }
+
+ # Get data and fill data buffers. Correct for offsets if needed.
+ ndim = IM_NDIM(out[1])
+ do i = 1, nimages {
+ if (lflag[i] == D_NONE)
+ next
+ if (dbuf[i] == NULL) {
+ call amovl (v1, v2, IM_MAXDIM)
+ if (project)
+ v2[ndim+1] = i
+ j = imgnlr (in[i], d[i], v2)
+ } else {
+ v2[1] = v1[1]
+ do j = 2, ndim
+ v2[j] = v1[j] - offsets[i,j]
+ if (project)
+ v2[ndim+1] = i
+ j = imgnlr (in[i], buf, v2)
+ call amovr (Memr[buf], Memr[dbuf[i]+offsets[i,1]],
+ IM_LEN(in[i],1))
+ d[i] = dbuf[i]
+ }
+ }
+
+ # Apply threshold if needed
+ if (dothresh) {
+ do i = 1, nimages {
+ dp = d[i]
+ if (lflag[i] == D_ALL) {
+ do j = 1, npts {
+ a = Memr[dp]
+ if (a < lthresh || a > hthresh) {
+ Memi[m[i]+j-1] = 1
+ lflag[i] = D_MIX
+ dflag = D_MIX
+ }
+ dp = dp + 1
+ }
+ } else if (lflag[i] == D_MIX) {
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ a = Memr[dp]
+ if (a < lthresh || a > hthresh) {
+ Memi[m[i]+j-1] = 1
+ dflag = D_MIX
+ }
+ }
+ dp = dp + 1
+ mp = mp + 1
+ }
+ }
+
+ # Check for completely empty lines
+ if (lflag[i] == D_MIX) {
+ lflag[i] = D_NONE
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ lflag[i] = D_MIX
+ break
+ }
+ mp = mp + 1
+ }
+ }
+ }
+ }
+
+ # Apply scaling (avoiding masked pixels which might overflow?)
+ if (doscale) {
+ if (dflag == D_ALL) {
+ do i = 1, nimages {
+ dp = d[i]
+ a = scales[i]
+ b = -zeros[i]
+ do j = 1, npts {
+ Memr[dp] = Memr[dp] / a + b
+ dp = dp + 1
+ }
+ }
+ } else if (dflag == D_MIX) {
+ do i = 1, nimages {
+ dp = d[i]
+ a = scales[i]
+ b = -zeros[i]
+ if (lflag[i] == D_ALL) {
+ do j = 1, npts {
+ Memr[dp] = Memr[dp] / a + b
+ dp = dp + 1
+ }
+ } else if (lflag[i] == D_MIX) {
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0)
+ Memr[dp] = Memr[dp] / a + b
+ dp = dp + 1
+ mp = mp + 1
+ }
+ }
+ }
+ }
+ }
+
+ # Sort pointers to exclude unused images.
+ # Use the lflag array to keep track of the image index.
+
+ if (dflag == D_ALL)
+ nused = nimages
+ else {
+ nused = 0
+ do i = 1, nimages
+ if (lflag[i] != D_NONE) {
+ nused = nused + 1
+ d[nused] = d[i]
+ m[nused] = m[i]
+ lflag[nused] = i
+ }
+ if (nused == 0)
+ dflag = D_NONE
+ }
+
+ # Compact data to remove bad pixels
+ # Keep track of the image indices if needed
+ # If growing mark the end of the included image indices with zero
+
+ if (dflag == D_ALL) {
+ call amovki (nused, n, npts)
+ if (keepids)
+ do i = 1, nimages
+ call amovki (i, Memi[id[i]], npts)
+ } else if (dflag == D_NONE)
+ call aclri (n, npts)
+ else {
+ call aclri (n, npts)
+ if (keepids) {
+ do i = 1, nused {
+ l = lflag[i]
+ dp = d[i]
+ ip = id[i]
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ n[j] = n[j] + 1
+ k = n[j]
+ if (k < i) {
+ Memr[d[k]+j-1] = Memr[dp]
+ Memi[id[k]+j-1] = l
+ } else
+ Memi[ip] = l
+ }
+ dp = dp + 1
+ ip = ip + 1
+ mp = mp + 1
+ }
+ }
+ if (grow >= 1.) {
+ do j = 1, npts {
+ do i = n[j]+1, nimages
+ Memi[id[i]+j-1] = 0
+ }
+ }
+ } else {
+ do i = 1, nused {
+ dp = d[i]
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ n[j] = n[j] + 1
+ k = n[j]
+ if (k < i)
+ Memr[d[k]+j-1] = Memr[dp]
+ }
+ dp = dp + 1
+ mp = mp + 1
+ }
+ }
+ }
+ }
+
+ # Sort the pixels and IDs if needed
+ if (mclip) {
+ call malloc (dp, nimages, TY_REAL)
+ if (keepids) {
+ call malloc (ip, nimages, TY_INT)
+ call ic_2sortr (d, Memr[dp], id, Memi[ip], n, npts)
+ call mfree (ip, TY_INT)
+ } else
+ call ic_sortr (d, Memr[dp], n, npts)
+ call mfree (dp, TY_REAL)
+ }
+end
+
+# IC_GDATA -- Get line of image and mask data and apply threshold and scaling.
+# Entirely empty lines are excluded. The data are compacted within the
+# input data buffers. If it is required, the connection to the original
+# image index is kept in the returned m data pointers.
+
+procedure ic_gdatad (in, out, dbuf, d, id, n, m, lflag, offsets, scales,
+ zeros, nimages, npts, v1, v2)
+
+pointer in[nimages] # Input images
+pointer out[3] # Output images
+pointer dbuf[nimages] # Data buffers
+pointer d[nimages] # Data pointers
+pointer id[nimages] # ID pointers
+int n[npts] # Number of good pixels
+pointer m[nimages] # Mask pointers
+int lflag[nimages] # Empty mask flags
+int offsets[nimages,ARB] # Image offsets
+real scales[nimages] # Scale factors
+real zeros[nimages] # Zero offset factors
+int nimages # Number of input images
+int npts # NUmber of output points per line
+long v1[ARB], v2[ARB] # Line vectors
+
+int i, j, k, l, ndim, nused
+real a, b
+pointer buf, dp, ip, mp, imgnld()
+
+include "../icombine.com"
+
+begin
+ # Get masks and return if there is no data
+ call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages)
+ if (dflag == D_NONE) {
+ call aclri (n, npts)
+ return
+ }
+
+ # Get data and fill data buffers. Correct for offsets if needed.
+ ndim = IM_NDIM(out[1])
+ do i = 1, nimages {
+ if (lflag[i] == D_NONE)
+ next
+ if (dbuf[i] == NULL) {
+ call amovl (v1, v2, IM_MAXDIM)
+ if (project)
+ v2[ndim+1] = i
+ j = imgnld (in[i], d[i], v2)
+ } else {
+ v2[1] = v1[1]
+ do j = 2, ndim
+ v2[j] = v1[j] - offsets[i,j]
+ if (project)
+ v2[ndim+1] = i
+ j = imgnld (in[i], buf, v2)
+ call amovd (Memd[buf], Memd[dbuf[i]+offsets[i,1]],
+ IM_LEN(in[i],1))
+ d[i] = dbuf[i]
+ }
+ }
+
+ # Apply threshold if needed
+ if (dothresh) {
+ do i = 1, nimages {
+ dp = d[i]
+ if (lflag[i] == D_ALL) {
+ do j = 1, npts {
+ a = Memd[dp]
+ if (a < lthresh || a > hthresh) {
+ Memi[m[i]+j-1] = 1
+ lflag[i] = D_MIX
+ dflag = D_MIX
+ }
+ dp = dp + 1
+ }
+ } else if (lflag[i] == D_MIX) {
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ a = Memd[dp]
+ if (a < lthresh || a > hthresh) {
+ Memi[m[i]+j-1] = 1
+ dflag = D_MIX
+ }
+ }
+ dp = dp + 1
+ mp = mp + 1
+ }
+ }
+
+ # Check for completely empty lines
+ if (lflag[i] == D_MIX) {
+ lflag[i] = D_NONE
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ lflag[i] = D_MIX
+ break
+ }
+ mp = mp + 1
+ }
+ }
+ }
+ }
+
+ # Apply scaling (avoiding masked pixels which might overflow?)
+ if (doscale) {
+ if (dflag == D_ALL) {
+ do i = 1, nimages {
+ dp = d[i]
+ a = scales[i]
+ b = -zeros[i]
+ do j = 1, npts {
+ Memd[dp] = Memd[dp] / a + b
+ dp = dp + 1
+ }
+ }
+ } else if (dflag == D_MIX) {
+ do i = 1, nimages {
+ dp = d[i]
+ a = scales[i]
+ b = -zeros[i]
+ if (lflag[i] == D_ALL) {
+ do j = 1, npts {
+ Memd[dp] = Memd[dp] / a + b
+ dp = dp + 1
+ }
+ } else if (lflag[i] == D_MIX) {
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0)
+ Memd[dp] = Memd[dp] / a + b
+ dp = dp + 1
+ mp = mp + 1
+ }
+ }
+ }
+ }
+ }
+
+ # Sort pointers to exclude unused images.
+ # Use the lflag array to keep track of the image index.
+
+ if (dflag == D_ALL)
+ nused = nimages
+ else {
+ nused = 0
+ do i = 1, nimages
+ if (lflag[i] != D_NONE) {
+ nused = nused + 1
+ d[nused] = d[i]
+ m[nused] = m[i]
+ lflag[nused] = i
+ }
+ if (nused == 0)
+ dflag = D_NONE
+ }
+
+ # Compact data to remove bad pixels
+ # Keep track of the image indices if needed
+ # If growing mark the end of the included image indices with zero
+
+ if (dflag == D_ALL) {
+ call amovki (nused, n, npts)
+ if (keepids)
+ do i = 1, nimages
+ call amovki (i, Memi[id[i]], npts)
+ } else if (dflag == D_NONE)
+ call aclri (n, npts)
+ else {
+ call aclri (n, npts)
+ if (keepids) {
+ do i = 1, nused {
+ l = lflag[i]
+ dp = d[i]
+ ip = id[i]
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ n[j] = n[j] + 1
+ k = n[j]
+ if (k < i) {
+ Memd[d[k]+j-1] = Memd[dp]
+ Memi[id[k]+j-1] = l
+ } else
+ Memi[ip] = l
+ }
+ dp = dp + 1
+ ip = ip + 1
+ mp = mp + 1
+ }
+ }
+ if (grow >= 1.) {
+ do j = 1, npts {
+ do i = n[j]+1, nimages
+ Memi[id[i]+j-1] = 0
+ }
+ }
+ } else {
+ do i = 1, nused {
+ dp = d[i]
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ n[j] = n[j] + 1
+ k = n[j]
+ if (k < i)
+ Memd[d[k]+j-1] = Memd[dp]
+ }
+ dp = dp + 1
+ mp = mp + 1
+ }
+ }
+ }
+ }
+
+ # Sort the pixels and IDs if needed
+ if (mclip) {
+ call malloc (dp, nimages, TY_DOUBLE)
+ if (keepids) {
+ call malloc (ip, nimages, TY_INT)
+ call ic_2sortd (d, Memd[dp], id, Memi[ip], n, npts)
+ call mfree (ip, TY_INT)
+ } else
+ call ic_sortd (d, Memd[dp], n, npts)
+ call mfree (dp, TY_DOUBLE)
+ }
+end
diff --git a/pkg/obsolete/imcombine/generic/icgrow.x b/pkg/obsolete/imcombine/generic/icgrow.x
new file mode 100644
index 00000000..d47af927
--- /dev/null
+++ b/pkg/obsolete/imcombine/generic/icgrow.x
@@ -0,0 +1,251 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include <pmset.h>
+include "../icombine.h"
+
+# IC_GROW -- Mark neigbors of rejected pixels.
+# The rejected pixels (original plus grown) are saved in pixel masks.
+
+procedure ic_grow (out, v, m, n, buf, nimages, npts, pms)
+
+pointer out # Output image pointer
+long v[ARB] # Output vector
+pointer m[ARB] # Image id pointers
+int n[ARB] # Number of good pixels
+int buf[npts,nimages] # Working buffer
+int nimages # Number of images
+int npts # Number of output points per line
+pointer pms # Pointer to array of pixel masks
+
+int i, j, k, l, line, nl, rop, igrow, nset, or()
+real grow2, i2
+pointer mp, pm, pm_newmask()
+errchk pm_newmask()
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_NONE || grow == 0.)
+ return
+
+ line = v[2]
+ nl = IM_LEN(out,2)
+ rop = or (PIX_SRC, PIX_DST)
+
+ igrow = grow
+ grow2 = grow**2
+ do l = 0, igrow {
+ i2 = grow2 - l * l
+ call aclri (buf, npts*nimages)
+ nset = 0
+ do j = 1, npts {
+ do k = n[j]+1, nimages {
+ mp = Memi[m[k]+j-1]
+ if (mp == 0)
+ next
+ do i = 0, igrow {
+ if (i**2 > i2)
+ next
+ if (j > i)
+ buf[j-i,mp] = 1
+ if (j+i <= npts)
+ buf[j+i,mp] = 1
+ nset = nset + 1
+ }
+ }
+ }
+ if (nset == 0)
+ return
+
+ if (pms == NULL) {
+ call malloc (pms, nimages, TY_POINTER)
+ do i = 1, nimages
+ Memi[pms+i-1] = pm_newmask (out, 1)
+ }
+ do i = 1, nimages {
+ pm = Memi[pms+i-1]
+ v[2] = line - l
+ if (v[2] > 0)
+ call pmplpi (pm, v, buf[1,i], 1, npts, rop)
+ v[2] = line + l
+ if (v[2] <= nl)
+ call pmplpi (pm, v, buf[1,i], 1, npts, rop)
+ }
+ }
+ v[2] = line
+end
+
+
+
+# IC_GROW$T -- Reject pixels.
+
+procedure ic_grows (v, d, m, n, buf, nimages, npts, pms)
+
+long v[ARB] # Output vector
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image id pointers
+int n[ARB] # Number of good pixels
+int buf[ARB] # Buffer of npts
+int nimages # Number of images
+int npts # Number of output points per line
+pointer pms # Pointer to array of pixel masks
+
+int i, j, k
+pointer pm
+bool pl_linenotempty()
+
+include "../icombine.com"
+
+begin
+ do k = 1, nimages {
+ pm = Memi[pms+k-1]
+ if (!pl_linenotempty (pm, v))
+ next
+ call pmglpi (pm, v, buf, 1, npts, PIX_SRC)
+ do i = 1, npts {
+ if (buf[i] == 0)
+ next
+ for (j = 1; j <= n[i]; j = j + 1) {
+ if (Memi[m[j]+i-1] == k) {
+ if (j < n[i]) {
+ Mems[d[j]+i-1] = Mems[d[n[i]]+i-1]
+ Memi[m[j]+i-1] = Memi[m[n[i]]+i-1]
+ }
+ n[i] = n[i] - 1
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+ }
+end
+
+# IC_GROW$T -- Reject pixels.
+
+procedure ic_growi (v, d, m, n, buf, nimages, npts, pms)
+
+long v[ARB] # Output vector
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image id pointers
+int n[ARB] # Number of good pixels
+int buf[ARB] # Buffer of npts
+int nimages # Number of images
+int npts # Number of output points per line
+pointer pms # Pointer to array of pixel masks
+
+int i, j, k
+pointer pm
+bool pl_linenotempty()
+
+include "../icombine.com"
+
+begin
+ do k = 1, nimages {
+ pm = Memi[pms+k-1]
+ if (!pl_linenotempty (pm, v))
+ next
+ call pmglpi (pm, v, buf, 1, npts, PIX_SRC)
+ do i = 1, npts {
+ if (buf[i] == 0)
+ next
+ for (j = 1; j <= n[i]; j = j + 1) {
+ if (Memi[m[j]+i-1] == k) {
+ if (j < n[i]) {
+ Memi[d[j]+i-1] = Memi[d[n[i]]+i-1]
+ Memi[m[j]+i-1] = Memi[m[n[i]]+i-1]
+ }
+ n[i] = n[i] - 1
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+ }
+end
+
+# IC_GROW$T -- Reject pixels.
+
+procedure ic_growr (v, d, m, n, buf, nimages, npts, pms)
+
+long v[ARB] # Output vector
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image id pointers
+int n[ARB] # Number of good pixels
+int buf[ARB] # Buffer of npts
+int nimages # Number of images
+int npts # Number of output points per line
+pointer pms # Pointer to array of pixel masks
+
+int i, j, k
+pointer pm
+bool pl_linenotempty()
+
+include "../icombine.com"
+
+begin
+ do k = 1, nimages {
+ pm = Memi[pms+k-1]
+ if (!pl_linenotempty (pm, v))
+ next
+ call pmglpi (pm, v, buf, 1, npts, PIX_SRC)
+ do i = 1, npts {
+ if (buf[i] == 0)
+ next
+ for (j = 1; j <= n[i]; j = j + 1) {
+ if (Memi[m[j]+i-1] == k) {
+ if (j < n[i]) {
+ Memr[d[j]+i-1] = Memr[d[n[i]]+i-1]
+ Memi[m[j]+i-1] = Memi[m[n[i]]+i-1]
+ }
+ n[i] = n[i] - 1
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+ }
+end
+
+# IC_GROW$T -- Reject pixels.
+
+procedure ic_growd (v, d, m, n, buf, nimages, npts, pms)
+
+long v[ARB] # Output vector
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image id pointers
+int n[ARB] # Number of good pixels
+int buf[ARB] # Buffer of npts
+int nimages # Number of images
+int npts # Number of output points per line
+pointer pms # Pointer to array of pixel masks
+
+int i, j, k
+pointer pm
+bool pl_linenotempty()
+
+include "../icombine.com"
+
+begin
+ do k = 1, nimages {
+ pm = Memi[pms+k-1]
+ if (!pl_linenotempty (pm, v))
+ next
+ call pmglpi (pm, v, buf, 1, npts, PIX_SRC)
+ do i = 1, npts {
+ if (buf[i] == 0)
+ next
+ for (j = 1; j <= n[i]; j = j + 1) {
+ if (Memi[m[j]+i-1] == k) {
+ if (j < n[i]) {
+ Memd[d[j]+i-1] = Memd[d[n[i]]+i-1]
+ Memi[m[j]+i-1] = Memi[m[n[i]]+i-1]
+ }
+ n[i] = n[i] - 1
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+ }
+end
diff --git a/pkg/obsolete/imcombine/generic/icmedian.x b/pkg/obsolete/imcombine/generic/icmedian.x
new file mode 100644
index 00000000..80f36443
--- /dev/null
+++ b/pkg/obsolete/imcombine/generic/icmedian.x
@@ -0,0 +1,556 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include "../icombine.h"
+
+
+# IC_MEDIAN -- Median of lines
+
+procedure ic_medians (d, n, npts, doblank, median)
+
+pointer d[ARB] # Input data line pointers
+int n[npts] # Number of good pixels
+int npts # Number of output points per line
+int doblank # Set blank values?
+real median[npts] # Median
+
+int i, j1, j2, j3, k, n1
+bool even
+real val1, val2, val3
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_NONE) {
+ if (doblank == YES) {
+ do i = 1, npts
+ median[i]= blank
+ }
+ return
+ }
+
+ # Check for previous sorting
+ if (mclip) {
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ even = (mod (n1, 2) == 0)
+ j1 = n1 / 2 + 1
+ j2 = n1 / 2
+ do i = 1, npts {
+ k = i - 1
+ if (even) {
+ val1 = Mems[d[j1]+k]
+ val2 = Mems[d[j2]+k]
+ median[i] = (val1 + val2) / 2.
+ } else
+ median[i] = Mems[d[j1]+k]
+ }
+ } else {
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (n1 > 0) {
+ j1 = n1 / 2 + 1
+ if (mod (n1, 2) == 0) {
+ j2 = n1 / 2
+ val1 = Mems[d[j1]+k]
+ val2 = Mems[d[j2]+k]
+ median[i] = (val1 + val2) / 2.
+ } else
+ median[i] = Mems[d[j1]+k]
+ } else if (doblank == YES)
+ median[i] = blank
+ }
+ }
+ return
+ }
+
+ # Repeatedly exchange the extreme values until there are three
+ # or fewer pixels.
+
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ while (n1 > 3) {
+ j1 = 1
+ j2 = 1
+ val1 = Mems[d[j1]+k]
+ val2 = val1
+ do j3 = 2, n1 {
+ val3 = Mems[d[j3]+k]
+ if (val3 > val1) {
+ j1 = j3
+ val1 = val3
+ } else if (val3 < val2) {
+ j2 = j3
+ val2 = val3
+ }
+ }
+ j3 = n1 - 1
+ if (j1 < j3 && j2 < j3) {
+ Mems[d[j1]+k] = val3
+ Mems[d[j2]+k] = Mems[d[j3]+k]
+ Mems[d[j3]+k] = val1
+ Mems[d[n1]+k] = val2
+ } else if (j1 < j3) {
+ if (j2 == j3) {
+ Mems[d[j1]+k] = val3
+ Mems[d[n1]+k] = val1
+ } else {
+ Mems[d[j1]+k] = Mems[d[j3]+k]
+ Mems[d[j3]+k] = val1
+ }
+ } else if (j2 < j3) {
+ if (j1 == j3) {
+ Mems[d[j2]+k] = val3
+ Mems[d[n1]+k] = val2
+ } else {
+ Mems[d[j2]+k] = Mems[d[j3]+k]
+ Mems[d[j3]+k] = val2
+ }
+ }
+ n1 = n1 - 2
+ }
+
+ if (n1 == 3) {
+ val1 = Mems[d[1]+k]
+ val2 = Mems[d[2]+k]
+ val3 = Mems[d[3]+k]
+ if (val1 < val2) {
+ if (val2 < val3) # abc
+ median[i] = val2
+ else if (val1 < val3) # acb
+ median[i] = val3
+ else # cab
+ median[i] = val1
+ } else {
+ if (val2 > val3) # cba
+ median[i] = val2
+ else if (val1 > val3) # bca
+ median[i] = val3
+ else # bac
+ median[i] = val1
+ }
+ } else if (n1 == 2) {
+ val1 = Mems[d[1]+k]
+ val2 = Mems[d[2]+k]
+ median[i] = (val1 + val2) / 2
+ } else if (n1 == 1)
+ median[i] = Mems[d[1]+k]
+ else if (doblank == YES)
+ median[i] = blank
+ }
+end
+
+# IC_MEDIAN -- Median of lines
+
+procedure ic_mediani (d, n, npts, doblank, median)
+
+pointer d[ARB] # Input data line pointers
+int n[npts] # Number of good pixels
+int npts # Number of output points per line
+int doblank # Set blank values?
+real median[npts] # Median
+
+int i, j1, j2, j3, k, n1
+bool even
+real val1, val2, val3
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_NONE) {
+ if (doblank == YES) {
+ do i = 1, npts
+ median[i]= blank
+ }
+ return
+ }
+
+ # Check for previous sorting
+ if (mclip) {
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ even = (mod (n1, 2) == 0)
+ j1 = n1 / 2 + 1
+ j2 = n1 / 2
+ do i = 1, npts {
+ k = i - 1
+ if (even) {
+ val1 = Memi[d[j1]+k]
+ val2 = Memi[d[j2]+k]
+ median[i] = (val1 + val2) / 2.
+ } else
+ median[i] = Memi[d[j1]+k]
+ }
+ } else {
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (n1 > 0) {
+ j1 = n1 / 2 + 1
+ if (mod (n1, 2) == 0) {
+ j2 = n1 / 2
+ val1 = Memi[d[j1]+k]
+ val2 = Memi[d[j2]+k]
+ median[i] = (val1 + val2) / 2.
+ } else
+ median[i] = Memi[d[j1]+k]
+ } else if (doblank == YES)
+ median[i] = blank
+ }
+ }
+ return
+ }
+
+ # Repeatedly exchange the extreme values until there are three
+ # or fewer pixels.
+
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ while (n1 > 3) {
+ j1 = 1
+ j2 = 1
+ val1 = Memi[d[j1]+k]
+ val2 = val1
+ do j3 = 2, n1 {
+ val3 = Memi[d[j3]+k]
+ if (val3 > val1) {
+ j1 = j3
+ val1 = val3
+ } else if (val3 < val2) {
+ j2 = j3
+ val2 = val3
+ }
+ }
+ j3 = n1 - 1
+ if (j1 < j3 && j2 < j3) {
+ Memi[d[j1]+k] = val3
+ Memi[d[j2]+k] = Memi[d[j3]+k]
+ Memi[d[j3]+k] = val1
+ Memi[d[n1]+k] = val2
+ } else if (j1 < j3) {
+ if (j2 == j3) {
+ Memi[d[j1]+k] = val3
+ Memi[d[n1]+k] = val1
+ } else {
+ Memi[d[j1]+k] = Memi[d[j3]+k]
+ Memi[d[j3]+k] = val1
+ }
+ } else if (j2 < j3) {
+ if (j1 == j3) {
+ Memi[d[j2]+k] = val3
+ Memi[d[n1]+k] = val2
+ } else {
+ Memi[d[j2]+k] = Memi[d[j3]+k]
+ Memi[d[j3]+k] = val2
+ }
+ }
+ n1 = n1 - 2
+ }
+
+ if (n1 == 3) {
+ val1 = Memi[d[1]+k]
+ val2 = Memi[d[2]+k]
+ val3 = Memi[d[3]+k]
+ if (val1 < val2) {
+ if (val2 < val3) # abc
+ median[i] = val2
+ else if (val1 < val3) # acb
+ median[i] = val3
+ else # cab
+ median[i] = val1
+ } else {
+ if (val2 > val3) # cba
+ median[i] = val2
+ else if (val1 > val3) # bca
+ median[i] = val3
+ else # bac
+ median[i] = val1
+ }
+ } else if (n1 == 2) {
+ val1 = Memi[d[1]+k]
+ val2 = Memi[d[2]+k]
+ median[i] = (val1 + val2) / 2
+ } else if (n1 == 1)
+ median[i] = Memi[d[1]+k]
+ else if (doblank == YES)
+ median[i] = blank
+ }
+end
+
+# IC_MEDIAN -- Median of lines
+
+procedure ic_medianr (d, n, npts, doblank, median)
+
+pointer d[ARB] # Input data line pointers
+int n[npts] # Number of good pixels
+int npts # Number of output points per line
+int doblank # Set blank values?
+real median[npts] # Median
+
+int i, j1, j2, j3, k, n1
+bool even
+real val1, val2, val3
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_NONE) {
+ if (doblank == YES) {
+ do i = 1, npts
+ median[i]= blank
+ }
+ return
+ }
+
+ # Check for previous sorting
+ if (mclip) {
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ even = (mod (n1, 2) == 0)
+ j1 = n1 / 2 + 1
+ j2 = n1 / 2
+ do i = 1, npts {
+ k = i - 1
+ if (even) {
+ val1 = Memr[d[j1]+k]
+ val2 = Memr[d[j2]+k]
+ median[i] = (val1 + val2) / 2.
+ } else
+ median[i] = Memr[d[j1]+k]
+ }
+ } else {
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (n1 > 0) {
+ j1 = n1 / 2 + 1
+ if (mod (n1, 2) == 0) {
+ j2 = n1 / 2
+ val1 = Memr[d[j1]+k]
+ val2 = Memr[d[j2]+k]
+ median[i] = (val1 + val2) / 2.
+ } else
+ median[i] = Memr[d[j1]+k]
+ } else if (doblank == YES)
+ median[i] = blank
+ }
+ }
+ return
+ }
+
+ # Repeatedly exchange the extreme values until there are three
+ # or fewer pixels.
+
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ while (n1 > 3) {
+ j1 = 1
+ j2 = 1
+ val1 = Memr[d[j1]+k]
+ val2 = val1
+ do j3 = 2, n1 {
+ val3 = Memr[d[j3]+k]
+ if (val3 > val1) {
+ j1 = j3
+ val1 = val3
+ } else if (val3 < val2) {
+ j2 = j3
+ val2 = val3
+ }
+ }
+ j3 = n1 - 1
+ if (j1 < j3 && j2 < j3) {
+ Memr[d[j1]+k] = val3
+ Memr[d[j2]+k] = Memr[d[j3]+k]
+ Memr[d[j3]+k] = val1
+ Memr[d[n1]+k] = val2
+ } else if (j1 < j3) {
+ if (j2 == j3) {
+ Memr[d[j1]+k] = val3
+ Memr[d[n1]+k] = val1
+ } else {
+ Memr[d[j1]+k] = Memr[d[j3]+k]
+ Memr[d[j3]+k] = val1
+ }
+ } else if (j2 < j3) {
+ if (j1 == j3) {
+ Memr[d[j2]+k] = val3
+ Memr[d[n1]+k] = val2
+ } else {
+ Memr[d[j2]+k] = Memr[d[j3]+k]
+ Memr[d[j3]+k] = val2
+ }
+ }
+ n1 = n1 - 2
+ }
+
+ if (n1 == 3) {
+ val1 = Memr[d[1]+k]
+ val2 = Memr[d[2]+k]
+ val3 = Memr[d[3]+k]
+ if (val1 < val2) {
+ if (val2 < val3) # abc
+ median[i] = val2
+ else if (val1 < val3) # acb
+ median[i] = val3
+ else # cab
+ median[i] = val1
+ } else {
+ if (val2 > val3) # cba
+ median[i] = val2
+ else if (val1 > val3) # bca
+ median[i] = val3
+ else # bac
+ median[i] = val1
+ }
+ } else if (n1 == 2) {
+ val1 = Memr[d[1]+k]
+ val2 = Memr[d[2]+k]
+ median[i] = (val1 + val2) / 2
+ } else if (n1 == 1)
+ median[i] = Memr[d[1]+k]
+ else if (doblank == YES)
+ median[i] = blank
+ }
+end
+
+# IC_MEDIAN -- Median of lines
+
+procedure ic_mediand (d, n, npts, doblank, median)
+
+pointer d[ARB] # Input data line pointers
+int n[npts] # Number of good pixels
+int npts # Number of output points per line
+int doblank # Set blank values?
+double median[npts] # Median
+
+int i, j1, j2, j3, k, n1
+bool even
+double val1, val2, val3
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_NONE) {
+ if (doblank == YES) {
+ do i = 1, npts
+ median[i]= blank
+ }
+ return
+ }
+
+ # Check for previous sorting
+ if (mclip) {
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ even = (mod (n1, 2) == 0)
+ j1 = n1 / 2 + 1
+ j2 = n1 / 2
+ do i = 1, npts {
+ k = i - 1
+ if (even) {
+ val1 = Memd[d[j1]+k]
+ val2 = Memd[d[j2]+k]
+ median[i] = (val1 + val2) / 2.
+ } else
+ median[i] = Memd[d[j1]+k]
+ }
+ } else {
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (n1 > 0) {
+ j1 = n1 / 2 + 1
+ if (mod (n1, 2) == 0) {
+ j2 = n1 / 2
+ val1 = Memd[d[j1]+k]
+ val2 = Memd[d[j2]+k]
+ median[i] = (val1 + val2) / 2.
+ } else
+ median[i] = Memd[d[j1]+k]
+ } else if (doblank == YES)
+ median[i] = blank
+ }
+ }
+ return
+ }
+
+ # Repeatedly exchange the extreme values until there are three
+ # or fewer pixels.
+
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ while (n1 > 3) {
+ j1 = 1
+ j2 = 1
+ val1 = Memd[d[j1]+k]
+ val2 = val1
+ do j3 = 2, n1 {
+ val3 = Memd[d[j3]+k]
+ if (val3 > val1) {
+ j1 = j3
+ val1 = val3
+ } else if (val3 < val2) {
+ j2 = j3
+ val2 = val3
+ }
+ }
+ j3 = n1 - 1
+ if (j1 < j3 && j2 < j3) {
+ Memd[d[j1]+k] = val3
+ Memd[d[j2]+k] = Memd[d[j3]+k]
+ Memd[d[j3]+k] = val1
+ Memd[d[n1]+k] = val2
+ } else if (j1 < j3) {
+ if (j2 == j3) {
+ Memd[d[j1]+k] = val3
+ Memd[d[n1]+k] = val1
+ } else {
+ Memd[d[j1]+k] = Memd[d[j3]+k]
+ Memd[d[j3]+k] = val1
+ }
+ } else if (j2 < j3) {
+ if (j1 == j3) {
+ Memd[d[j2]+k] = val3
+ Memd[d[n1]+k] = val2
+ } else {
+ Memd[d[j2]+k] = Memd[d[j3]+k]
+ Memd[d[j3]+k] = val2
+ }
+ }
+ n1 = n1 - 2
+ }
+
+ if (n1 == 3) {
+ val1 = Memd[d[1]+k]
+ val2 = Memd[d[2]+k]
+ val3 = Memd[d[3]+k]
+ if (val1 < val2) {
+ if (val2 < val3) # abc
+ median[i] = val2
+ else if (val1 < val3) # acb
+ median[i] = val3
+ else # cab
+ median[i] = val1
+ } else {
+ if (val2 > val3) # cba
+ median[i] = val2
+ else if (val1 > val3) # bca
+ median[i] = val3
+ else # bac
+ median[i] = val1
+ }
+ } else if (n1 == 2) {
+ val1 = Memd[d[1]+k]
+ val2 = Memd[d[2]+k]
+ median[i] = (val1 + val2) / 2
+ } else if (n1 == 1)
+ median[i] = Memd[d[1]+k]
+ else if (doblank == YES)
+ median[i] = blank
+ }
+end
diff --git a/pkg/obsolete/imcombine/generic/icmm.x b/pkg/obsolete/imcombine/generic/icmm.x
new file mode 100644
index 00000000..fc1a9239
--- /dev/null
+++ b/pkg/obsolete/imcombine/generic/icmm.x
@@ -0,0 +1,612 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include "../icombine.h"
+
+
+# IC_MM -- Reject a specified number of high and low pixels
+
+procedure ic_mms (d, m, n, npts)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image ID pointers
+int n[npts] # Number of good pixels
+int npts # Number of output points per line
+
+int n1, ncombine, npairs, nlow, nhigh, np
+int i, i1, j, jmax, jmin
+pointer k, kmax, kmin
+short d1, d2, dmin, dmax
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_NONE)
+ return
+
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ nlow = flow * n1 + 0.001
+ nhigh = fhigh * n1 + 0.001
+ ncombine = n1 - nlow - nhigh
+ npairs = min (nlow, nhigh)
+ nlow = nlow - npairs
+ nhigh = nhigh - npairs
+ }
+
+ do i = 1, npts {
+ i1 = i - 1
+ n1 = n[i]
+ if (dflag == D_MIX) {
+ nlow = flow * n1 + 0.001
+ nhigh = fhigh * n1 + 0.001
+ ncombine = max (ncombine, n1 - nlow - nhigh)
+ npairs = min (nlow, nhigh)
+ nlow = nlow - npairs
+ nhigh = nhigh - npairs
+ }
+
+ # Reject the npairs low and high points.
+ do np = 1, npairs {
+ k = d[1] + i1
+ d1 = Mems[k]
+ dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k
+ do j = 2, n1 {
+ d2 = d1
+ k = d[j] + i1
+ d1 = Mems[k]
+ if (d1 > dmax) {
+ dmax = d1; jmax = j; kmax = k
+ } else if (d1 < dmin) {
+ dmin = d1; jmin = j; kmin = k
+ }
+ }
+ j = n1 - 1
+ if (keepids) {
+ if (jmax < j) {
+ if (jmin != j) {
+ Mems[kmax] = d2
+ Memi[m[jmax]+i1] = Memi[m[j]+i1]
+ } else {
+ Mems[kmax] = d1
+ Memi[m[jmax]+i1] = Memi[m[n1]+i1]
+ }
+ }
+ if (jmin < j) {
+ if (jmax != n1) {
+ Mems[kmin] = d1
+ Memi[m[jmin]+i1] = Memi[m[n1]+i1]
+ } else {
+ Mems[kmin] = d2
+ Memi[m[jmin]+i1] = Memi[m[j]+i1]
+ }
+ }
+ } else {
+ if (jmax < j) {
+ if (jmin != j)
+ Mems[kmax] = d2
+ else
+ Mems[kmax] = d1
+ }
+ if (jmin < j) {
+ if (jmax != n1)
+ Mems[kmin] = d1
+ else
+ Mems[kmin] = d2
+ }
+ }
+ n1 = n1 - 2
+ }
+
+ # Reject the excess low points.
+ do np = 1, nlow {
+ k = d[1] + i1
+ d1 = Mems[k]
+ dmin = d1; jmin = 1; kmin = k
+ do j = 2, n1 {
+ k = d[j] + i1
+ d1 = Mems[k]
+ if (d1 < dmin) {
+ dmin = d1; jmin = j; kmin = k
+ }
+ }
+ if (keepids) {
+ if (jmin < n1) {
+ Mems[kmin] = d1
+ k = Memi[m[jmin]+i1]
+ Memi[m[jmin]+i1] = Memi[m[n1]+i1]
+ Memi[m[n1]+i1] = k
+ }
+ } else {
+ if (jmin < n1)
+ Mems[kmin] = d1
+ }
+ n1 = n1 - 1
+ }
+
+ # Reject the excess high points.
+ do np = 1, nhigh {
+ k = d[1] + i1
+ d1 = Mems[k]
+ dmax = d1; jmax = 1; kmax = k
+ do j = 2, n1 {
+ k = d[j] + i1
+ d1 = Mems[k]
+ if (d1 > dmax) {
+ dmax = d1; jmax = j; kmax = k
+ }
+ }
+ if (keepids) {
+ if (jmax < n1) {
+ Mems[kmax] = d1
+ k = Memi[m[jmax]+i1]
+ Memi[m[jmax]+i1] = Memi[m[n1]+i1]
+ Memi[m[n1]+i1] = k
+ }
+ } else {
+ if (jmax < n1)
+ Mems[kmax] = d1
+ }
+ n1 = n1 - 1
+ }
+ n[i] = n1
+ }
+
+ if (dflag == D_ALL && npairs + nlow + nhigh > 0)
+ dflag = D_MIX
+end
+
+# IC_MM -- Reject a specified number of high and low pixels
+
+procedure ic_mmi (d, m, n, npts)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image ID pointers
+int n[npts] # Number of good pixels
+int npts # Number of output points per line
+
+int n1, ncombine, npairs, nlow, nhigh, np
+int i, i1, j, jmax, jmin
+pointer k, kmax, kmin
+int d1, d2, dmin, dmax
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_NONE)
+ return
+
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ nlow = flow * n1 + 0.001
+ nhigh = fhigh * n1 + 0.001
+ ncombine = n1 - nlow - nhigh
+ npairs = min (nlow, nhigh)
+ nlow = nlow - npairs
+ nhigh = nhigh - npairs
+ }
+
+ do i = 1, npts {
+ i1 = i - 1
+ n1 = n[i]
+ if (dflag == D_MIX) {
+ nlow = flow * n1 + 0.001
+ nhigh = fhigh * n1 + 0.001
+ ncombine = max (ncombine, n1 - nlow - nhigh)
+ npairs = min (nlow, nhigh)
+ nlow = nlow - npairs
+ nhigh = nhigh - npairs
+ }
+
+ # Reject the npairs low and high points.
+ do np = 1, npairs {
+ k = d[1] + i1
+ d1 = Memi[k]
+ dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k
+ do j = 2, n1 {
+ d2 = d1
+ k = d[j] + i1
+ d1 = Memi[k]
+ if (d1 > dmax) {
+ dmax = d1; jmax = j; kmax = k
+ } else if (d1 < dmin) {
+ dmin = d1; jmin = j; kmin = k
+ }
+ }
+ j = n1 - 1
+ if (keepids) {
+ if (jmax < j) {
+ if (jmin != j) {
+ Memi[kmax] = d2
+ Memi[m[jmax]+i1] = Memi[m[j]+i1]
+ } else {
+ Memi[kmax] = d1
+ Memi[m[jmax]+i1] = Memi[m[n1]+i1]
+ }
+ }
+ if (jmin < j) {
+ if (jmax != n1) {
+ Memi[kmin] = d1
+ Memi[m[jmin]+i1] = Memi[m[n1]+i1]
+ } else {
+ Memi[kmin] = d2
+ Memi[m[jmin]+i1] = Memi[m[j]+i1]
+ }
+ }
+ } else {
+ if (jmax < j) {
+ if (jmin != j)
+ Memi[kmax] = d2
+ else
+ Memi[kmax] = d1
+ }
+ if (jmin < j) {
+ if (jmax != n1)
+ Memi[kmin] = d1
+ else
+ Memi[kmin] = d2
+ }
+ }
+ n1 = n1 - 2
+ }
+
+ # Reject the excess low points.
+ do np = 1, nlow {
+ k = d[1] + i1
+ d1 = Memi[k]
+ dmin = d1; jmin = 1; kmin = k
+ do j = 2, n1 {
+ k = d[j] + i1
+ d1 = Memi[k]
+ if (d1 < dmin) {
+ dmin = d1; jmin = j; kmin = k
+ }
+ }
+ if (keepids) {
+ if (jmin < n1) {
+ Memi[kmin] = d1
+ k = Memi[m[jmin]+i1]
+ Memi[m[jmin]+i1] = Memi[m[n1]+i1]
+ Memi[m[n1]+i1] = k
+ }
+ } else {
+ if (jmin < n1)
+ Memi[kmin] = d1
+ }
+ n1 = n1 - 1
+ }
+
+ # Reject the excess high points.
+ do np = 1, nhigh {
+ k = d[1] + i1
+ d1 = Memi[k]
+ dmax = d1; jmax = 1; kmax = k
+ do j = 2, n1 {
+ k = d[j] + i1
+ d1 = Memi[k]
+ if (d1 > dmax) {
+ dmax = d1; jmax = j; kmax = k
+ }
+ }
+ if (keepids) {
+ if (jmax < n1) {
+ Memi[kmax] = d1
+ k = Memi[m[jmax]+i1]
+ Memi[m[jmax]+i1] = Memi[m[n1]+i1]
+ Memi[m[n1]+i1] = k
+ }
+ } else {
+ if (jmax < n1)
+ Memi[kmax] = d1
+ }
+ n1 = n1 - 1
+ }
+ n[i] = n1
+ }
+
+ if (dflag == D_ALL && npairs + nlow + nhigh > 0)
+ dflag = D_MIX
+end
+
+# IC_MM -- Reject a specified number of high and low pixels
+
+procedure ic_mmr (d, m, n, npts)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image ID pointers
+int n[npts] # Number of good pixels
+int npts # Number of output points per line
+
+int n1, ncombine, npairs, nlow, nhigh, np
+int i, i1, j, jmax, jmin
+pointer k, kmax, kmin
+real d1, d2, dmin, dmax
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_NONE)
+ return
+
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ nlow = flow * n1 + 0.001
+ nhigh = fhigh * n1 + 0.001
+ ncombine = n1 - nlow - nhigh
+ npairs = min (nlow, nhigh)
+ nlow = nlow - npairs
+ nhigh = nhigh - npairs
+ }
+
+ do i = 1, npts {
+ i1 = i - 1
+ n1 = n[i]
+ if (dflag == D_MIX) {
+ nlow = flow * n1 + 0.001
+ nhigh = fhigh * n1 + 0.001
+ ncombine = max (ncombine, n1 - nlow - nhigh)
+ npairs = min (nlow, nhigh)
+ nlow = nlow - npairs
+ nhigh = nhigh - npairs
+ }
+
+ # Reject the npairs low and high points.
+ do np = 1, npairs {
+ k = d[1] + i1
+ d1 = Memr[k]
+ dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k
+ do j = 2, n1 {
+ d2 = d1
+ k = d[j] + i1
+ d1 = Memr[k]
+ if (d1 > dmax) {
+ dmax = d1; jmax = j; kmax = k
+ } else if (d1 < dmin) {
+ dmin = d1; jmin = j; kmin = k
+ }
+ }
+ j = n1 - 1
+ if (keepids) {
+ if (jmax < j) {
+ if (jmin != j) {
+ Memr[kmax] = d2
+ Memi[m[jmax]+i1] = Memi[m[j]+i1]
+ } else {
+ Memr[kmax] = d1
+ Memi[m[jmax]+i1] = Memi[m[n1]+i1]
+ }
+ }
+ if (jmin < j) {
+ if (jmax != n1) {
+ Memr[kmin] = d1
+ Memi[m[jmin]+i1] = Memi[m[n1]+i1]
+ } else {
+ Memr[kmin] = d2
+ Memi[m[jmin]+i1] = Memi[m[j]+i1]
+ }
+ }
+ } else {
+ if (jmax < j) {
+ if (jmin != j)
+ Memr[kmax] = d2
+ else
+ Memr[kmax] = d1
+ }
+ if (jmin < j) {
+ if (jmax != n1)
+ Memr[kmin] = d1
+ else
+ Memr[kmin] = d2
+ }
+ }
+ n1 = n1 - 2
+ }
+
+ # Reject the excess low points.
+ do np = 1, nlow {
+ k = d[1] + i1
+ d1 = Memr[k]
+ dmin = d1; jmin = 1; kmin = k
+ do j = 2, n1 {
+ k = d[j] + i1
+ d1 = Memr[k]
+ if (d1 < dmin) {
+ dmin = d1; jmin = j; kmin = k
+ }
+ }
+ if (keepids) {
+ if (jmin < n1) {
+ Memr[kmin] = d1
+ k = Memi[m[jmin]+i1]
+ Memi[m[jmin]+i1] = Memi[m[n1]+i1]
+ Memi[m[n1]+i1] = k
+ }
+ } else {
+ if (jmin < n1)
+ Memr[kmin] = d1
+ }
+ n1 = n1 - 1
+ }
+
+ # Reject the excess high points.
+ do np = 1, nhigh {
+ k = d[1] + i1
+ d1 = Memr[k]
+ dmax = d1; jmax = 1; kmax = k
+ do j = 2, n1 {
+ k = d[j] + i1
+ d1 = Memr[k]
+ if (d1 > dmax) {
+ dmax = d1; jmax = j; kmax = k
+ }
+ }
+ if (keepids) {
+ if (jmax < n1) {
+ Memr[kmax] = d1
+ k = Memi[m[jmax]+i1]
+ Memi[m[jmax]+i1] = Memi[m[n1]+i1]
+ Memi[m[n1]+i1] = k
+ }
+ } else {
+ if (jmax < n1)
+ Memr[kmax] = d1
+ }
+ n1 = n1 - 1
+ }
+ n[i] = n1
+ }
+
+ if (dflag == D_ALL && npairs + nlow + nhigh > 0)
+ dflag = D_MIX
+end
+
+# IC_MM -- Reject a specified number of high and low pixels
+
+procedure ic_mmd (d, m, n, npts)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image ID pointers
+int n[npts] # Number of good pixels
+int npts # Number of output points per line
+
+int n1, ncombine, npairs, nlow, nhigh, np
+int i, i1, j, jmax, jmin
+pointer k, kmax, kmin
+double d1, d2, dmin, dmax
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_NONE)
+ return
+
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ nlow = flow * n1 + 0.001
+ nhigh = fhigh * n1 + 0.001
+ ncombine = n1 - nlow - nhigh
+ npairs = min (nlow, nhigh)
+ nlow = nlow - npairs
+ nhigh = nhigh - npairs
+ }
+
+ do i = 1, npts {
+ i1 = i - 1
+ n1 = n[i]
+ if (dflag == D_MIX) {
+ nlow = flow * n1 + 0.001
+ nhigh = fhigh * n1 + 0.001
+ ncombine = max (ncombine, n1 - nlow - nhigh)
+ npairs = min (nlow, nhigh)
+ nlow = nlow - npairs
+ nhigh = nhigh - npairs
+ }
+
+ # Reject the npairs low and high points.
+ do np = 1, npairs {
+ k = d[1] + i1
+ d1 = Memd[k]
+ dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k
+ do j = 2, n1 {
+ d2 = d1
+ k = d[j] + i1
+ d1 = Memd[k]
+ if (d1 > dmax) {
+ dmax = d1; jmax = j; kmax = k
+ } else if (d1 < dmin) {
+ dmin = d1; jmin = j; kmin = k
+ }
+ }
+ j = n1 - 1
+ if (keepids) {
+ if (jmax < j) {
+ if (jmin != j) {
+ Memd[kmax] = d2
+ Memi[m[jmax]+i1] = Memi[m[j]+i1]
+ } else {
+ Memd[kmax] = d1
+ Memi[m[jmax]+i1] = Memi[m[n1]+i1]
+ }
+ }
+ if (jmin < j) {
+ if (jmax != n1) {
+ Memd[kmin] = d1
+ Memi[m[jmin]+i1] = Memi[m[n1]+i1]
+ } else {
+ Memd[kmin] = d2
+ Memi[m[jmin]+i1] = Memi[m[j]+i1]
+ }
+ }
+ } else {
+ if (jmax < j) {
+ if (jmin != j)
+ Memd[kmax] = d2
+ else
+ Memd[kmax] = d1
+ }
+ if (jmin < j) {
+ if (jmax != n1)
+ Memd[kmin] = d1
+ else
+ Memd[kmin] = d2
+ }
+ }
+ n1 = n1 - 2
+ }
+
+ # Reject the excess low points.
+ do np = 1, nlow {
+ k = d[1] + i1
+ d1 = Memd[k]
+ dmin = d1; jmin = 1; kmin = k
+ do j = 2, n1 {
+ k = d[j] + i1
+ d1 = Memd[k]
+ if (d1 < dmin) {
+ dmin = d1; jmin = j; kmin = k
+ }
+ }
+ if (keepids) {
+ if (jmin < n1) {
+ Memd[kmin] = d1
+ k = Memi[m[jmin]+i1]
+ Memi[m[jmin]+i1] = Memi[m[n1]+i1]
+ Memi[m[n1]+i1] = k
+ }
+ } else {
+ if (jmin < n1)
+ Memd[kmin] = d1
+ }
+ n1 = n1 - 1
+ }
+
+ # Reject the excess high points.
+ do np = 1, nhigh {
+ k = d[1] + i1
+ d1 = Memd[k]
+ dmax = d1; jmax = 1; kmax = k
+ do j = 2, n1 {
+ k = d[j] + i1
+ d1 = Memd[k]
+ if (d1 > dmax) {
+ dmax = d1; jmax = j; kmax = k
+ }
+ }
+ if (keepids) {
+ if (jmax < n1) {
+ Memd[kmax] = d1
+ k = Memi[m[jmax]+i1]
+ Memi[m[jmax]+i1] = Memi[m[n1]+i1]
+ Memi[m[n1]+i1] = k
+ }
+ } else {
+ if (jmax < n1)
+ Memd[kmax] = d1
+ }
+ n1 = n1 - 1
+ }
+ n[i] = n1
+ }
+
+ if (dflag == D_ALL && npairs + nlow + nhigh > 0)
+ dflag = D_MIX
+end
diff --git a/pkg/obsolete/imcombine/generic/icombine.x b/pkg/obsolete/imcombine/generic/icombine.x
new file mode 100644
index 00000000..50c76cca
--- /dev/null
+++ b/pkg/obsolete/imcombine/generic/icombine.x
@@ -0,0 +1,1645 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include <imset.h>
+include <pmset.h>
+include <error.h>
+include <syserr.h>
+include <mach.h>
+include "../icombine.h"
+
+
+# ICOMBINE -- Combine images
+#
+# The memory and open file descriptor limits are checked and an attempt
+# to recover is made either by setting the image pixel files to be
+# closed after I/O or by notifying the calling program that memory
+# ran out and the IMIO buffer size should be reduced. After the checks
+# a procedure for the selected combine option is called.
+# Because there may be several failure modes when reaching the file
+# limits we first assume an error is due to the file limit, except for
+# out of memory, and close some pixel files. If the error then repeats
+# on accessing the pixels the error is passed back.
+
+
+procedure icombines (in, out, offsets, nimages, bufsize)
+
+pointer in[nimages] # Input images
+pointer out[4] # Output images
+int offsets[nimages,ARB] # Input image offsets
+int nimages # Number of input images
+int bufsize # IMIO buffer size
+
+char str[1]
+int i, j, npts, fd, stropen(), errcode(), imstati()
+pointer sp, d, id, n, m, lflag, scales, zeros, wts, dbuf
+pointer buf, imgl1s(), impl1i()
+errchk stropen, imgl1s, impl1i
+pointer impl1r()
+errchk impl1r
+
+include "../icombine.com"
+
+begin
+ npts = IM_LEN(out[1],1)
+
+ # Allocate memory.
+ call smark (sp)
+ call salloc (dbuf, nimages, TY_POINTER)
+ call salloc (d, nimages, TY_POINTER)
+ call salloc (id, nimages, TY_POINTER)
+ call salloc (n, npts, TY_INT)
+ call salloc (m, nimages, TY_POINTER)
+ call salloc (lflag, nimages, TY_INT)
+ call salloc (scales, nimages, TY_REAL)
+ call salloc (zeros, nimages, TY_REAL)
+ call salloc (wts, nimages, TY_REAL)
+ call amovki (D_ALL, Memi[lflag], nimages)
+
+ # If not aligned or growing create data buffers of output length
+ # otherwise use the IMIO buffers.
+
+ if (!aligned || grow >= 1.) {
+ do i = 1, nimages
+ call salloc (Memi[dbuf+i-1], npts, TY_SHORT)
+ } else
+ call amovki (NULL, Memi[dbuf], nimages)
+
+ if (project) {
+ call imseti (in[1], IM_NBUFS, nimages)
+ call imseti (in[1], IM_BUFSIZE, bufsize)
+ do i = 1, 3 {
+ if (out[i] != NULL)
+ call imseti (out[i], IM_BUFSIZE, bufsize)
+ }
+ } else {
+ # Reserve FD for string operations.
+ fd = stropen (str, 1, NEW_FILE)
+
+ # Do I/O to the images.
+ do i = 1, 3 {
+ if (out[i] != NULL)
+ call imseti (out[i], IM_BUFSIZE, bufsize)
+ }
+ buf = impl1r (out[1])
+ call aclrr (Memr[buf], npts)
+ if (out[3] != NULL) {
+ buf = impl1r (out[3])
+ call aclrr (Memr[buf], npts)
+ }
+ if (out[2] != NULL) {
+ buf = impl1i (out[2])
+ call aclri (Memi[buf], npts)
+ }
+
+ do i = 1, nimages {
+ call imseti (in[i], IM_BUFSIZE, bufsize)
+ iferr (buf = imgl1s (in[i])) {
+ switch (errcode()) {
+ case SYS_MFULL:
+ call sfree (sp)
+ call strclose (fd)
+ call erract (EA_ERROR)
+ case SYS_FTOOMANYFILES, SYS_IKIOPIX:
+ if (imstati (in[i], IM_CLOSEFD) == YES) {
+ call sfree (sp)
+ call strclose (fd)
+ call erract (EA_ERROR)
+ }
+ do j = i-2, nimages
+ call imseti (in[j], IM_CLOSEFD, YES)
+ buf = imgl1s (in[i])
+ default:
+ call sfree (sp)
+ call strclose (fd)
+ call erract (EA_ERROR)
+ }
+ }
+ }
+
+ call strclose (fd)
+ }
+
+ call ic_combines (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n],
+ Memi[m], Memi[lflag], offsets, Memr[scales], Memr[zeros],
+ Memr[wts], nimages, npts)
+end
+
+
+# IC_COMBINE -- Combine images.
+
+procedure ic_combines (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, wts, nimages, npts)
+
+pointer in[nimages] # Input images
+pointer out[4] # Output image
+pointer dbuf[nimages] # Data buffers for nonaligned images
+pointer d[nimages] # Data pointers
+pointer id[nimages] # Image index ID pointers
+int n[npts] # Number of good pixels
+pointer m[nimages] # Mask pointers
+int lflag[nimages] # Line flags
+int offsets[nimages,ARB] # Input image offsets
+real scales[nimages] # Scale factors
+real zeros[nimages] # Zero offset factors
+real wts[nimages] # Combining weights
+int nimages # Number of input images
+int npts # Number of points per output line
+
+int i, ext, ctor(), ic_qsort(), errcode()
+real r, imgetr()
+pointer sp, fname, imname, v1, v2, v3, work
+pointer outdata, buf, nm, pms
+pointer immap(), impnli()
+pointer impnlr(), imgnlr()
+errchk immap, ic_scale, imgetr, ic_grow, ic_grows, ic_rmasks
+extern ic_qsort
+
+include "../icombine.com"
+data ext/0/
+
+begin
+ call smark (sp)
+ call salloc (fname, SZ_FNAME, TY_CHAR)
+ call salloc (imname, SZ_FNAME, TY_CHAR)
+ call salloc (v1, IM_MAXDIM, TY_LONG)
+ call salloc (v2, IM_MAXDIM, TY_LONG)
+ call salloc (v3, IM_MAXDIM, TY_LONG)
+ call amovkl (long(1), Meml[v1], IM_MAXDIM)
+ call amovkl (long(1), Meml[v2], IM_MAXDIM)
+ call amovkl (long(1), Meml[v3], IM_MAXDIM)
+
+ call ic_scale (in, out, offsets, scales, zeros, wts, nimages)
+
+ # Set combine parameters
+ switch (combine) {
+ case AVERAGE:
+ if (dowts)
+ keepids = true
+ else
+ keepids = false
+ case MEDIAN:
+ dowts = false
+ keepids = false
+ }
+ docombine = true
+
+ # Set rejection algorithm specific parameters
+ switch (reject) {
+ case CCDCLIP, CRREJECT:
+ call salloc (nm, 3*nimages, TY_REAL)
+ i = 1
+ if (ctor (Memc[rdnoise], i, r) > 0) {
+ do i = 1, nimages
+ Memr[nm+3*(i-1)] = r
+ } else {
+ do i = 1, nimages
+ Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise])
+ }
+ i = 1
+ if (ctor (Memc[gain], i, r) > 0) {
+ do i = 1, nimages {
+ Memr[nm+3*(i-1)+1] = r
+ Memr[nm+3*(i-1)] =
+ max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL)
+ }
+ } else {
+ do i = 1, nimages {
+ r = imgetr (in[i], Memc[gain])
+ Memr[nm+3*(i-1)+1] = r
+ Memr[nm+3*(i-1)] =
+ max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL)
+ }
+ }
+ i = 1
+ if (ctor (Memc[snoise], i, r) > 0) {
+ do i = 1, nimages
+ Memr[nm+3*(i-1)+2] = r
+ } else {
+ do i = 1, nimages {
+ r = imgetr (in[i], Memc[snoise])
+ Memr[nm+3*(i-1)+2] = r
+ }
+ }
+ if (!keepids) {
+ if (doscale1)
+ keepids = true
+ else {
+ do i = 2, nimages {
+ if (Memr[nm+3*(i-1)] != Memr[nm] ||
+ Memr[nm+3*(i-1)+1] != Memr[nm+1] ||
+ Memr[nm+3*(i-1)+2] != Memr[nm+2]) {
+ keepids = true
+ break
+ }
+ }
+ }
+ }
+ if (reject == CRREJECT)
+ lsigma = MAX_REAL
+ case MINMAX:
+ mclip = false
+ case PCLIP:
+ mclip = true
+ case AVSIGCLIP, SIGCLIP:
+ if (doscale1)
+ keepids = true
+ case NONE:
+ mclip = false
+ }
+
+ if (out[4] != NULL)
+ keepids = true
+
+ if (grow >= 1.) {
+ keepids = true
+ call salloc (work, npts * nimages, TY_INT)
+ }
+ pms = NULL
+
+ if (keepids) {
+ do i = 1, nimages
+ call salloc (id[i], npts, TY_INT)
+ }
+
+ while (impnlr (out[1], outdata, Meml[v1]) != EOF) {
+ call ic_gdatas (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, nimages, npts, Meml[v2], Meml[v3])
+
+ switch (reject) {
+ case CCDCLIP, CRREJECT:
+ if (mclip)
+ call ic_mccdclips (d, id, n, scales, zeros, Memr[nm],
+ nimages, npts, Memr[outdata])
+ else
+ call ic_accdclips (d, id, n, scales, zeros, Memr[nm],
+ nimages, npts, Memr[outdata])
+ case MINMAX:
+ call ic_mms (d, id, n, npts)
+ case PCLIP:
+ call ic_pclips (d, id, n, nimages, npts, Memr[outdata])
+ case SIGCLIP:
+ if (mclip)
+ call ic_msigclips (d, id, n, scales, zeros, nimages, npts,
+ Memr[outdata])
+ else
+ call ic_asigclips (d, id, n, scales, zeros, nimages, npts,
+ Memr[outdata])
+ case AVSIGCLIP:
+ if (mclip)
+ call ic_mavsigclips (d, id, n, scales, zeros, nimages,
+ npts, Memr[outdata])
+ else
+ call ic_aavsigclips (d, id, n, scales, zeros, nimages,
+ npts, Memr[outdata])
+ }
+
+ if (pms == NULL || nkeep > 0) {
+ if (docombine) {
+ switch (combine) {
+ case AVERAGE:
+ call ic_averages (d, id, n, wts, npts, YES,
+ Memr[outdata])
+ case MEDIAN:
+ call ic_medians (d, n, npts, YES, Memr[outdata])
+ }
+ }
+ }
+
+ if (grow >= 1.)
+ call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts,
+ pms)
+
+ if (pms == NULL) {
+ if (out[2] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnli (out[2], buf, Meml[v1])
+ call amovki (nimages, Memi[buf], npts)
+ call asubi (Memi[buf], n, Memi[buf], npts)
+ }
+
+ if (out[3] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnlr (out[3], buf, Meml[v1])
+ call ic_sigmas (d, id, n, wts, npts, Memr[outdata],
+ Memr[buf])
+ }
+
+ if (out[4] != NULL)
+ call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts)
+ }
+
+ call amovl (Meml[v1], Meml[v2], IM_MAXDIM)
+ }
+
+ if (pms != NULL) {
+ if (nkeep > 0) {
+ call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME)
+ call imunmap (out[1])
+ iferr (buf = immap (Memc[fname], READ_WRITE, 0)) {
+ switch (errcode()) {
+ case SYS_FXFOPNOEXTNV:
+ call imgcluster (Memc[fname], Memc[fname], SZ_FNAME)
+ ext = ext + 1
+ call sprintf (Memc[imname], SZ_FNAME, "%s[%d]")
+ call pargstr (Memc[fname])
+ call pargi (ext)
+ iferr (buf = immap (Memc[imname], READ_WRITE, 0)) {
+ buf = NULL
+ ext = 0
+ }
+ repeat {
+ call sprintf (Memc[imname], SZ_FNAME, "%s[%d]")
+ call pargstr (Memc[fname])
+ call pargi (ext+1)
+ iferr (outdata = immap (Memc[imname],READ_WRITE,0))
+ break
+ if (buf != NULL)
+ call imunmap (buf)
+ buf = outdata
+ ext = ext + 1
+ }
+ default:
+ call erract (EA_ERROR)
+ }
+ }
+ out[1] = buf
+ }
+
+ call amovkl (long(1), Meml[v1], IM_MAXDIM)
+ call amovkl (long(1), Meml[v2], IM_MAXDIM)
+ call amovkl (long(1), Meml[v3], IM_MAXDIM)
+ while (impnlr (out[1], outdata, Meml[v1]) != EOF) {
+ call ic_gdatas (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, nimages, npts, Meml[v2], Meml[v3])
+
+ call ic_grows (Meml[v2], d, id, n, Memi[work], nimages, npts,
+ pms)
+
+ if (nkeep > 0) {
+ do i = 1, npts {
+ if (n[i] < nkeep) {
+ Meml[v1+1] = Meml[v1+1] - 1
+ if (imgnlr (out[1], buf, Meml[v1]) == EOF)
+ ;
+ call amovr (Memr[buf], Memr[outdata], npts)
+ break
+ }
+ }
+ }
+
+ switch (combine) {
+ case AVERAGE:
+ call ic_averages (d, id, n, wts, npts, NO, Memr[outdata])
+ case MEDIAN:
+ call ic_medians (d, n, npts, NO, Memr[outdata])
+ }
+
+ if (out[2] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnli (out[2], buf, Meml[v1])
+ call amovki (nimages, Memi[buf], npts)
+ call asubi (Memi[buf], n, Memi[buf], npts)
+ }
+
+ if (out[3] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnlr (out[3], buf, Meml[v1])
+ call ic_sigmas (d, id, n, wts, npts, Memr[outdata],
+ Memr[buf])
+ }
+
+ if (out[4] != NULL)
+ call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts)
+
+ call amovl (Meml[v1], Meml[v2], IM_MAXDIM)
+ }
+
+ do i = 1, nimages
+ call pm_close (Memi[pms+i-1])
+ call mfree (pms, TY_POINTER)
+ }
+
+ call sfree (sp)
+end
+
+procedure icombinei (in, out, offsets, nimages, bufsize)
+
+pointer in[nimages] # Input images
+pointer out[4] # Output images
+int offsets[nimages,ARB] # Input image offsets
+int nimages # Number of input images
+int bufsize # IMIO buffer size
+
+char str[1]
+int i, j, npts, fd, stropen(), errcode(), imstati()
+pointer sp, d, id, n, m, lflag, scales, zeros, wts, dbuf
+pointer buf, imgl1i(), impl1i()
+errchk stropen, imgl1i, impl1i
+pointer impl1r()
+errchk impl1r
+
+include "../icombine.com"
+
+begin
+ npts = IM_LEN(out[1],1)
+
+ # Allocate memory.
+ call smark (sp)
+ call salloc (dbuf, nimages, TY_POINTER)
+ call salloc (d, nimages, TY_POINTER)
+ call salloc (id, nimages, TY_POINTER)
+ call salloc (n, npts, TY_INT)
+ call salloc (m, nimages, TY_POINTER)
+ call salloc (lflag, nimages, TY_INT)
+ call salloc (scales, nimages, TY_REAL)
+ call salloc (zeros, nimages, TY_REAL)
+ call salloc (wts, nimages, TY_REAL)
+ call amovki (D_ALL, Memi[lflag], nimages)
+
+ # If not aligned or growing create data buffers of output length
+ # otherwise use the IMIO buffers.
+
+ if (!aligned || grow >= 1.) {
+ do i = 1, nimages
+ call salloc (Memi[dbuf+i-1], npts, TY_INT)
+ } else
+ call amovki (NULL, Memi[dbuf], nimages)
+
+ if (project) {
+ call imseti (in[1], IM_NBUFS, nimages)
+ call imseti (in[1], IM_BUFSIZE, bufsize)
+ do i = 1, 3 {
+ if (out[i] != NULL)
+ call imseti (out[i], IM_BUFSIZE, bufsize)
+ }
+ } else {
+ # Reserve FD for string operations.
+ fd = stropen (str, 1, NEW_FILE)
+
+ # Do I/O to the images.
+ do i = 1, 3 {
+ if (out[i] != NULL)
+ call imseti (out[i], IM_BUFSIZE, bufsize)
+ }
+ buf = impl1r (out[1])
+ call aclrr (Memr[buf], npts)
+ if (out[3] != NULL) {
+ buf = impl1r (out[3])
+ call aclrr (Memr[buf], npts)
+ }
+ if (out[2] != NULL) {
+ buf = impl1i (out[2])
+ call aclri (Memi[buf], npts)
+ }
+
+ do i = 1, nimages {
+ call imseti (in[i], IM_BUFSIZE, bufsize)
+ iferr (buf = imgl1i (in[i])) {
+ switch (errcode()) {
+ case SYS_MFULL:
+ call sfree (sp)
+ call strclose (fd)
+ call erract (EA_ERROR)
+ case SYS_FTOOMANYFILES, SYS_IKIOPIX:
+ if (imstati (in[i], IM_CLOSEFD) == YES) {
+ call sfree (sp)
+ call strclose (fd)
+ call erract (EA_ERROR)
+ }
+ do j = i-2, nimages
+ call imseti (in[j], IM_CLOSEFD, YES)
+ buf = imgl1i (in[i])
+ default:
+ call sfree (sp)
+ call strclose (fd)
+ call erract (EA_ERROR)
+ }
+ }
+ }
+
+ call strclose (fd)
+ }
+
+ call ic_combinei (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n],
+ Memi[m], Memi[lflag], offsets, Memr[scales], Memr[zeros],
+ Memr[wts], nimages, npts)
+end
+
+
+# IC_COMBINE -- Combine images.
+
+procedure ic_combinei (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, wts, nimages, npts)
+
+pointer in[nimages] # Input images
+pointer out[4] # Output image
+pointer dbuf[nimages] # Data buffers for nonaligned images
+pointer d[nimages] # Data pointers
+pointer id[nimages] # Image index ID pointers
+int n[npts] # Number of good pixels
+pointer m[nimages] # Mask pointers
+int lflag[nimages] # Line flags
+int offsets[nimages,ARB] # Input image offsets
+real scales[nimages] # Scale factors
+real zeros[nimages] # Zero offset factors
+real wts[nimages] # Combining weights
+int nimages # Number of input images
+int npts # Number of points per output line
+
+int i, ext, ctor(), ic_qsort(), errcode()
+real r, imgetr()
+pointer sp, fname, imname, v1, v2, v3, work
+pointer outdata, buf, nm, pms
+pointer immap(), impnli()
+pointer impnlr(), imgnlr()
+errchk immap, ic_scale, imgetr, ic_grow, ic_growi, ic_rmasks
+extern ic_qsort
+
+include "../icombine.com"
+data ext/0/
+
+begin
+ call smark (sp)
+ call salloc (fname, SZ_FNAME, TY_CHAR)
+ call salloc (imname, SZ_FNAME, TY_CHAR)
+ call salloc (v1, IM_MAXDIM, TY_LONG)
+ call salloc (v2, IM_MAXDIM, TY_LONG)
+ call salloc (v3, IM_MAXDIM, TY_LONG)
+ call amovkl (long(1), Meml[v1], IM_MAXDIM)
+ call amovkl (long(1), Meml[v2], IM_MAXDIM)
+ call amovkl (long(1), Meml[v3], IM_MAXDIM)
+
+ call ic_scale (in, out, offsets, scales, zeros, wts, nimages)
+
+ # Set combine parameters
+ switch (combine) {
+ case AVERAGE:
+ if (dowts)
+ keepids = true
+ else
+ keepids = false
+ case MEDIAN:
+ dowts = false
+ keepids = false
+ }
+ docombine = true
+
+ # Set rejection algorithm specific parameters
+ switch (reject) {
+ case CCDCLIP, CRREJECT:
+ call salloc (nm, 3*nimages, TY_REAL)
+ i = 1
+ if (ctor (Memc[rdnoise], i, r) > 0) {
+ do i = 1, nimages
+ Memr[nm+3*(i-1)] = r
+ } else {
+ do i = 1, nimages
+ Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise])
+ }
+ i = 1
+ if (ctor (Memc[gain], i, r) > 0) {
+ do i = 1, nimages {
+ Memr[nm+3*(i-1)+1] = r
+ Memr[nm+3*(i-1)] =
+ max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL)
+ }
+ } else {
+ do i = 1, nimages {
+ r = imgetr (in[i], Memc[gain])
+ Memr[nm+3*(i-1)+1] = r
+ Memr[nm+3*(i-1)] =
+ max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL)
+ }
+ }
+ i = 1
+ if (ctor (Memc[snoise], i, r) > 0) {
+ do i = 1, nimages
+ Memr[nm+3*(i-1)+2] = r
+ } else {
+ do i = 1, nimages {
+ r = imgetr (in[i], Memc[snoise])
+ Memr[nm+3*(i-1)+2] = r
+ }
+ }
+ if (!keepids) {
+ if (doscale1)
+ keepids = true
+ else {
+ do i = 2, nimages {
+ if (Memr[nm+3*(i-1)] != Memr[nm] ||
+ Memr[nm+3*(i-1)+1] != Memr[nm+1] ||
+ Memr[nm+3*(i-1)+2] != Memr[nm+2]) {
+ keepids = true
+ break
+ }
+ }
+ }
+ }
+ if (reject == CRREJECT)
+ lsigma = MAX_REAL
+ case MINMAX:
+ mclip = false
+ case PCLIP:
+ mclip = true
+ case AVSIGCLIP, SIGCLIP:
+ if (doscale1)
+ keepids = true
+ case NONE:
+ mclip = false
+ }
+
+ if (out[4] != NULL)
+ keepids = true
+
+ if (grow >= 1.) {
+ keepids = true
+ call salloc (work, npts * nimages, TY_INT)
+ }
+ pms = NULL
+
+ if (keepids) {
+ do i = 1, nimages
+ call salloc (id[i], npts, TY_INT)
+ }
+
+ while (impnlr (out[1], outdata, Meml[v1]) != EOF) {
+ call ic_gdatai (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, nimages, npts, Meml[v2], Meml[v3])
+
+ switch (reject) {
+ case CCDCLIP, CRREJECT:
+ if (mclip)
+ call ic_mccdclipi (d, id, n, scales, zeros, Memr[nm],
+ nimages, npts, Memr[outdata])
+ else
+ call ic_accdclipi (d, id, n, scales, zeros, Memr[nm],
+ nimages, npts, Memr[outdata])
+ case MINMAX:
+ call ic_mmi (d, id, n, npts)
+ case PCLIP:
+ call ic_pclipi (d, id, n, nimages, npts, Memr[outdata])
+ case SIGCLIP:
+ if (mclip)
+ call ic_msigclipi (d, id, n, scales, zeros, nimages, npts,
+ Memr[outdata])
+ else
+ call ic_asigclipi (d, id, n, scales, zeros, nimages, npts,
+ Memr[outdata])
+ case AVSIGCLIP:
+ if (mclip)
+ call ic_mavsigclipi (d, id, n, scales, zeros, nimages,
+ npts, Memr[outdata])
+ else
+ call ic_aavsigclipi (d, id, n, scales, zeros, nimages,
+ npts, Memr[outdata])
+ }
+
+ if (pms == NULL || nkeep > 0) {
+ if (docombine) {
+ switch (combine) {
+ case AVERAGE:
+ call ic_averagei (d, id, n, wts, npts, YES,
+ Memr[outdata])
+ case MEDIAN:
+ call ic_mediani (d, n, npts, YES, Memr[outdata])
+ }
+ }
+ }
+
+ if (grow >= 1.)
+ call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts,
+ pms)
+
+ if (pms == NULL) {
+ if (out[2] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnli (out[2], buf, Meml[v1])
+ call amovki (nimages, Memi[buf], npts)
+ call asubi (Memi[buf], n, Memi[buf], npts)
+ }
+
+ if (out[3] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnlr (out[3], buf, Meml[v1])
+ call ic_sigmai (d, id, n, wts, npts, Memr[outdata],
+ Memr[buf])
+ }
+
+ if (out[4] != NULL)
+ call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts)
+ }
+
+ call amovl (Meml[v1], Meml[v2], IM_MAXDIM)
+ }
+
+ if (pms != NULL) {
+ if (nkeep > 0) {
+ call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME)
+ call imunmap (out[1])
+ iferr (buf = immap (Memc[fname], READ_WRITE, 0)) {
+ switch (errcode()) {
+ case SYS_FXFOPNOEXTNV:
+ call imgcluster (Memc[fname], Memc[fname], SZ_FNAME)
+ ext = ext + 1
+ call sprintf (Memc[imname], SZ_FNAME, "%s[%d]")
+ call pargstr (Memc[fname])
+ call pargi (ext)
+ iferr (buf = immap (Memc[imname], READ_WRITE, 0)) {
+ buf = NULL
+ ext = 0
+ }
+ repeat {
+ call sprintf (Memc[imname], SZ_FNAME, "%s[%d]")
+ call pargstr (Memc[fname])
+ call pargi (ext+1)
+ iferr (outdata = immap (Memc[imname],READ_WRITE,0))
+ break
+ if (buf != NULL)
+ call imunmap (buf)
+ buf = outdata
+ ext = ext + 1
+ }
+ default:
+ call erract (EA_ERROR)
+ }
+ }
+ out[1] = buf
+ }
+
+ call amovkl (long(1), Meml[v1], IM_MAXDIM)
+ call amovkl (long(1), Meml[v2], IM_MAXDIM)
+ call amovkl (long(1), Meml[v3], IM_MAXDIM)
+ while (impnlr (out[1], outdata, Meml[v1]) != EOF) {
+ call ic_gdatai (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, nimages, npts, Meml[v2], Meml[v3])
+
+ call ic_growi (Meml[v2], d, id, n, Memi[work], nimages, npts,
+ pms)
+
+ if (nkeep > 0) {
+ do i = 1, npts {
+ if (n[i] < nkeep) {
+ Meml[v1+1] = Meml[v1+1] - 1
+ if (imgnlr (out[1], buf, Meml[v1]) == EOF)
+ ;
+ call amovr (Memr[buf], Memr[outdata], npts)
+ break
+ }
+ }
+ }
+
+ switch (combine) {
+ case AVERAGE:
+ call ic_averagei (d, id, n, wts, npts, NO, Memr[outdata])
+ case MEDIAN:
+ call ic_mediani (d, n, npts, NO, Memr[outdata])
+ }
+
+ if (out[2] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnli (out[2], buf, Meml[v1])
+ call amovki (nimages, Memi[buf], npts)
+ call asubi (Memi[buf], n, Memi[buf], npts)
+ }
+
+ if (out[3] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnlr (out[3], buf, Meml[v1])
+ call ic_sigmai (d, id, n, wts, npts, Memr[outdata],
+ Memr[buf])
+ }
+
+ if (out[4] != NULL)
+ call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts)
+
+ call amovl (Meml[v1], Meml[v2], IM_MAXDIM)
+ }
+
+ do i = 1, nimages
+ call pm_close (Memi[pms+i-1])
+ call mfree (pms, TY_POINTER)
+ }
+
+ call sfree (sp)
+end
+
+procedure icombiner (in, out, offsets, nimages, bufsize)
+
+pointer in[nimages] # Input images
+pointer out[4] # Output images
+int offsets[nimages,ARB] # Input image offsets
+int nimages # Number of input images
+int bufsize # IMIO buffer size
+
+char str[1]
+int i, j, npts, fd, stropen(), errcode(), imstati()
+pointer sp, d, id, n, m, lflag, scales, zeros, wts, dbuf
+pointer buf, imgl1r(), impl1i()
+errchk stropen, imgl1r, impl1i
+pointer impl1r()
+errchk impl1r
+
+include "../icombine.com"
+
+begin
+ npts = IM_LEN(out[1],1)
+
+ # Allocate memory.
+ call smark (sp)
+ call salloc (dbuf, nimages, TY_POINTER)
+ call salloc (d, nimages, TY_POINTER)
+ call salloc (id, nimages, TY_POINTER)
+ call salloc (n, npts, TY_INT)
+ call salloc (m, nimages, TY_POINTER)
+ call salloc (lflag, nimages, TY_INT)
+ call salloc (scales, nimages, TY_REAL)
+ call salloc (zeros, nimages, TY_REAL)
+ call salloc (wts, nimages, TY_REAL)
+ call amovki (D_ALL, Memi[lflag], nimages)
+
+ # If not aligned or growing create data buffers of output length
+ # otherwise use the IMIO buffers.
+
+ if (!aligned || grow >= 1.) {
+ do i = 1, nimages
+ call salloc (Memi[dbuf+i-1], npts, TY_REAL)
+ } else
+ call amovki (NULL, Memi[dbuf], nimages)
+
+ if (project) {
+ call imseti (in[1], IM_NBUFS, nimages)
+ call imseti (in[1], IM_BUFSIZE, bufsize)
+ do i = 1, 3 {
+ if (out[i] != NULL)
+ call imseti (out[i], IM_BUFSIZE, bufsize)
+ }
+ } else {
+ # Reserve FD for string operations.
+ fd = stropen (str, 1, NEW_FILE)
+
+ # Do I/O to the images.
+ do i = 1, 3 {
+ if (out[i] != NULL)
+ call imseti (out[i], IM_BUFSIZE, bufsize)
+ }
+ buf = impl1r (out[1])
+ call aclrr (Memr[buf], npts)
+ if (out[3] != NULL) {
+ buf = impl1r (out[3])
+ call aclrr (Memr[buf], npts)
+ }
+ if (out[2] != NULL) {
+ buf = impl1i (out[2])
+ call aclri (Memi[buf], npts)
+ }
+
+ do i = 1, nimages {
+ call imseti (in[i], IM_BUFSIZE, bufsize)
+ iferr (buf = imgl1r (in[i])) {
+ switch (errcode()) {
+ case SYS_MFULL:
+ call sfree (sp)
+ call strclose (fd)
+ call erract (EA_ERROR)
+ case SYS_FTOOMANYFILES, SYS_IKIOPIX:
+ if (imstati (in[i], IM_CLOSEFD) == YES) {
+ call sfree (sp)
+ call strclose (fd)
+ call erract (EA_ERROR)
+ }
+ do j = i-2, nimages
+ call imseti (in[j], IM_CLOSEFD, YES)
+ buf = imgl1r (in[i])
+ default:
+ call sfree (sp)
+ call strclose (fd)
+ call erract (EA_ERROR)
+ }
+ }
+ }
+
+ call strclose (fd)
+ }
+
+ call ic_combiner (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n],
+ Memi[m], Memi[lflag], offsets, Memr[scales], Memr[zeros],
+ Memr[wts], nimages, npts)
+end
+
+
+# IC_COMBINE -- Combine images.
+
+procedure ic_combiner (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, wts, nimages, npts)
+
+pointer in[nimages] # Input images
+pointer out[4] # Output image
+pointer dbuf[nimages] # Data buffers for nonaligned images
+pointer d[nimages] # Data pointers
+pointer id[nimages] # Image index ID pointers
+int n[npts] # Number of good pixels
+pointer m[nimages] # Mask pointers
+int lflag[nimages] # Line flags
+int offsets[nimages,ARB] # Input image offsets
+real scales[nimages] # Scale factors
+real zeros[nimages] # Zero offset factors
+real wts[nimages] # Combining weights
+int nimages # Number of input images
+int npts # Number of points per output line
+
+int i, ext, ctor(), ic_qsort(), errcode()
+real r, imgetr()
+pointer sp, fname, imname, v1, v2, v3, work
+pointer outdata, buf, nm, pms
+pointer immap(), impnli()
+pointer impnlr(), imgnlr
+errchk immap, ic_scale, imgetr, ic_grow, ic_growr, ic_rmasks
+extern ic_qsort
+
+include "../icombine.com"
+data ext/0/
+
+begin
+ call smark (sp)
+ call salloc (fname, SZ_FNAME, TY_CHAR)
+ call salloc (imname, SZ_FNAME, TY_CHAR)
+ call salloc (v1, IM_MAXDIM, TY_LONG)
+ call salloc (v2, IM_MAXDIM, TY_LONG)
+ call salloc (v3, IM_MAXDIM, TY_LONG)
+ call amovkl (long(1), Meml[v1], IM_MAXDIM)
+ call amovkl (long(1), Meml[v2], IM_MAXDIM)
+ call amovkl (long(1), Meml[v3], IM_MAXDIM)
+
+ call ic_scale (in, out, offsets, scales, zeros, wts, nimages)
+
+ # Set combine parameters
+ switch (combine) {
+ case AVERAGE:
+ if (dowts)
+ keepids = true
+ else
+ keepids = false
+ case MEDIAN:
+ dowts = false
+ keepids = false
+ }
+ docombine = true
+
+ # Set rejection algorithm specific parameters
+ switch (reject) {
+ case CCDCLIP, CRREJECT:
+ call salloc (nm, 3*nimages, TY_REAL)
+ i = 1
+ if (ctor (Memc[rdnoise], i, r) > 0) {
+ do i = 1, nimages
+ Memr[nm+3*(i-1)] = r
+ } else {
+ do i = 1, nimages
+ Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise])
+ }
+ i = 1
+ if (ctor (Memc[gain], i, r) > 0) {
+ do i = 1, nimages {
+ Memr[nm+3*(i-1)+1] = r
+ Memr[nm+3*(i-1)] =
+ max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL)
+ }
+ } else {
+ do i = 1, nimages {
+ r = imgetr (in[i], Memc[gain])
+ Memr[nm+3*(i-1)+1] = r
+ Memr[nm+3*(i-1)] =
+ max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL)
+ }
+ }
+ i = 1
+ if (ctor (Memc[snoise], i, r) > 0) {
+ do i = 1, nimages
+ Memr[nm+3*(i-1)+2] = r
+ } else {
+ do i = 1, nimages {
+ r = imgetr (in[i], Memc[snoise])
+ Memr[nm+3*(i-1)+2] = r
+ }
+ }
+ if (!keepids) {
+ if (doscale1)
+ keepids = true
+ else {
+ do i = 2, nimages {
+ if (Memr[nm+3*(i-1)] != Memr[nm] ||
+ Memr[nm+3*(i-1)+1] != Memr[nm+1] ||
+ Memr[nm+3*(i-1)+2] != Memr[nm+2]) {
+ keepids = true
+ break
+ }
+ }
+ }
+ }
+ if (reject == CRREJECT)
+ lsigma = MAX_REAL
+ case MINMAX:
+ mclip = false
+ case PCLIP:
+ mclip = true
+ case AVSIGCLIP, SIGCLIP:
+ if (doscale1)
+ keepids = true
+ case NONE:
+ mclip = false
+ }
+
+ if (out[4] != NULL)
+ keepids = true
+
+ if (grow >= 1.) {
+ keepids = true
+ call salloc (work, npts * nimages, TY_INT)
+ }
+ pms = NULL
+
+ if (keepids) {
+ do i = 1, nimages
+ call salloc (id[i], npts, TY_INT)
+ }
+
+ while (impnlr (out[1], outdata, Meml[v1]) != EOF) {
+ call ic_gdatar (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, nimages, npts, Meml[v2], Meml[v3])
+
+ switch (reject) {
+ case CCDCLIP, CRREJECT:
+ if (mclip)
+ call ic_mccdclipr (d, id, n, scales, zeros, Memr[nm],
+ nimages, npts, Memr[outdata])
+ else
+ call ic_accdclipr (d, id, n, scales, zeros, Memr[nm],
+ nimages, npts, Memr[outdata])
+ case MINMAX:
+ call ic_mmr (d, id, n, npts)
+ case PCLIP:
+ call ic_pclipr (d, id, n, nimages, npts, Memr[outdata])
+ case SIGCLIP:
+ if (mclip)
+ call ic_msigclipr (d, id, n, scales, zeros, nimages, npts,
+ Memr[outdata])
+ else
+ call ic_asigclipr (d, id, n, scales, zeros, nimages, npts,
+ Memr[outdata])
+ case AVSIGCLIP:
+ if (mclip)
+ call ic_mavsigclipr (d, id, n, scales, zeros, nimages,
+ npts, Memr[outdata])
+ else
+ call ic_aavsigclipr (d, id, n, scales, zeros, nimages,
+ npts, Memr[outdata])
+ }
+
+ if (pms == NULL || nkeep > 0) {
+ if (docombine) {
+ switch (combine) {
+ case AVERAGE:
+ call ic_averager (d, id, n, wts, npts, YES,
+ Memr[outdata])
+ case MEDIAN:
+ call ic_medianr (d, n, npts, YES, Memr[outdata])
+ }
+ }
+ }
+
+ if (grow >= 1.)
+ call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts,
+ pms)
+
+ if (pms == NULL) {
+ if (out[2] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnli (out[2], buf, Meml[v1])
+ call amovki (nimages, Memi[buf], npts)
+ call asubi (Memi[buf], n, Memi[buf], npts)
+ }
+
+ if (out[3] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnlr (out[3], buf, Meml[v1])
+ call ic_sigmar (d, id, n, wts, npts, Memr[outdata],
+ Memr[buf])
+ }
+
+ if (out[4] != NULL)
+ call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts)
+ }
+
+ call amovl (Meml[v1], Meml[v2], IM_MAXDIM)
+ }
+
+ if (pms != NULL) {
+ if (nkeep > 0) {
+ call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME)
+ call imunmap (out[1])
+ iferr (buf = immap (Memc[fname], READ_WRITE, 0)) {
+ switch (errcode()) {
+ case SYS_FXFOPNOEXTNV:
+ call imgcluster (Memc[fname], Memc[fname], SZ_FNAME)
+ ext = ext + 1
+ call sprintf (Memc[imname], SZ_FNAME, "%s[%d]")
+ call pargstr (Memc[fname])
+ call pargi (ext)
+ iferr (buf = immap (Memc[imname], READ_WRITE, 0)) {
+ buf = NULL
+ ext = 0
+ }
+ repeat {
+ call sprintf (Memc[imname], SZ_FNAME, "%s[%d]")
+ call pargstr (Memc[fname])
+ call pargi (ext+1)
+ iferr (outdata = immap (Memc[imname],READ_WRITE,0))
+ break
+ if (buf != NULL)
+ call imunmap (buf)
+ buf = outdata
+ ext = ext + 1
+ }
+ default:
+ call erract (EA_ERROR)
+ }
+ }
+ out[1] = buf
+ }
+
+ call amovkl (long(1), Meml[v1], IM_MAXDIM)
+ call amovkl (long(1), Meml[v2], IM_MAXDIM)
+ call amovkl (long(1), Meml[v3], IM_MAXDIM)
+ while (impnlr (out[1], outdata, Meml[v1]) != EOF) {
+ call ic_gdatar (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, nimages, npts, Meml[v2], Meml[v3])
+
+ call ic_growr (Meml[v2], d, id, n, Memi[work], nimages, npts,
+ pms)
+
+ if (nkeep > 0) {
+ do i = 1, npts {
+ if (n[i] < nkeep) {
+ Meml[v1+1] = Meml[v1+1] - 1
+ if (imgnlr (out[1], buf, Meml[v1]) == EOF)
+ ;
+ call amovr (Memr[buf], Memr[outdata], npts)
+ break
+ }
+ }
+ }
+
+ switch (combine) {
+ case AVERAGE:
+ call ic_averager (d, id, n, wts, npts, NO, Memr[outdata])
+ case MEDIAN:
+ call ic_medianr (d, n, npts, NO, Memr[outdata])
+ }
+
+ if (out[2] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnli (out[2], buf, Meml[v1])
+ call amovki (nimages, Memi[buf], npts)
+ call asubi (Memi[buf], n, Memi[buf], npts)
+ }
+
+ if (out[3] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnlr (out[3], buf, Meml[v1])
+ call ic_sigmar (d, id, n, wts, npts, Memr[outdata],
+ Memr[buf])
+ }
+
+ if (out[4] != NULL)
+ call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts)
+
+ call amovl (Meml[v1], Meml[v2], IM_MAXDIM)
+ }
+
+ do i = 1, nimages
+ call pm_close (Memi[pms+i-1])
+ call mfree (pms, TY_POINTER)
+ }
+
+ call sfree (sp)
+end
+
+procedure icombined (in, out, offsets, nimages, bufsize)
+
+pointer in[nimages] # Input images
+pointer out[4] # Output images
+int offsets[nimages,ARB] # Input image offsets
+int nimages # Number of input images
+int bufsize # IMIO buffer size
+
+char str[1]
+int i, j, npts, fd, stropen(), errcode(), imstati()
+pointer sp, d, id, n, m, lflag, scales, zeros, wts, dbuf
+pointer buf, imgl1d(), impl1i()
+errchk stropen, imgl1d, impl1i
+pointer impl1d()
+errchk impl1d
+
+include "../icombine.com"
+
+begin
+ npts = IM_LEN(out[1],1)
+
+ # Allocate memory.
+ call smark (sp)
+ call salloc (dbuf, nimages, TY_POINTER)
+ call salloc (d, nimages, TY_POINTER)
+ call salloc (id, nimages, TY_POINTER)
+ call salloc (n, npts, TY_INT)
+ call salloc (m, nimages, TY_POINTER)
+ call salloc (lflag, nimages, TY_INT)
+ call salloc (scales, nimages, TY_REAL)
+ call salloc (zeros, nimages, TY_REAL)
+ call salloc (wts, nimages, TY_REAL)
+ call amovki (D_ALL, Memi[lflag], nimages)
+
+ # If not aligned or growing create data buffers of output length
+ # otherwise use the IMIO buffers.
+
+ if (!aligned || grow >= 1.) {
+ do i = 1, nimages
+ call salloc (Memi[dbuf+i-1], npts, TY_DOUBLE)
+ } else
+ call amovki (NULL, Memi[dbuf], nimages)
+
+ if (project) {
+ call imseti (in[1], IM_NBUFS, nimages)
+ call imseti (in[1], IM_BUFSIZE, bufsize)
+ do i = 1, 3 {
+ if (out[i] != NULL)
+ call imseti (out[i], IM_BUFSIZE, bufsize)
+ }
+ } else {
+ # Reserve FD for string operations.
+ fd = stropen (str, 1, NEW_FILE)
+
+ # Do I/O to the images.
+ do i = 1, 3 {
+ if (out[i] != NULL)
+ call imseti (out[i], IM_BUFSIZE, bufsize)
+ }
+ buf = impl1d (out[1])
+ call aclrd (Memd[buf], npts)
+ if (out[3] != NULL) {
+ buf = impl1d (out[3])
+ call aclrd (Memd[buf], npts)
+ }
+ if (out[2] != NULL) {
+ buf = impl1i (out[2])
+ call aclri (Memi[buf], npts)
+ }
+
+ do i = 1, nimages {
+ call imseti (in[i], IM_BUFSIZE, bufsize)
+ iferr (buf = imgl1d (in[i])) {
+ switch (errcode()) {
+ case SYS_MFULL:
+ call sfree (sp)
+ call strclose (fd)
+ call erract (EA_ERROR)
+ case SYS_FTOOMANYFILES, SYS_IKIOPIX:
+ if (imstati (in[i], IM_CLOSEFD) == YES) {
+ call sfree (sp)
+ call strclose (fd)
+ call erract (EA_ERROR)
+ }
+ do j = i-2, nimages
+ call imseti (in[j], IM_CLOSEFD, YES)
+ buf = imgl1d (in[i])
+ default:
+ call sfree (sp)
+ call strclose (fd)
+ call erract (EA_ERROR)
+ }
+ }
+ }
+
+ call strclose (fd)
+ }
+
+ call ic_combined (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n],
+ Memi[m], Memi[lflag], offsets, Memr[scales], Memr[zeros],
+ Memr[wts], nimages, npts)
+end
+
+
+# IC_COMBINE -- Combine images.
+
+procedure ic_combined (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, wts, nimages, npts)
+
+pointer in[nimages] # Input images
+pointer out[4] # Output image
+pointer dbuf[nimages] # Data buffers for nonaligned images
+pointer d[nimages] # Data pointers
+pointer id[nimages] # Image index ID pointers
+int n[npts] # Number of good pixels
+pointer m[nimages] # Mask pointers
+int lflag[nimages] # Line flags
+int offsets[nimages,ARB] # Input image offsets
+real scales[nimages] # Scale factors
+real zeros[nimages] # Zero offset factors
+real wts[nimages] # Combining weights
+int nimages # Number of input images
+int npts # Number of points per output line
+
+int i, ext, ctor(), ic_qsort(), errcode()
+real r, imgetr()
+pointer sp, fname, imname, v1, v2, v3, work
+pointer outdata, buf, nm, pms
+pointer immap(), impnli()
+pointer impnld(), imgnld
+errchk immap, ic_scale, imgetr, ic_grow, ic_growd, ic_rmasks
+extern ic_qsort
+
+include "../icombine.com"
+data ext/0/
+
+begin
+ call smark (sp)
+ call salloc (fname, SZ_FNAME, TY_CHAR)
+ call salloc (imname, SZ_FNAME, TY_CHAR)
+ call salloc (v1, IM_MAXDIM, TY_LONG)
+ call salloc (v2, IM_MAXDIM, TY_LONG)
+ call salloc (v3, IM_MAXDIM, TY_LONG)
+ call amovkl (long(1), Meml[v1], IM_MAXDIM)
+ call amovkl (long(1), Meml[v2], IM_MAXDIM)
+ call amovkl (long(1), Meml[v3], IM_MAXDIM)
+
+ call ic_scale (in, out, offsets, scales, zeros, wts, nimages)
+
+ # Set combine parameters
+ switch (combine) {
+ case AVERAGE:
+ if (dowts)
+ keepids = true
+ else
+ keepids = false
+ case MEDIAN:
+ dowts = false
+ keepids = false
+ }
+ docombine = true
+
+ # Set rejection algorithm specific parameters
+ switch (reject) {
+ case CCDCLIP, CRREJECT:
+ call salloc (nm, 3*nimages, TY_REAL)
+ i = 1
+ if (ctor (Memc[rdnoise], i, r) > 0) {
+ do i = 1, nimages
+ Memr[nm+3*(i-1)] = r
+ } else {
+ do i = 1, nimages
+ Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise])
+ }
+ i = 1
+ if (ctor (Memc[gain], i, r) > 0) {
+ do i = 1, nimages {
+ Memr[nm+3*(i-1)+1] = r
+ Memr[nm+3*(i-1)] =
+ max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL)
+ }
+ } else {
+ do i = 1, nimages {
+ r = imgetr (in[i], Memc[gain])
+ Memr[nm+3*(i-1)+1] = r
+ Memr[nm+3*(i-1)] =
+ max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL)
+ }
+ }
+ i = 1
+ if (ctor (Memc[snoise], i, r) > 0) {
+ do i = 1, nimages
+ Memr[nm+3*(i-1)+2] = r
+ } else {
+ do i = 1, nimages {
+ r = imgetr (in[i], Memc[snoise])
+ Memr[nm+3*(i-1)+2] = r
+ }
+ }
+ if (!keepids) {
+ if (doscale1)
+ keepids = true
+ else {
+ do i = 2, nimages {
+ if (Memr[nm+3*(i-1)] != Memr[nm] ||
+ Memr[nm+3*(i-1)+1] != Memr[nm+1] ||
+ Memr[nm+3*(i-1)+2] != Memr[nm+2]) {
+ keepids = true
+ break
+ }
+ }
+ }
+ }
+ if (reject == CRREJECT)
+ lsigma = MAX_REAL
+ case MINMAX:
+ mclip = false
+ case PCLIP:
+ mclip = true
+ case AVSIGCLIP, SIGCLIP:
+ if (doscale1)
+ keepids = true
+ case NONE:
+ mclip = false
+ }
+
+ if (out[4] != NULL)
+ keepids = true
+
+ if (grow >= 1.) {
+ keepids = true
+ call salloc (work, npts * nimages, TY_INT)
+ }
+ pms = NULL
+
+ if (keepids) {
+ do i = 1, nimages
+ call salloc (id[i], npts, TY_INT)
+ }
+
+ while (impnld (out[1], outdata, Meml[v1]) != EOF) {
+ call ic_gdatad (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, nimages, npts, Meml[v2], Meml[v3])
+
+ switch (reject) {
+ case CCDCLIP, CRREJECT:
+ if (mclip)
+ call ic_mccdclipd (d, id, n, scales, zeros, Memr[nm],
+ nimages, npts, Memd[outdata])
+ else
+ call ic_accdclipd (d, id, n, scales, zeros, Memr[nm],
+ nimages, npts, Memd[outdata])
+ case MINMAX:
+ call ic_mmd (d, id, n, npts)
+ case PCLIP:
+ call ic_pclipd (d, id, n, nimages, npts, Memd[outdata])
+ case SIGCLIP:
+ if (mclip)
+ call ic_msigclipd (d, id, n, scales, zeros, nimages, npts,
+ Memd[outdata])
+ else
+ call ic_asigclipd (d, id, n, scales, zeros, nimages, npts,
+ Memd[outdata])
+ case AVSIGCLIP:
+ if (mclip)
+ call ic_mavsigclipd (d, id, n, scales, zeros, nimages,
+ npts, Memd[outdata])
+ else
+ call ic_aavsigclipd (d, id, n, scales, zeros, nimages,
+ npts, Memd[outdata])
+ }
+
+ if (pms == NULL || nkeep > 0) {
+ if (docombine) {
+ switch (combine) {
+ case AVERAGE:
+ call ic_averaged (d, id, n, wts, npts, YES,
+ Memd[outdata])
+ case MEDIAN:
+ call ic_mediand (d, n, npts, YES, Memd[outdata])
+ }
+ }
+ }
+
+ if (grow >= 1.)
+ call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts,
+ pms)
+
+ if (pms == NULL) {
+ if (out[2] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnli (out[2], buf, Meml[v1])
+ call amovki (nimages, Memi[buf], npts)
+ call asubi (Memi[buf], n, Memi[buf], npts)
+ }
+
+ if (out[3] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnld (out[3], buf, Meml[v1])
+ call ic_sigmad (d, id, n, wts, npts, Memd[outdata],
+ Memd[buf])
+ }
+
+ if (out[4] != NULL)
+ call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts)
+ }
+
+ call amovl (Meml[v1], Meml[v2], IM_MAXDIM)
+ }
+
+ if (pms != NULL) {
+ if (nkeep > 0) {
+ call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME)
+ call imunmap (out[1])
+ iferr (buf = immap (Memc[fname], READ_WRITE, 0)) {
+ switch (errcode()) {
+ case SYS_FXFOPNOEXTNV:
+ call imgcluster (Memc[fname], Memc[fname], SZ_FNAME)
+ ext = ext + 1
+ call sprintf (Memc[imname], SZ_FNAME, "%s[%d]")
+ call pargstr (Memc[fname])
+ call pargi (ext)
+ iferr (buf = immap (Memc[imname], READ_WRITE, 0)) {
+ buf = NULL
+ ext = 0
+ }
+ repeat {
+ call sprintf (Memc[imname], SZ_FNAME, "%s[%d]")
+ call pargstr (Memc[fname])
+ call pargi (ext+1)
+ iferr (outdata = immap (Memc[imname],READ_WRITE,0))
+ break
+ if (buf != NULL)
+ call imunmap (buf)
+ buf = outdata
+ ext = ext + 1
+ }
+ default:
+ call erract (EA_ERROR)
+ }
+ }
+ out[1] = buf
+ }
+
+ call amovkl (long(1), Meml[v1], IM_MAXDIM)
+ call amovkl (long(1), Meml[v2], IM_MAXDIM)
+ call amovkl (long(1), Meml[v3], IM_MAXDIM)
+ while (impnld (out[1], outdata, Meml[v1]) != EOF) {
+ call ic_gdatad (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, nimages, npts, Meml[v2], Meml[v3])
+
+ call ic_growd (Meml[v2], d, id, n, Memi[work], nimages, npts,
+ pms)
+
+ if (nkeep > 0) {
+ do i = 1, npts {
+ if (n[i] < nkeep) {
+ Meml[v1+1] = Meml[v1+1] - 1
+ if (imgnld (out[1], buf, Meml[v1]) == EOF)
+ ;
+ call amovd (Memd[buf], Memd[outdata], npts)
+ break
+ }
+ }
+ }
+
+ switch (combine) {
+ case AVERAGE:
+ call ic_averaged (d, id, n, wts, npts, NO, Memd[outdata])
+ case MEDIAN:
+ call ic_mediand (d, n, npts, NO, Memd[outdata])
+ }
+
+ if (out[2] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnli (out[2], buf, Meml[v1])
+ call amovki (nimages, Memi[buf], npts)
+ call asubi (Memi[buf], n, Memi[buf], npts)
+ }
+
+ if (out[3] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnld (out[3], buf, Meml[v1])
+ call ic_sigmad (d, id, n, wts, npts, Memd[outdata],
+ Memd[buf])
+ }
+
+ if (out[4] != NULL)
+ call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts)
+
+ call amovl (Meml[v1], Meml[v2], IM_MAXDIM)
+ }
+
+ do i = 1, nimages
+ call pm_close (Memi[pms+i-1])
+ call mfree (pms, TY_POINTER)
+ }
+
+ call sfree (sp)
+end
+
+
+
+# IC_QSORT -- Compare line numbers for GQSORT.
+
+int procedure ic_qsort (arg, i1, i2)
+
+pointer arg
+int i1, i2
+
+begin
+ if (Mems[arg+i1-1] < Mems[arg+i2-1])
+ return (-1)
+ else if (Mems[arg+i1-1] > Mems[arg+i2-1])
+ return (1)
+ else
+ return (0)
+end
diff --git a/pkg/obsolete/imcombine/generic/icpclip.x b/pkg/obsolete/imcombine/generic/icpclip.x
new file mode 100644
index 00000000..237d9686
--- /dev/null
+++ b/pkg/obsolete/imcombine/generic/icpclip.x
@@ -0,0 +1,878 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include "../icombine.h"
+
+define MINCLIP 3 # Minimum number for clipping
+
+
+# IC_PCLIP -- Percentile clip
+#
+# 1) Find the median
+# 2) Find the pixel which is the specified order index away
+# 3) Use the data value difference as a sigma and apply clipping
+# 4) Since the median is known return it so it does not have to be recomputed
+
+procedure ic_pclips (d, m, n, nimages, npts, median)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image id pointers
+int n[npts] # Number of good pixels
+int nimages # Number of input images
+int npts # Number of output points per line
+real median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep
+bool even, fp_equalr()
+real sigma, r, s, t
+pointer sp, resid, mp1, mp2
+real med
+
+include "../icombine.com"
+
+begin
+ # There must be at least MINCLIP and more than nkeep pixels.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Set sign of pclip parameter
+ if (pclip < 0)
+ t = -1.
+ else
+ t = 1.
+
+ # If there are no rejected pixels compute certain parameters once.
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ n2 = 1 + n1 / 2
+ even = (mod (n1, 2) == 0)
+ if (pclip < 0.) {
+ if (even)
+ n3 = max (1, nint (n2 - 1 + pclip))
+ else
+ n3 = max (1, nint (n2 + pclip))
+ } else
+ n3 = min (n1, nint (n2 + pclip))
+ nin = n1
+ }
+
+ # Now apply clipping.
+ do i = 1, npts {
+ # Compute median.
+ if (dflag == D_MIX) {
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 == 0) {
+ if (combine == MEDIAN)
+ median[i] = blank
+ next
+ }
+ n2 = 1 + n1 / 2
+ even = (mod (n1, 2) == 0)
+ if (pclip < 0) {
+ if (even)
+ n3 = max (1, nint (n2 - 1 + pclip))
+ else
+ n3 = max (1, nint (n2 + pclip))
+ } else
+ n3 = min (n1, nint (n2 + pclip))
+ }
+
+ j = i - 1
+ if (even) {
+ med = Mems[d[n2-1]+j]
+ med = (med + Mems[d[n2]+j]) / 2.
+ } else
+ med = Mems[d[n2]+j]
+
+ if (n1 < max (MINCLIP, maxkeep+1)) {
+ if (combine == MEDIAN)
+ median[i] = med
+ next
+ }
+
+ # Define sigma for clipping
+ sigma = t * (Mems[d[n3]+j] - med)
+ if (fp_equalr (sigma, 0.)) {
+ if (combine == MEDIAN)
+ median[i] = med
+ next
+ }
+
+ # Reject pixels and save residuals.
+ # Check if any pixels are clipped.
+ # If so recompute the median and reset the number of good pixels.
+ # Only reorder if needed.
+
+ for (nl=1; nl<=n1; nl=nl+1) {
+ r = (med - Mems[d[nl]+j]) / sigma
+ if (r < lsigma)
+ break
+ Memr[resid+nl] = r
+ }
+ for (nh=n1; nh>=1; nh=nh-1) {
+ r = (Mems[d[nh]+j] - med) / sigma
+ if (r < hsigma)
+ break
+ Memr[resid+nh] = r
+ }
+ n4 = nh - nl + 1
+
+ # If too many pixels are rejected add some back in.
+ # All pixels with the same residual are added.
+ while (n4 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n4 = nh - nl + 1
+ }
+
+ # If any pixels are rejected recompute the median.
+ if (nl > 1 || nh < n1) {
+ n5 = nl + n4 / 2
+ if (mod (n4, 2) == 0) {
+ med = Mems[d[n5-1]+j]
+ med = (med + Mems[d[n5]+j]) / 2.
+ } else
+ med = Mems[d[n5]+j]
+ n[i] = n4
+ }
+ if (combine == MEDIAN)
+ median[i] = med
+
+ # Reorder if pixels only if necessary.
+ if (nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ k = max (nl, n4 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Mems[d[l]+j] = Mems[d[k]+j]
+ if (grow >= 1.) {
+ mp1 = m[l] + j
+ mp2 = m[k] + j
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+j] = Memi[m[k]+j]
+ k = k + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Mems[d[l]+j] = Mems[d[k]+j]
+ k = k + 1
+ }
+ }
+ }
+ }
+
+ # Check if data flag needs to be reset for rejected pixels.
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag whether the median has been computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+
+# IC_PCLIP -- Percentile clip
+#
+# 1) Find the median
+# 2) Find the pixel which is the specified order index away
+# 3) Use the data value difference as a sigma and apply clipping
+# 4) Since the median is known return it so it does not have to be recomputed
+
+procedure ic_pclipi (d, m, n, nimages, npts, median)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image id pointers
+int n[npts] # Number of good pixels
+int nimages # Number of input images
+int npts # Number of output points per line
+real median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep
+bool even, fp_equalr()
+real sigma, r, s, t
+pointer sp, resid, mp1, mp2
+real med
+
+include "../icombine.com"
+
+begin
+ # There must be at least MINCLIP and more than nkeep pixels.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Set sign of pclip parameter
+ if (pclip < 0)
+ t = -1.
+ else
+ t = 1.
+
+ # If there are no rejected pixels compute certain parameters once.
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ n2 = 1 + n1 / 2
+ even = (mod (n1, 2) == 0)
+ if (pclip < 0.) {
+ if (even)
+ n3 = max (1, nint (n2 - 1 + pclip))
+ else
+ n3 = max (1, nint (n2 + pclip))
+ } else
+ n3 = min (n1, nint (n2 + pclip))
+ nin = n1
+ }
+
+ # Now apply clipping.
+ do i = 1, npts {
+ # Compute median.
+ if (dflag == D_MIX) {
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 == 0) {
+ if (combine == MEDIAN)
+ median[i] = blank
+ next
+ }
+ n2 = 1 + n1 / 2
+ even = (mod (n1, 2) == 0)
+ if (pclip < 0) {
+ if (even)
+ n3 = max (1, nint (n2 - 1 + pclip))
+ else
+ n3 = max (1, nint (n2 + pclip))
+ } else
+ n3 = min (n1, nint (n2 + pclip))
+ }
+
+ j = i - 1
+ if (even) {
+ med = Memi[d[n2-1]+j]
+ med = (med + Memi[d[n2]+j]) / 2.
+ } else
+ med = Memi[d[n2]+j]
+
+ if (n1 < max (MINCLIP, maxkeep+1)) {
+ if (combine == MEDIAN)
+ median[i] = med
+ next
+ }
+
+ # Define sigma for clipping
+ sigma = t * (Memi[d[n3]+j] - med)
+ if (fp_equalr (sigma, 0.)) {
+ if (combine == MEDIAN)
+ median[i] = med
+ next
+ }
+
+ # Reject pixels and save residuals.
+ # Check if any pixels are clipped.
+ # If so recompute the median and reset the number of good pixels.
+ # Only reorder if needed.
+
+ for (nl=1; nl<=n1; nl=nl+1) {
+ r = (med - Memi[d[nl]+j]) / sigma
+ if (r < lsigma)
+ break
+ Memr[resid+nl] = r
+ }
+ for (nh=n1; nh>=1; nh=nh-1) {
+ r = (Memi[d[nh]+j] - med) / sigma
+ if (r < hsigma)
+ break
+ Memr[resid+nh] = r
+ }
+ n4 = nh - nl + 1
+
+ # If too many pixels are rejected add some back in.
+ # All pixels with the same residual are added.
+ while (n4 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n4 = nh - nl + 1
+ }
+
+ # If any pixels are rejected recompute the median.
+ if (nl > 1 || nh < n1) {
+ n5 = nl + n4 / 2
+ if (mod (n4, 2) == 0) {
+ med = Memi[d[n5-1]+j]
+ med = (med + Memi[d[n5]+j]) / 2.
+ } else
+ med = Memi[d[n5]+j]
+ n[i] = n4
+ }
+ if (combine == MEDIAN)
+ median[i] = med
+
+ # Reorder if pixels only if necessary.
+ if (nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ k = max (nl, n4 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Memi[d[l]+j] = Memi[d[k]+j]
+ if (grow >= 1.) {
+ mp1 = m[l] + j
+ mp2 = m[k] + j
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+j] = Memi[m[k]+j]
+ k = k + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Memi[d[l]+j] = Memi[d[k]+j]
+ k = k + 1
+ }
+ }
+ }
+ }
+
+ # Check if data flag needs to be reset for rejected pixels.
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag whether the median has been computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+
+# IC_PCLIP -- Percentile clip
+#
+# 1) Find the median
+# 2) Find the pixel which is the specified order index away
+# 3) Use the data value difference as a sigma and apply clipping
+# 4) Since the median is known return it so it does not have to be recomputed
+
+procedure ic_pclipr (d, m, n, nimages, npts, median)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image id pointers
+int n[npts] # Number of good pixels
+int nimages # Number of input images
+int npts # Number of output points per line
+real median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep
+bool even, fp_equalr()
+real sigma, r, s, t
+pointer sp, resid, mp1, mp2
+real med
+
+include "../icombine.com"
+
+begin
+ # There must be at least MINCLIP and more than nkeep pixels.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Set sign of pclip parameter
+ if (pclip < 0)
+ t = -1.
+ else
+ t = 1.
+
+ # If there are no rejected pixels compute certain parameters once.
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ n2 = 1 + n1 / 2
+ even = (mod (n1, 2) == 0)
+ if (pclip < 0.) {
+ if (even)
+ n3 = max (1, nint (n2 - 1 + pclip))
+ else
+ n3 = max (1, nint (n2 + pclip))
+ } else
+ n3 = min (n1, nint (n2 + pclip))
+ nin = n1
+ }
+
+ # Now apply clipping.
+ do i = 1, npts {
+ # Compute median.
+ if (dflag == D_MIX) {
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 == 0) {
+ if (combine == MEDIAN)
+ median[i] = blank
+ next
+ }
+ n2 = 1 + n1 / 2
+ even = (mod (n1, 2) == 0)
+ if (pclip < 0) {
+ if (even)
+ n3 = max (1, nint (n2 - 1 + pclip))
+ else
+ n3 = max (1, nint (n2 + pclip))
+ } else
+ n3 = min (n1, nint (n2 + pclip))
+ }
+
+ j = i - 1
+ if (even) {
+ med = Memr[d[n2-1]+j]
+ med = (med + Memr[d[n2]+j]) / 2.
+ } else
+ med = Memr[d[n2]+j]
+
+ if (n1 < max (MINCLIP, maxkeep+1)) {
+ if (combine == MEDIAN)
+ median[i] = med
+ next
+ }
+
+ # Define sigma for clipping
+ sigma = t * (Memr[d[n3]+j] - med)
+ if (fp_equalr (sigma, 0.)) {
+ if (combine == MEDIAN)
+ median[i] = med
+ next
+ }
+
+ # Reject pixels and save residuals.
+ # Check if any pixels are clipped.
+ # If so recompute the median and reset the number of good pixels.
+ # Only reorder if needed.
+
+ for (nl=1; nl<=n1; nl=nl+1) {
+ r = (med - Memr[d[nl]+j]) / sigma
+ if (r < lsigma)
+ break
+ Memr[resid+nl] = r
+ }
+ for (nh=n1; nh>=1; nh=nh-1) {
+ r = (Memr[d[nh]+j] - med) / sigma
+ if (r < hsigma)
+ break
+ Memr[resid+nh] = r
+ }
+ n4 = nh - nl + 1
+
+ # If too many pixels are rejected add some back in.
+ # All pixels with the same residual are added.
+ while (n4 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n4 = nh - nl + 1
+ }
+
+ # If any pixels are rejected recompute the median.
+ if (nl > 1 || nh < n1) {
+ n5 = nl + n4 / 2
+ if (mod (n4, 2) == 0) {
+ med = Memr[d[n5-1]+j]
+ med = (med + Memr[d[n5]+j]) / 2.
+ } else
+ med = Memr[d[n5]+j]
+ n[i] = n4
+ }
+ if (combine == MEDIAN)
+ median[i] = med
+
+ # Reorder if pixels only if necessary.
+ if (nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ k = max (nl, n4 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Memr[d[l]+j] = Memr[d[k]+j]
+ if (grow >= 1.) {
+ mp1 = m[l] + j
+ mp2 = m[k] + j
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+j] = Memi[m[k]+j]
+ k = k + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Memr[d[l]+j] = Memr[d[k]+j]
+ k = k + 1
+ }
+ }
+ }
+ }
+
+ # Check if data flag needs to be reset for rejected pixels.
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag whether the median has been computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+
+# IC_PCLIP -- Percentile clip
+#
+# 1) Find the median
+# 2) Find the pixel which is the specified order index away
+# 3) Use the data value difference as a sigma and apply clipping
+# 4) Since the median is known return it so it does not have to be recomputed
+
+procedure ic_pclipd (d, m, n, nimages, npts, median)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image id pointers
+int n[npts] # Number of good pixels
+int nimages # Number of input images
+int npts # Number of output points per line
+double median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep
+bool even, fp_equalr()
+real sigma, r, s, t
+pointer sp, resid, mp1, mp2
+double med
+
+include "../icombine.com"
+
+begin
+ # There must be at least MINCLIP and more than nkeep pixels.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Set sign of pclip parameter
+ if (pclip < 0)
+ t = -1.
+ else
+ t = 1.
+
+ # If there are no rejected pixels compute certain parameters once.
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ n2 = 1 + n1 / 2
+ even = (mod (n1, 2) == 0)
+ if (pclip < 0.) {
+ if (even)
+ n3 = max (1, nint (n2 - 1 + pclip))
+ else
+ n3 = max (1, nint (n2 + pclip))
+ } else
+ n3 = min (n1, nint (n2 + pclip))
+ nin = n1
+ }
+
+ # Now apply clipping.
+ do i = 1, npts {
+ # Compute median.
+ if (dflag == D_MIX) {
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 == 0) {
+ if (combine == MEDIAN)
+ median[i] = blank
+ next
+ }
+ n2 = 1 + n1 / 2
+ even = (mod (n1, 2) == 0)
+ if (pclip < 0) {
+ if (even)
+ n3 = max (1, nint (n2 - 1 + pclip))
+ else
+ n3 = max (1, nint (n2 + pclip))
+ } else
+ n3 = min (n1, nint (n2 + pclip))
+ }
+
+ j = i - 1
+ if (even) {
+ med = Memd[d[n2-1]+j]
+ med = (med + Memd[d[n2]+j]) / 2.
+ } else
+ med = Memd[d[n2]+j]
+
+ if (n1 < max (MINCLIP, maxkeep+1)) {
+ if (combine == MEDIAN)
+ median[i] = med
+ next
+ }
+
+ # Define sigma for clipping
+ sigma = t * (Memd[d[n3]+j] - med)
+ if (fp_equalr (sigma, 0.)) {
+ if (combine == MEDIAN)
+ median[i] = med
+ next
+ }
+
+ # Reject pixels and save residuals.
+ # Check if any pixels are clipped.
+ # If so recompute the median and reset the number of good pixels.
+ # Only reorder if needed.
+
+ for (nl=1; nl<=n1; nl=nl+1) {
+ r = (med - Memd[d[nl]+j]) / sigma
+ if (r < lsigma)
+ break
+ Memr[resid+nl] = r
+ }
+ for (nh=n1; nh>=1; nh=nh-1) {
+ r = (Memd[d[nh]+j] - med) / sigma
+ if (r < hsigma)
+ break
+ Memr[resid+nh] = r
+ }
+ n4 = nh - nl + 1
+
+ # If too many pixels are rejected add some back in.
+ # All pixels with the same residual are added.
+ while (n4 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n4 = nh - nl + 1
+ }
+
+ # If any pixels are rejected recompute the median.
+ if (nl > 1 || nh < n1) {
+ n5 = nl + n4 / 2
+ if (mod (n4, 2) == 0) {
+ med = Memd[d[n5-1]+j]
+ med = (med + Memd[d[n5]+j]) / 2.
+ } else
+ med = Memd[d[n5]+j]
+ n[i] = n4
+ }
+ if (combine == MEDIAN)
+ median[i] = med
+
+ # Reorder if pixels only if necessary.
+ if (nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ k = max (nl, n4 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Memd[d[l]+j] = Memd[d[k]+j]
+ if (grow >= 1.) {
+ mp1 = m[l] + j
+ mp2 = m[k] + j
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+j] = Memi[m[k]+j]
+ k = k + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Memd[d[l]+j] = Memd[d[k]+j]
+ k = k + 1
+ }
+ }
+ }
+ }
+
+ # Check if data flag needs to be reset for rejected pixels.
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag whether the median has been computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
diff --git a/pkg/obsolete/imcombine/generic/icsclip.x b/pkg/obsolete/imcombine/generic/icsclip.x
new file mode 100644
index 00000000..a0188d72
--- /dev/null
+++ b/pkg/obsolete/imcombine/generic/icsclip.x
@@ -0,0 +1,1922 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include "../icombine.h"
+
+define MINCLIP 3 # Mininum number of images for algorithm
+
+
+# IC_ASIGCLIP -- Reject pixels using sigma clipping about the average
+# The initial average rejects the high and low pixels. A correction for
+# different scalings of the images may be made. Weights are not used.
+
+procedure ic_asigclips (d, m, n, scales, zeros, nimages, npts, average)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+real average[npts] # Average
+
+int i, j, k, l, jj, n1, n2, nin, nk, maxkeep
+real d1, low, high, sum, a, s, r, one
+data one /1.0/
+pointer sp, resid, w, wp, dp1, dp2, mp1, mp2
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ # Flag whether returned average needs to be recomputed.
+ if (dowts || combine != AVERAGE)
+ docombine = true
+ else
+ docombine = false
+
+ # Save the residuals and the sigma scaling corrections if needed.
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+ if (doscale1)
+ call salloc (w, nimages, TY_REAL)
+
+ # Do sigma clipping.
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+
+ # If there are not enough pixels simply compute the average.
+ if (n1 < max (3, maxkeep)) {
+ if (!docombine) {
+ if (n1 == 0)
+ average[i] = blank
+ else {
+ sum = Mems[d[1]+k]
+ do j = 2, n1
+ sum = sum + Mems[d[j]+k]
+ average[i] = sum / n1
+ }
+ }
+ next
+ }
+
+ # Compute average with the high and low rejected.
+ low = Mems[d[1]+k]
+ high = Mems[d[2]+k]
+ if (low > high) {
+ d1 = low
+ low = high
+ high = d1
+ }
+ sum = 0.
+ do j = 3, n1 {
+ d1 = Mems[d[j]+k]
+ if (d1 < low) {
+ sum = sum + low
+ low = d1
+ } else if (d1 > high) {
+ sum = sum + high
+ high = d1
+ } else
+ sum = sum + d1
+ }
+ a = sum / (n1 - 2)
+ sum = sum + low + high
+
+ # Iteratively reject pixels and compute the final average if needed.
+ # Compact the data and keep track of the image IDs if needed.
+
+ repeat {
+ n2 = n1
+ if (doscale1) {
+ # Compute sigma corrected for scaling.
+ s = 0.
+ wp = w - 1
+ do j = 1, n1 {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ wp = wp + 1
+
+ d1 = Mems[dp1]
+ l = Memi[mp1]
+ r = sqrt (max (one, (a + zeros[l]) / scales[l]))
+ s = s + ((d1 - a) / r) ** 2
+ Memr[wp] = r
+ }
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels. Save the residuals and data values.
+ wp = w - 1
+ if (s > 0.) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ wp = wp + 1
+
+ d1 = Mems[dp1]
+ r = (d1 - a) / (s * Memr[wp])
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs (r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Mems[dp1] = Mems[dp2]
+ Mems[dp2] = d1
+ Memr[wp] = Memr[w+n1-1]
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ } else {
+ # Compute the sigma without scale correction.
+ s = 0.
+ do j = 1, n1
+ s = s + (Mems[d[j]+k] - a) ** 2
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels. Save the residuals and data values.
+ if (s > 0.) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ d1 = Mems[dp1]
+ r = (d1 - a) / s
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs (r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Mems[dp1] = Mems[dp2]
+ Mems[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ }
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ }
+
+ # Recompute the average.
+ if (n1 > 1)
+ a = sum / n1
+ } until (n1 == n2 || n1 <= max (2, maxkeep))
+
+ # If too many pixels are rejected add some back.
+ # All pixels with equal residuals are added back.
+ if (n1 < maxkeep) {
+ nk = maxkeep
+ if (doscale1) {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Mems[dp1]
+ Mems[dp1] = Mems[dp2]
+ Mems[dp2] = d1
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ sum = sum + Mems[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ } else {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Mems[dp1]
+ Mems[dp1] = Mems[dp2]
+ Mems[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ }
+ sum = sum + Mems[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ }
+
+ # Recompute the average.
+ if (n1 > 1)
+ a = sum / n1
+ }
+
+ # Save the average if needed.
+ n[i] = n1
+ if (!docombine) {
+ if (n1 > 0)
+ average[i] = a
+ else
+ average[i] = blank
+ }
+ }
+
+ # Check if the data flag has to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_MSIGCLIP -- Reject pixels using sigma clipping about the median
+
+procedure ic_msigclips (d, m, n, scales, zeros, nimages, npts, median)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+real median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep
+real r, s
+pointer sp, resid, w, mp1, mp2
+real med, one
+data one /1.0/
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ # Save the residuals and sigma scaling corrections if needed.
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+ if (doscale1)
+ call salloc (w, nimages, TY_REAL)
+
+ # Compute median and sigma and iteratively clip.
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ nl = 1
+ nh = n1
+
+ repeat {
+ n2 = n1
+ n3 = nl + n1 / 2
+
+ if (n1 == 0)
+ med = blank
+ else if (mod (n1, 2) == 0)
+ med = (Mems[d[n3-1]+k] + Mems[d[n3]+k]) / 2.
+ else
+ med = Mems[d[n3]+k]
+
+ if (n1 >= max (MINCLIP, maxkeep+1)) {
+ if (doscale1) {
+ # Compute the sigma with scaling correction.
+ s = 0.
+ do j = nl, nh {
+ l = Memi[m[j]+k]
+ r = sqrt (max (one, (med + zeros[l]) / scales[l]))
+ s = s + ((Mems[d[j]+k] - med) / r) ** 2
+ Memr[w+j-1] = r
+ }
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels and save the residuals.
+ if (s > 0.) {
+ for (; nl <= n2; nl = nl + 1) {
+ r = (med - Mems[d[nl]+k]) / (s * Memr[w+nl-1])
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ r = (Mems[d[nh]+k] - med) / (s * Memr[w+nh-1])
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+ } else {
+ # Compute the sigma without scaling correction.
+ s = 0.
+ do j = nl, nh
+ s = s + (Mems[d[j]+k] - med) ** 2
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels and save the residuals.
+ if (s > 0.) {
+ for (; nl <= n2; nl = nl + 1) {
+ r = (med - Mems[d[nl]+k]) / s
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ r = (Mems[d[nh]+k] - med) / s
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ # If too many pixels are rejected add some back.
+ # All pixels with equal residuals are added back.
+ while (n1 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n1 = nh - nl + 1
+ }
+
+ # Only set median and reorder if needed
+ n[i] = n1
+ if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ j = max (nl, n1 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Mems[d[l]+k] = Mems[d[j]+k]
+ if (grow >= 1.) {
+ mp1 = m[l] + k
+ mp2 = m[j] + k
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+k] = Memi[m[j]+k]
+ j = j + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Mems[d[l]+k] = Mems[d[j]+k]
+ j = j + 1
+ }
+ }
+ }
+
+ if (combine == MEDIAN)
+ median[i] = med
+ }
+
+ # Check if data flag needs to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag that the median has been computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+
+# IC_ASIGCLIP -- Reject pixels using sigma clipping about the average
+# The initial average rejects the high and low pixels. A correction for
+# different scalings of the images may be made. Weights are not used.
+
+procedure ic_asigclipi (d, m, n, scales, zeros, nimages, npts, average)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+real average[npts] # Average
+
+int i, j, k, l, jj, n1, n2, nin, nk, maxkeep
+real d1, low, high, sum, a, s, r, one
+data one /1.0/
+pointer sp, resid, w, wp, dp1, dp2, mp1, mp2
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ # Flag whether returned average needs to be recomputed.
+ if (dowts || combine != AVERAGE)
+ docombine = true
+ else
+ docombine = false
+
+ # Save the residuals and the sigma scaling corrections if needed.
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+ if (doscale1)
+ call salloc (w, nimages, TY_REAL)
+
+ # Do sigma clipping.
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+
+ # If there are not enough pixels simply compute the average.
+ if (n1 < max (3, maxkeep)) {
+ if (!docombine) {
+ if (n1 == 0)
+ average[i] = blank
+ else {
+ sum = Memi[d[1]+k]
+ do j = 2, n1
+ sum = sum + Memi[d[j]+k]
+ average[i] = sum / n1
+ }
+ }
+ next
+ }
+
+ # Compute average with the high and low rejected.
+ low = Memi[d[1]+k]
+ high = Memi[d[2]+k]
+ if (low > high) {
+ d1 = low
+ low = high
+ high = d1
+ }
+ sum = 0.
+ do j = 3, n1 {
+ d1 = Memi[d[j]+k]
+ if (d1 < low) {
+ sum = sum + low
+ low = d1
+ } else if (d1 > high) {
+ sum = sum + high
+ high = d1
+ } else
+ sum = sum + d1
+ }
+ a = sum / (n1 - 2)
+ sum = sum + low + high
+
+ # Iteratively reject pixels and compute the final average if needed.
+ # Compact the data and keep track of the image IDs if needed.
+
+ repeat {
+ n2 = n1
+ if (doscale1) {
+ # Compute sigma corrected for scaling.
+ s = 0.
+ wp = w - 1
+ do j = 1, n1 {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ wp = wp + 1
+
+ d1 = Memi[dp1]
+ l = Memi[mp1]
+ r = sqrt (max (one, (a + zeros[l]) / scales[l]))
+ s = s + ((d1 - a) / r) ** 2
+ Memr[wp] = r
+ }
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels. Save the residuals and data values.
+ wp = w - 1
+ if (s > 0.) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ wp = wp + 1
+
+ d1 = Memi[dp1]
+ r = (d1 - a) / (s * Memr[wp])
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs (r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memi[dp1] = Memi[dp2]
+ Memi[dp2] = d1
+ Memr[wp] = Memr[w+n1-1]
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ } else {
+ # Compute the sigma without scale correction.
+ s = 0.
+ do j = 1, n1
+ s = s + (Memi[d[j]+k] - a) ** 2
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels. Save the residuals and data values.
+ if (s > 0.) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ d1 = Memi[dp1]
+ r = (d1 - a) / s
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs (r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memi[dp1] = Memi[dp2]
+ Memi[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ }
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ }
+
+ # Recompute the average.
+ if (n1 > 1)
+ a = sum / n1
+ } until (n1 == n2 || n1 <= max (2, maxkeep))
+
+ # If too many pixels are rejected add some back.
+ # All pixels with equal residuals are added back.
+ if (n1 < maxkeep) {
+ nk = maxkeep
+ if (doscale1) {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memi[dp1]
+ Memi[dp1] = Memi[dp2]
+ Memi[dp2] = d1
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ sum = sum + Memi[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ } else {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memi[dp1]
+ Memi[dp1] = Memi[dp2]
+ Memi[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ }
+ sum = sum + Memi[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ }
+
+ # Recompute the average.
+ if (n1 > 1)
+ a = sum / n1
+ }
+
+ # Save the average if needed.
+ n[i] = n1
+ if (!docombine) {
+ if (n1 > 0)
+ average[i] = a
+ else
+ average[i] = blank
+ }
+ }
+
+ # Check if the data flag has to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_MSIGCLIP -- Reject pixels using sigma clipping about the median
+
+procedure ic_msigclipi (d, m, n, scales, zeros, nimages, npts, median)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+real median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep
+real r, s
+pointer sp, resid, w, mp1, mp2
+real med, one
+data one /1.0/
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ # Save the residuals and sigma scaling corrections if needed.
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+ if (doscale1)
+ call salloc (w, nimages, TY_REAL)
+
+ # Compute median and sigma and iteratively clip.
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ nl = 1
+ nh = n1
+
+ repeat {
+ n2 = n1
+ n3 = nl + n1 / 2
+
+ if (n1 == 0)
+ med = blank
+ else if (mod (n1, 2) == 0)
+ med = (Memi[d[n3-1]+k] + Memi[d[n3]+k]) / 2.
+ else
+ med = Memi[d[n3]+k]
+
+ if (n1 >= max (MINCLIP, maxkeep+1)) {
+ if (doscale1) {
+ # Compute the sigma with scaling correction.
+ s = 0.
+ do j = nl, nh {
+ l = Memi[m[j]+k]
+ r = sqrt (max (one, (med + zeros[l]) / scales[l]))
+ s = s + ((Memi[d[j]+k] - med) / r) ** 2
+ Memr[w+j-1] = r
+ }
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels and save the residuals.
+ if (s > 0.) {
+ for (; nl <= n2; nl = nl + 1) {
+ r = (med - Memi[d[nl]+k]) / (s * Memr[w+nl-1])
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ r = (Memi[d[nh]+k] - med) / (s * Memr[w+nh-1])
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+ } else {
+ # Compute the sigma without scaling correction.
+ s = 0.
+ do j = nl, nh
+ s = s + (Memi[d[j]+k] - med) ** 2
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels and save the residuals.
+ if (s > 0.) {
+ for (; nl <= n2; nl = nl + 1) {
+ r = (med - Memi[d[nl]+k]) / s
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ r = (Memi[d[nh]+k] - med) / s
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ # If too many pixels are rejected add some back.
+ # All pixels with equal residuals are added back.
+ while (n1 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n1 = nh - nl + 1
+ }
+
+ # Only set median and reorder if needed
+ n[i] = n1
+ if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ j = max (nl, n1 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Memi[d[l]+k] = Memi[d[j]+k]
+ if (grow >= 1.) {
+ mp1 = m[l] + k
+ mp2 = m[j] + k
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+k] = Memi[m[j]+k]
+ j = j + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Memi[d[l]+k] = Memi[d[j]+k]
+ j = j + 1
+ }
+ }
+ }
+
+ if (combine == MEDIAN)
+ median[i] = med
+ }
+
+ # Check if data flag needs to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag that the median has been computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+
+# IC_ASIGCLIP -- Reject pixels using sigma clipping about the average
+# The initial average rejects the high and low pixels. A correction for
+# different scalings of the images may be made. Weights are not used.
+
+procedure ic_asigclipr (d, m, n, scales, zeros, nimages, npts, average)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+real average[npts] # Average
+
+int i, j, k, l, jj, n1, n2, nin, nk, maxkeep
+real d1, low, high, sum, a, s, r, one
+data one /1.0/
+pointer sp, resid, w, wp, dp1, dp2, mp1, mp2
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ # Flag whether returned average needs to be recomputed.
+ if (dowts || combine != AVERAGE)
+ docombine = true
+ else
+ docombine = false
+
+ # Save the residuals and the sigma scaling corrections if needed.
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+ if (doscale1)
+ call salloc (w, nimages, TY_REAL)
+
+ # Do sigma clipping.
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+
+ # If there are not enough pixels simply compute the average.
+ if (n1 < max (3, maxkeep)) {
+ if (!docombine) {
+ if (n1 == 0)
+ average[i] = blank
+ else {
+ sum = Memr[d[1]+k]
+ do j = 2, n1
+ sum = sum + Memr[d[j]+k]
+ average[i] = sum / n1
+ }
+ }
+ next
+ }
+
+ # Compute average with the high and low rejected.
+ low = Memr[d[1]+k]
+ high = Memr[d[2]+k]
+ if (low > high) {
+ d1 = low
+ low = high
+ high = d1
+ }
+ sum = 0.
+ do j = 3, n1 {
+ d1 = Memr[d[j]+k]
+ if (d1 < low) {
+ sum = sum + low
+ low = d1
+ } else if (d1 > high) {
+ sum = sum + high
+ high = d1
+ } else
+ sum = sum + d1
+ }
+ a = sum / (n1 - 2)
+ sum = sum + low + high
+
+ # Iteratively reject pixels and compute the final average if needed.
+ # Compact the data and keep track of the image IDs if needed.
+
+ repeat {
+ n2 = n1
+ if (doscale1) {
+ # Compute sigma corrected for scaling.
+ s = 0.
+ wp = w - 1
+ do j = 1, n1 {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ wp = wp + 1
+
+ d1 = Memr[dp1]
+ l = Memi[mp1]
+ r = sqrt (max (one, (a + zeros[l]) / scales[l]))
+ s = s + ((d1 - a) / r) ** 2
+ Memr[wp] = r
+ }
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels. Save the residuals and data values.
+ wp = w - 1
+ if (s > 0.) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ wp = wp + 1
+
+ d1 = Memr[dp1]
+ r = (d1 - a) / (s * Memr[wp])
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs (r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memr[dp1] = Memr[dp2]
+ Memr[dp2] = d1
+ Memr[wp] = Memr[w+n1-1]
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ } else {
+ # Compute the sigma without scale correction.
+ s = 0.
+ do j = 1, n1
+ s = s + (Memr[d[j]+k] - a) ** 2
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels. Save the residuals and data values.
+ if (s > 0.) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ d1 = Memr[dp1]
+ r = (d1 - a) / s
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs (r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memr[dp1] = Memr[dp2]
+ Memr[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ }
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ }
+
+ # Recompute the average.
+ if (n1 > 1)
+ a = sum / n1
+ } until (n1 == n2 || n1 <= max (2, maxkeep))
+
+ # If too many pixels are rejected add some back.
+ # All pixels with equal residuals are added back.
+ if (n1 < maxkeep) {
+ nk = maxkeep
+ if (doscale1) {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memr[dp1]
+ Memr[dp1] = Memr[dp2]
+ Memr[dp2] = d1
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ sum = sum + Memr[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ } else {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memr[dp1]
+ Memr[dp1] = Memr[dp2]
+ Memr[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ }
+ sum = sum + Memr[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ }
+
+ # Recompute the average.
+ if (n1 > 1)
+ a = sum / n1
+ }
+
+ # Save the average if needed.
+ n[i] = n1
+ if (!docombine) {
+ if (n1 > 0)
+ average[i] = a
+ else
+ average[i] = blank
+ }
+ }
+
+ # Check if the data flag has to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_MSIGCLIP -- Reject pixels using sigma clipping about the median
+
+procedure ic_msigclipr (d, m, n, scales, zeros, nimages, npts, median)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+real median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep
+real r, s
+pointer sp, resid, w, mp1, mp2
+real med, one
+data one /1.0/
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ # Save the residuals and sigma scaling corrections if needed.
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+ if (doscale1)
+ call salloc (w, nimages, TY_REAL)
+
+ # Compute median and sigma and iteratively clip.
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ nl = 1
+ nh = n1
+
+ repeat {
+ n2 = n1
+ n3 = nl + n1 / 2
+
+ if (n1 == 0)
+ med = blank
+ else if (mod (n1, 2) == 0)
+ med = (Memr[d[n3-1]+k] + Memr[d[n3]+k]) / 2.
+ else
+ med = Memr[d[n3]+k]
+
+ if (n1 >= max (MINCLIP, maxkeep+1)) {
+ if (doscale1) {
+ # Compute the sigma with scaling correction.
+ s = 0.
+ do j = nl, nh {
+ l = Memi[m[j]+k]
+ r = sqrt (max (one, (med + zeros[l]) / scales[l]))
+ s = s + ((Memr[d[j]+k] - med) / r) ** 2
+ Memr[w+j-1] = r
+ }
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels and save the residuals.
+ if (s > 0.) {
+ for (; nl <= n2; nl = nl + 1) {
+ r = (med - Memr[d[nl]+k]) / (s * Memr[w+nl-1])
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ r = (Memr[d[nh]+k] - med) / (s * Memr[w+nh-1])
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+ } else {
+ # Compute the sigma without scaling correction.
+ s = 0.
+ do j = nl, nh
+ s = s + (Memr[d[j]+k] - med) ** 2
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels and save the residuals.
+ if (s > 0.) {
+ for (; nl <= n2; nl = nl + 1) {
+ r = (med - Memr[d[nl]+k]) / s
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ r = (Memr[d[nh]+k] - med) / s
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ # If too many pixels are rejected add some back.
+ # All pixels with equal residuals are added back.
+ while (n1 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n1 = nh - nl + 1
+ }
+
+ # Only set median and reorder if needed
+ n[i] = n1
+ if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ j = max (nl, n1 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Memr[d[l]+k] = Memr[d[j]+k]
+ if (grow >= 1.) {
+ mp1 = m[l] + k
+ mp2 = m[j] + k
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+k] = Memi[m[j]+k]
+ j = j + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Memr[d[l]+k] = Memr[d[j]+k]
+ j = j + 1
+ }
+ }
+ }
+
+ if (combine == MEDIAN)
+ median[i] = med
+ }
+
+ # Check if data flag needs to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag that the median has been computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+
+# IC_ASIGCLIP -- Reject pixels using sigma clipping about the average
+# The initial average rejects the high and low pixels. A correction for
+# different scalings of the images may be made. Weights are not used.
+
+procedure ic_asigclipd (d, m, n, scales, zeros, nimages, npts, average)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+double average[npts] # Average
+
+int i, j, k, l, jj, n1, n2, nin, nk, maxkeep
+double d1, low, high, sum, a, s, r, one
+data one /1.0D0/
+pointer sp, resid, w, wp, dp1, dp2, mp1, mp2
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ # Flag whether returned average needs to be recomputed.
+ if (dowts || combine != AVERAGE)
+ docombine = true
+ else
+ docombine = false
+
+ # Save the residuals and the sigma scaling corrections if needed.
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+ if (doscale1)
+ call salloc (w, nimages, TY_REAL)
+
+ # Do sigma clipping.
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+
+ # If there are not enough pixels simply compute the average.
+ if (n1 < max (3, maxkeep)) {
+ if (!docombine) {
+ if (n1 == 0)
+ average[i] = blank
+ else {
+ sum = Memd[d[1]+k]
+ do j = 2, n1
+ sum = sum + Memd[d[j]+k]
+ average[i] = sum / n1
+ }
+ }
+ next
+ }
+
+ # Compute average with the high and low rejected.
+ low = Memd[d[1]+k]
+ high = Memd[d[2]+k]
+ if (low > high) {
+ d1 = low
+ low = high
+ high = d1
+ }
+ sum = 0.
+ do j = 3, n1 {
+ d1 = Memd[d[j]+k]
+ if (d1 < low) {
+ sum = sum + low
+ low = d1
+ } else if (d1 > high) {
+ sum = sum + high
+ high = d1
+ } else
+ sum = sum + d1
+ }
+ a = sum / (n1 - 2)
+ sum = sum + low + high
+
+ # Iteratively reject pixels and compute the final average if needed.
+ # Compact the data and keep track of the image IDs if needed.
+
+ repeat {
+ n2 = n1
+ if (doscale1) {
+ # Compute sigma corrected for scaling.
+ s = 0.
+ wp = w - 1
+ do j = 1, n1 {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ wp = wp + 1
+
+ d1 = Memd[dp1]
+ l = Memi[mp1]
+ r = sqrt (max (one, (a + zeros[l]) / scales[l]))
+ s = s + ((d1 - a) / r) ** 2
+ Memr[wp] = r
+ }
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels. Save the residuals and data values.
+ wp = w - 1
+ if (s > 0.) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ wp = wp + 1
+
+ d1 = Memd[dp1]
+ r = (d1 - a) / (s * Memr[wp])
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs (r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memd[dp1] = Memd[dp2]
+ Memd[dp2] = d1
+ Memr[wp] = Memr[w+n1-1]
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ } else {
+ # Compute the sigma without scale correction.
+ s = 0.
+ do j = 1, n1
+ s = s + (Memd[d[j]+k] - a) ** 2
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels. Save the residuals and data values.
+ if (s > 0.) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ d1 = Memd[dp1]
+ r = (d1 - a) / s
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs (r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Memd[dp1] = Memd[dp2]
+ Memd[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ }
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ }
+
+ # Recompute the average.
+ if (n1 > 1)
+ a = sum / n1
+ } until (n1 == n2 || n1 <= max (2, maxkeep))
+
+ # If too many pixels are rejected add some back.
+ # All pixels with equal residuals are added back.
+ if (n1 < maxkeep) {
+ nk = maxkeep
+ if (doscale1) {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memd[dp1]
+ Memd[dp1] = Memd[dp2]
+ Memd[dp2] = d1
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ sum = sum + Memd[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ } else {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Memd[dp1]
+ Memd[dp1] = Memd[dp2]
+ Memd[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ }
+ sum = sum + Memd[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ }
+
+ # Recompute the average.
+ if (n1 > 1)
+ a = sum / n1
+ }
+
+ # Save the average if needed.
+ n[i] = n1
+ if (!docombine) {
+ if (n1 > 0)
+ average[i] = a
+ else
+ average[i] = blank
+ }
+ }
+
+ # Check if the data flag has to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_MSIGCLIP -- Reject pixels using sigma clipping about the median
+
+procedure ic_msigclipd (d, m, n, scales, zeros, nimages, npts, median)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+double median[npts] # Median
+
+int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep
+real r, s
+pointer sp, resid, w, mp1, mp2
+double med, one
+data one /1.0D0/
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ # Save the residuals and sigma scaling corrections if needed.
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+ if (doscale1)
+ call salloc (w, nimages, TY_REAL)
+
+ # Compute median and sigma and iteratively clip.
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ nl = 1
+ nh = n1
+
+ repeat {
+ n2 = n1
+ n3 = nl + n1 / 2
+
+ if (n1 == 0)
+ med = blank
+ else if (mod (n1, 2) == 0)
+ med = (Memd[d[n3-1]+k] + Memd[d[n3]+k]) / 2.
+ else
+ med = Memd[d[n3]+k]
+
+ if (n1 >= max (MINCLIP, maxkeep+1)) {
+ if (doscale1) {
+ # Compute the sigma with scaling correction.
+ s = 0.
+ do j = nl, nh {
+ l = Memi[m[j]+k]
+ r = sqrt (max (one, (med + zeros[l]) / scales[l]))
+ s = s + ((Memd[d[j]+k] - med) / r) ** 2
+ Memr[w+j-1] = r
+ }
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels and save the residuals.
+ if (s > 0.) {
+ for (; nl <= n2; nl = nl + 1) {
+ r = (med - Memd[d[nl]+k]) / (s * Memr[w+nl-1])
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ r = (Memd[d[nh]+k] - med) / (s * Memr[w+nh-1])
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+ } else {
+ # Compute the sigma without scaling correction.
+ s = 0.
+ do j = nl, nh
+ s = s + (Memd[d[j]+k] - med) ** 2
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels and save the residuals.
+ if (s > 0.) {
+ for (; nl <= n2; nl = nl + 1) {
+ r = (med - Memd[d[nl]+k]) / s
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ r = (Memd[d[nh]+k] - med) / s
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ # If too many pixels are rejected add some back.
+ # All pixels with equal residuals are added back.
+ while (n1 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n1 = nh - nl + 1
+ }
+
+ # Only set median and reorder if needed
+ n[i] = n1
+ if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ j = max (nl, n1 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Memd[d[l]+k] = Memd[d[j]+k]
+ if (grow >= 1.) {
+ mp1 = m[l] + k
+ mp2 = m[j] + k
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+k] = Memi[m[j]+k]
+ j = j + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Memd[d[l]+k] = Memd[d[j]+k]
+ j = j + 1
+ }
+ }
+ }
+
+ if (combine == MEDIAN)
+ median[i] = med
+ }
+
+ # Check if data flag needs to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag that the median has been computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
diff --git a/pkg/obsolete/imcombine/generic/icsigma.x b/pkg/obsolete/imcombine/generic/icsigma.x
new file mode 100644
index 00000000..faf31602
--- /dev/null
+++ b/pkg/obsolete/imcombine/generic/icsigma.x
@@ -0,0 +1,405 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include "../icombine.h"
+
+
+# IC_SIGMA -- Compute the sigma image line.
+# The estimated sigma includes a correction for the finite population.
+# Weights are used if desired.
+
+procedure ic_sigmas (d, m, n, wts, npts, average, sigma)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image ID pointers
+int n[npts] # Number of points
+real wts[ARB] # Weights
+int npts # Number of output points per line
+real average[npts] # Average
+real sigma[npts] # Sigma line (returned)
+
+int i, j, k, n1
+real wt, sigcor, sumwt
+real a, sum
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ if (dowts) {
+ if (n1 > 1)
+ sigcor = real (n1) / real (n1 - 1)
+ else
+ sigcor = 1.
+ do i = 1, npts {
+ k = i - 1
+ a = average[i]
+ wt = wts[Memi[m[1]+k]]
+ sum = (Mems[d[1]+k] - a) ** 2 * wt
+ do j = 2, n1 {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + (Mems[d[j]+k] - a) ** 2 * wt
+ }
+ sigma[i] = sqrt (sum * sigcor)
+ }
+ } else {
+ if (n1 > 1)
+ sigcor = 1. / real (n1 - 1)
+ else
+ sigcor = 1.
+ do i = 1, npts {
+ k = i - 1
+ a = average[i]
+ sum = (Mems[d[1]+k] - a) ** 2
+ do j = 2, n1
+ sum = sum + (Mems[d[j]+k] - a) ** 2
+ sigma[i] = sqrt (sum * sigcor)
+ }
+ }
+ } else if (dflag == D_NONE) {
+ do i = 1, npts
+ sigma[i] = blank
+ } else {
+ if (dowts) {
+ do i = 1, npts {
+ n1 = n[i]
+ if (n1 > 0) {
+ k = i - 1
+ if (n1 > 1)
+ sigcor = real (n1) / real (n1 -1)
+ else
+ sigcor = 1
+ a = average[i]
+ wt = wts[Memi[m[1]+k]]
+ sum = (Mems[d[1]+k] - a) ** 2 * wt
+ sumwt = wt
+ do j = 2, n1 {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + (Mems[d[j]+k] - a) ** 2 * wt
+ sumwt = sumwt + wt
+ }
+ sigma[i] = sqrt (sum / sumwt * sigcor)
+ } else
+ sigma[i] = blank
+ }
+ } else {
+ do i = 1, npts {
+ n1 = n[i]
+ if (n1 > 0) {
+ k = i - 1
+ if (n1 > 1)
+ sigcor = 1. / real (n1 - 1)
+ else
+ sigcor = 1.
+ a = average[i]
+ sum = (Mems[d[1]+k] - a) ** 2
+ do j = 2, n1
+ sum = sum + (Mems[d[j]+k] - a) ** 2
+ sigma[i] = sqrt (sum * sigcor)
+ } else
+ sigma[i] = blank
+ }
+ }
+ }
+end
+
+# IC_SIGMA -- Compute the sigma image line.
+# The estimated sigma includes a correction for the finite population.
+# Weights are used if desired.
+
+procedure ic_sigmai (d, m, n, wts, npts, average, sigma)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image ID pointers
+int n[npts] # Number of points
+real wts[ARB] # Weights
+int npts # Number of output points per line
+real average[npts] # Average
+real sigma[npts] # Sigma line (returned)
+
+int i, j, k, n1
+real wt, sigcor, sumwt
+real a, sum
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ if (dowts) {
+ if (n1 > 1)
+ sigcor = real (n1) / real (n1 - 1)
+ else
+ sigcor = 1.
+ do i = 1, npts {
+ k = i - 1
+ a = average[i]
+ wt = wts[Memi[m[1]+k]]
+ sum = (Memi[d[1]+k] - a) ** 2 * wt
+ do j = 2, n1 {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + (Memi[d[j]+k] - a) ** 2 * wt
+ }
+ sigma[i] = sqrt (sum * sigcor)
+ }
+ } else {
+ if (n1 > 1)
+ sigcor = 1. / real (n1 - 1)
+ else
+ sigcor = 1.
+ do i = 1, npts {
+ k = i - 1
+ a = average[i]
+ sum = (Memi[d[1]+k] - a) ** 2
+ do j = 2, n1
+ sum = sum + (Memi[d[j]+k] - a) ** 2
+ sigma[i] = sqrt (sum * sigcor)
+ }
+ }
+ } else if (dflag == D_NONE) {
+ do i = 1, npts
+ sigma[i] = blank
+ } else {
+ if (dowts) {
+ do i = 1, npts {
+ n1 = n[i]
+ if (n1 > 0) {
+ k = i - 1
+ if (n1 > 1)
+ sigcor = real (n1) / real (n1 -1)
+ else
+ sigcor = 1
+ a = average[i]
+ wt = wts[Memi[m[1]+k]]
+ sum = (Memi[d[1]+k] - a) ** 2 * wt
+ sumwt = wt
+ do j = 2, n1 {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + (Memi[d[j]+k] - a) ** 2 * wt
+ sumwt = sumwt + wt
+ }
+ sigma[i] = sqrt (sum / sumwt * sigcor)
+ } else
+ sigma[i] = blank
+ }
+ } else {
+ do i = 1, npts {
+ n1 = n[i]
+ if (n1 > 0) {
+ k = i - 1
+ if (n1 > 1)
+ sigcor = 1. / real (n1 - 1)
+ else
+ sigcor = 1.
+ a = average[i]
+ sum = (Memi[d[1]+k] - a) ** 2
+ do j = 2, n1
+ sum = sum + (Memi[d[j]+k] - a) ** 2
+ sigma[i] = sqrt (sum * sigcor)
+ } else
+ sigma[i] = blank
+ }
+ }
+ }
+end
+
+# IC_SIGMA -- Compute the sigma image line.
+# The estimated sigma includes a correction for the finite population.
+# Weights are used if desired.
+
+procedure ic_sigmar (d, m, n, wts, npts, average, sigma)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image ID pointers
+int n[npts] # Number of points
+real wts[ARB] # Weights
+int npts # Number of output points per line
+real average[npts] # Average
+real sigma[npts] # Sigma line (returned)
+
+int i, j, k, n1
+real wt, sigcor, sumwt
+real a, sum
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ if (dowts) {
+ if (n1 > 1)
+ sigcor = real (n1) / real (n1 - 1)
+ else
+ sigcor = 1.
+ do i = 1, npts {
+ k = i - 1
+ a = average[i]
+ wt = wts[Memi[m[1]+k]]
+ sum = (Memr[d[1]+k] - a) ** 2 * wt
+ do j = 2, n1 {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + (Memr[d[j]+k] - a) ** 2 * wt
+ }
+ sigma[i] = sqrt (sum * sigcor)
+ }
+ } else {
+ if (n1 > 1)
+ sigcor = 1. / real (n1 - 1)
+ else
+ sigcor = 1.
+ do i = 1, npts {
+ k = i - 1
+ a = average[i]
+ sum = (Memr[d[1]+k] - a) ** 2
+ do j = 2, n1
+ sum = sum + (Memr[d[j]+k] - a) ** 2
+ sigma[i] = sqrt (sum * sigcor)
+ }
+ }
+ } else if (dflag == D_NONE) {
+ do i = 1, npts
+ sigma[i] = blank
+ } else {
+ if (dowts) {
+ do i = 1, npts {
+ n1 = n[i]
+ if (n1 > 0) {
+ k = i - 1
+ if (n1 > 1)
+ sigcor = real (n1) / real (n1 -1)
+ else
+ sigcor = 1
+ a = average[i]
+ wt = wts[Memi[m[1]+k]]
+ sum = (Memr[d[1]+k] - a) ** 2 * wt
+ sumwt = wt
+ do j = 2, n1 {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + (Memr[d[j]+k] - a) ** 2 * wt
+ sumwt = sumwt + wt
+ }
+ sigma[i] = sqrt (sum / sumwt * sigcor)
+ } else
+ sigma[i] = blank
+ }
+ } else {
+ do i = 1, npts {
+ n1 = n[i]
+ if (n1 > 0) {
+ k = i - 1
+ if (n1 > 1)
+ sigcor = 1. / real (n1 - 1)
+ else
+ sigcor = 1.
+ a = average[i]
+ sum = (Memr[d[1]+k] - a) ** 2
+ do j = 2, n1
+ sum = sum + (Memr[d[j]+k] - a) ** 2
+ sigma[i] = sqrt (sum * sigcor)
+ } else
+ sigma[i] = blank
+ }
+ }
+ }
+end
+
+# IC_SIGMA -- Compute the sigma image line.
+# The estimated sigma includes a correction for the finite population.
+# Weights are used if desired.
+
+procedure ic_sigmad (d, m, n, wts, npts, average, sigma)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image ID pointers
+int n[npts] # Number of points
+real wts[ARB] # Weights
+int npts # Number of output points per line
+double average[npts] # Average
+double sigma[npts] # Sigma line (returned)
+
+int i, j, k, n1
+real wt, sigcor, sumwt
+double a, sum
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ if (dowts) {
+ if (n1 > 1)
+ sigcor = real (n1) / real (n1 - 1)
+ else
+ sigcor = 1.
+ do i = 1, npts {
+ k = i - 1
+ a = average[i]
+ wt = wts[Memi[m[1]+k]]
+ sum = (Memd[d[1]+k] - a) ** 2 * wt
+ do j = 2, n1 {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + (Memd[d[j]+k] - a) ** 2 * wt
+ }
+ sigma[i] = sqrt (sum * sigcor)
+ }
+ } else {
+ if (n1 > 1)
+ sigcor = 1. / real (n1 - 1)
+ else
+ sigcor = 1.
+ do i = 1, npts {
+ k = i - 1
+ a = average[i]
+ sum = (Memd[d[1]+k] - a) ** 2
+ do j = 2, n1
+ sum = sum + (Memd[d[j]+k] - a) ** 2
+ sigma[i] = sqrt (sum * sigcor)
+ }
+ }
+ } else if (dflag == D_NONE) {
+ do i = 1, npts
+ sigma[i] = blank
+ } else {
+ if (dowts) {
+ do i = 1, npts {
+ n1 = n[i]
+ if (n1 > 0) {
+ k = i - 1
+ if (n1 > 1)
+ sigcor = real (n1) / real (n1 -1)
+ else
+ sigcor = 1
+ a = average[i]
+ wt = wts[Memi[m[1]+k]]
+ sum = (Memd[d[1]+k] - a) ** 2 * wt
+ sumwt = wt
+ do j = 2, n1 {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + (Memd[d[j]+k] - a) ** 2 * wt
+ sumwt = sumwt + wt
+ }
+ sigma[i] = sqrt (sum / sumwt * sigcor)
+ } else
+ sigma[i] = blank
+ }
+ } else {
+ do i = 1, npts {
+ n1 = n[i]
+ if (n1 > 0) {
+ k = i - 1
+ if (n1 > 1)
+ sigcor = 1. / real (n1 - 1)
+ else
+ sigcor = 1.
+ a = average[i]
+ sum = (Memd[d[1]+k] - a) ** 2
+ do j = 2, n1
+ sum = sum + (Memd[d[j]+k] - a) ** 2
+ sigma[i] = sqrt (sum * sigcor)
+ } else
+ sigma[i] = blank
+ }
+ }
+ }
+end
diff --git a/pkg/obsolete/imcombine/generic/icsort.x b/pkg/obsolete/imcombine/generic/icsort.x
new file mode 100644
index 00000000..3ec1d27e
--- /dev/null
+++ b/pkg/obsolete/imcombine/generic/icsort.x
@@ -0,0 +1,1096 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+define LOGPTR 32 # log2(maxpts) (4e9)
+
+
+# IC_SORT -- Quicksort. This is based on the VOPS asrt except that
+# the input is an array of pointers to image lines and the sort is done
+# across the image lines at each point along the lines. The number of
+# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3
+# pixels per point are treated specially.
+
+procedure ic_sorts (a, b, nvecs, npts)
+
+pointer a[ARB] # pointer to input vectors
+short b[ARB] # work array
+int nvecs[npts] # number of vectors
+int npts # number of points in vectors
+
+short pivot, temp, temp3
+int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR]
+define swap {temp=$1;$1=$2;$2=temp}
+define copy_ 10
+
+begin
+ do l = 0, npts-1 {
+ npix = nvecs[l+1]
+ if (npix <= 1)
+ next
+
+ do i = 1, npix
+ b[i] = Mems[a[i]+l]
+
+ # Special cases
+ if (npix <= 3) {
+ pivot = b[1]
+ temp = b[2]
+ if (npix == 2) {
+ if (temp < pivot) {
+ b[1] = temp
+ b[2] = pivot
+ } else
+ next
+ } else {
+ temp3 = b[3]
+ if (temp < pivot) { # bac|bca|cba
+ if (temp < temp3) { # bac|bca
+ b[1] = temp
+ if (pivot < temp3) # bac
+ b[2] = pivot
+ else { # bca
+ b[2] = temp3
+ b[3] = pivot
+ }
+ } else { # cba
+ b[1] = temp3
+ b[3] = pivot
+ }
+ } else if (temp3 < temp) { # acb|cab
+ b[3] = temp
+ if (pivot < temp3) # acb
+ b[2] = temp3
+ else { # cab
+ b[1] = temp3
+ b[2] = pivot
+ }
+ } else
+ next
+ }
+ goto copy_
+ }
+
+ # General case
+ do i = 1, npix
+ b[i] = Mems[a[i]+l]
+
+ lv[1] = 1
+ uv[1] = npix
+ p = 1
+
+ while (p > 0) {
+ if (lv[p] >= uv[p]) # only one elem in this subset
+ p = p - 1 # pop stack
+ else {
+ # Dummy do loop to trigger the Fortran optimizer.
+ do p = p, ARB {
+ i = lv[p] - 1
+ j = uv[p]
+
+ # Select as the pivot the element at the center of the
+ # array, to avoid quadratic behavior on an already
+ # sorted array.
+
+ k = (lv[p] + uv[p]) / 2
+ swap (b[j], b[k])
+ pivot = b[j] # pivot line
+
+ while (i < j) {
+ for (i=i+1; b[i] < pivot; i=i+1)
+ ;
+ for (j=j-1; j > i; j=j-1)
+ if (b[j] <= pivot)
+ break
+ if (i < j) # out of order pair
+ swap (b[i], b[j]) # interchange elements
+ }
+
+ j = uv[p] # move pivot to position i
+ swap (b[i], b[j]) # interchange elements
+
+ if (i-lv[p] < uv[p] - i) { # stack so shorter done first
+ lv[p+1] = lv[p]
+ uv[p+1] = i - 1
+ lv[p] = i + 1
+ } else {
+ lv[p+1] = i + 1
+ uv[p+1] = uv[p]
+ uv[p] = i - 1
+ }
+
+ break
+ }
+ p = p + 1 # push onto stack
+ }
+ }
+
+copy_
+ do i = 1, npix
+ Mems[a[i]+l] = b[i]
+ }
+end
+
+
+# IC_2SORT -- Quicksort. This is based on the VOPS asrt except that
+# the input is an array of pointers to image lines and the sort is done
+# across the image lines at each point along the lines. The number of
+# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3
+# pixels per point are treated specially. A second integer set of
+# vectors is sorted.
+
+procedure ic_2sorts (a, b, c, d, nvecs, npts)
+
+pointer a[ARB] # pointer to input vectors
+short b[ARB] # work array
+pointer c[ARB] # pointer to associated integer vectors
+int d[ARB] # work array
+int nvecs[npts] # number of vectors
+int npts # number of points in vectors
+
+short pivot, temp, temp3
+int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp
+define swap {temp=$1;$1=$2;$2=temp}
+define iswap {itemp=$1;$1=$2;$2=itemp}
+define copy_ 10
+
+begin
+ do l = 0, npts-1 {
+ npix = nvecs[l+1]
+ if (npix <= 1)
+ next
+
+ do i = 1, npix {
+ b[i] = Mems[a[i]+l]
+ d[i] = Memi[c[i]+l]
+ }
+
+ # Special cases
+ if (npix <= 3) {
+ pivot = b[1]
+ temp = b[2]
+ if (npix == 2) {
+ if (temp < pivot) {
+ b[1] = temp
+ b[2] = pivot
+ iswap (d[1], d[2])
+ } else
+ next
+ } else {
+ temp3 = b[3]
+ if (temp < pivot) { # bac|bca|cba
+ if (temp < temp3) { # bac|bca
+ b[1] = temp
+ if (pivot < temp3) { # bac
+ b[2] = pivot
+ iswap (d[1], d[2])
+ } else { # bca
+ b[2] = temp3
+ b[3] = pivot
+ itemp = d[2]
+ d[2] = d[3]
+ d[3] = d[1]
+ d[1] = itemp
+ }
+ } else { # cba
+ b[1] = temp3
+ b[3] = pivot
+ iswap (d[1], d[3])
+ }
+ } else if (temp3 < temp) { # acb|cab
+ b[3] = temp
+ if (pivot < temp3) { # acb
+ b[2] = temp3
+ iswap (d[2], d[3])
+ } else { # cab
+ b[1] = temp3
+ b[2] = pivot
+ itemp = d[2]
+ d[2] = d[1]
+ d[1] = d[3]
+ d[3] = itemp
+ }
+ } else
+ next
+ }
+ goto copy_
+ }
+
+ # General case
+ lv[1] = 1
+ uv[1] = npix
+ p = 1
+
+ while (p > 0) {
+ if (lv[p] >= uv[p]) # only one elem in this subset
+ p = p - 1 # pop stack
+ else {
+ # Dummy do loop to trigger the Fortran optimizer.
+ do p = p, ARB {
+ i = lv[p] - 1
+ j = uv[p]
+
+ # Select as the pivot the element at the center of the
+ # array, to avoid quadratic behavior on an already
+ # sorted array.
+
+ k = (lv[p] + uv[p]) / 2
+ swap (b[j], b[k]); swap (d[j], d[k])
+ pivot = b[j] # pivot line
+
+ while (i < j) {
+ for (i=i+1; b[i] < pivot; i=i+1)
+ ;
+ for (j=j-1; j > i; j=j-1)
+ if (b[j] <= pivot)
+ break
+ if (i < j) { # out of order pair
+ swap (b[i], b[j]) # interchange elements
+ swap (d[i], d[j])
+ }
+ }
+
+ j = uv[p] # move pivot to position i
+ swap (b[i], b[j]) # interchange elements
+ swap (d[i], d[j])
+
+ if (i-lv[p] < uv[p] - i) { # stack so shorter done first
+ lv[p+1] = lv[p]
+ uv[p+1] = i - 1
+ lv[p] = i + 1
+ } else {
+ lv[p+1] = i + 1
+ uv[p+1] = uv[p]
+ uv[p] = i - 1
+ }
+
+ break
+ }
+ p = p + 1 # push onto stack
+ }
+ }
+
+copy_
+ do i = 1, npix {
+ Mems[a[i]+l] = b[i]
+ Memi[c[i]+l] = d[i]
+ }
+ }
+end
+
+# IC_SORT -- Quicksort. This is based on the VOPS asrt except that
+# the input is an array of pointers to image lines and the sort is done
+# across the image lines at each point along the lines. The number of
+# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3
+# pixels per point are treated specially.
+
+procedure ic_sorti (a, b, nvecs, npts)
+
+pointer a[ARB] # pointer to input vectors
+int b[ARB] # work array
+int nvecs[npts] # number of vectors
+int npts # number of points in vectors
+
+int pivot, temp, temp3
+int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR]
+define swap {temp=$1;$1=$2;$2=temp}
+define copy_ 10
+
+begin
+ do l = 0, npts-1 {
+ npix = nvecs[l+1]
+ if (npix <= 1)
+ next
+
+ do i = 1, npix
+ b[i] = Memi[a[i]+l]
+
+ # Special cases
+ if (npix <= 3) {
+ pivot = b[1]
+ temp = b[2]
+ if (npix == 2) {
+ if (temp < pivot) {
+ b[1] = temp
+ b[2] = pivot
+ } else
+ next
+ } else {
+ temp3 = b[3]
+ if (temp < pivot) { # bac|bca|cba
+ if (temp < temp3) { # bac|bca
+ b[1] = temp
+ if (pivot < temp3) # bac
+ b[2] = pivot
+ else { # bca
+ b[2] = temp3
+ b[3] = pivot
+ }
+ } else { # cba
+ b[1] = temp3
+ b[3] = pivot
+ }
+ } else if (temp3 < temp) { # acb|cab
+ b[3] = temp
+ if (pivot < temp3) # acb
+ b[2] = temp3
+ else { # cab
+ b[1] = temp3
+ b[2] = pivot
+ }
+ } else
+ next
+ }
+ goto copy_
+ }
+
+ # General case
+ do i = 1, npix
+ b[i] = Memi[a[i]+l]
+
+ lv[1] = 1
+ uv[1] = npix
+ p = 1
+
+ while (p > 0) {
+ if (lv[p] >= uv[p]) # only one elem in this subset
+ p = p - 1 # pop stack
+ else {
+ # Dummy do loop to trigger the Fortran optimizer.
+ do p = p, ARB {
+ i = lv[p] - 1
+ j = uv[p]
+
+ # Select as the pivot the element at the center of the
+ # array, to avoid quadratic behavior on an already
+ # sorted array.
+
+ k = (lv[p] + uv[p]) / 2
+ swap (b[j], b[k])
+ pivot = b[j] # pivot line
+
+ while (i < j) {
+ for (i=i+1; b[i] < pivot; i=i+1)
+ ;
+ for (j=j-1; j > i; j=j-1)
+ if (b[j] <= pivot)
+ break
+ if (i < j) # out of order pair
+ swap (b[i], b[j]) # interchange elements
+ }
+
+ j = uv[p] # move pivot to position i
+ swap (b[i], b[j]) # interchange elements
+
+ if (i-lv[p] < uv[p] - i) { # stack so shorter done first
+ lv[p+1] = lv[p]
+ uv[p+1] = i - 1
+ lv[p] = i + 1
+ } else {
+ lv[p+1] = i + 1
+ uv[p+1] = uv[p]
+ uv[p] = i - 1
+ }
+
+ break
+ }
+ p = p + 1 # push onto stack
+ }
+ }
+
+copy_
+ do i = 1, npix
+ Memi[a[i]+l] = b[i]
+ }
+end
+
+
+# IC_2SORT -- Quicksort. This is based on the VOPS asrt except that
+# the input is an array of pointers to image lines and the sort is done
+# across the image lines at each point along the lines. The number of
+# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3
+# pixels per point are treated specially. A second integer set of
+# vectors is sorted.
+
+procedure ic_2sorti (a, b, c, d, nvecs, npts)
+
+pointer a[ARB] # pointer to input vectors
+int b[ARB] # work array
+pointer c[ARB] # pointer to associated integer vectors
+int d[ARB] # work array
+int nvecs[npts] # number of vectors
+int npts # number of points in vectors
+
+int pivot, temp, temp3
+int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp
+define swap {temp=$1;$1=$2;$2=temp}
+define iswap {itemp=$1;$1=$2;$2=itemp}
+define copy_ 10
+
+begin
+ do l = 0, npts-1 {
+ npix = nvecs[l+1]
+ if (npix <= 1)
+ next
+
+ do i = 1, npix {
+ b[i] = Memi[a[i]+l]
+ d[i] = Memi[c[i]+l]
+ }
+
+ # Special cases
+ if (npix <= 3) {
+ pivot = b[1]
+ temp = b[2]
+ if (npix == 2) {
+ if (temp < pivot) {
+ b[1] = temp
+ b[2] = pivot
+ iswap (d[1], d[2])
+ } else
+ next
+ } else {
+ temp3 = b[3]
+ if (temp < pivot) { # bac|bca|cba
+ if (temp < temp3) { # bac|bca
+ b[1] = temp
+ if (pivot < temp3) { # bac
+ b[2] = pivot
+ iswap (d[1], d[2])
+ } else { # bca
+ b[2] = temp3
+ b[3] = pivot
+ itemp = d[2]
+ d[2] = d[3]
+ d[3] = d[1]
+ d[1] = itemp
+ }
+ } else { # cba
+ b[1] = temp3
+ b[3] = pivot
+ iswap (d[1], d[3])
+ }
+ } else if (temp3 < temp) { # acb|cab
+ b[3] = temp
+ if (pivot < temp3) { # acb
+ b[2] = temp3
+ iswap (d[2], d[3])
+ } else { # cab
+ b[1] = temp3
+ b[2] = pivot
+ itemp = d[2]
+ d[2] = d[1]
+ d[1] = d[3]
+ d[3] = itemp
+ }
+ } else
+ next
+ }
+ goto copy_
+ }
+
+ # General case
+ lv[1] = 1
+ uv[1] = npix
+ p = 1
+
+ while (p > 0) {
+ if (lv[p] >= uv[p]) # only one elem in this subset
+ p = p - 1 # pop stack
+ else {
+ # Dummy do loop to trigger the Fortran optimizer.
+ do p = p, ARB {
+ i = lv[p] - 1
+ j = uv[p]
+
+ # Select as the pivot the element at the center of the
+ # array, to avoid quadratic behavior on an already
+ # sorted array.
+
+ k = (lv[p] + uv[p]) / 2
+ swap (b[j], b[k]); swap (d[j], d[k])
+ pivot = b[j] # pivot line
+
+ while (i < j) {
+ for (i=i+1; b[i] < pivot; i=i+1)
+ ;
+ for (j=j-1; j > i; j=j-1)
+ if (b[j] <= pivot)
+ break
+ if (i < j) { # out of order pair
+ swap (b[i], b[j]) # interchange elements
+ swap (d[i], d[j])
+ }
+ }
+
+ j = uv[p] # move pivot to position i
+ swap (b[i], b[j]) # interchange elements
+ swap (d[i], d[j])
+
+ if (i-lv[p] < uv[p] - i) { # stack so shorter done first
+ lv[p+1] = lv[p]
+ uv[p+1] = i - 1
+ lv[p] = i + 1
+ } else {
+ lv[p+1] = i + 1
+ uv[p+1] = uv[p]
+ uv[p] = i - 1
+ }
+
+ break
+ }
+ p = p + 1 # push onto stack
+ }
+ }
+
+copy_
+ do i = 1, npix {
+ Memi[a[i]+l] = b[i]
+ Memi[c[i]+l] = d[i]
+ }
+ }
+end
+
+# IC_SORT -- Quicksort. This is based on the VOPS asrt except that
+# the input is an array of pointers to image lines and the sort is done
+# across the image lines at each point along the lines. The number of
+# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3
+# pixels per point are treated specially.
+
+procedure ic_sortr (a, b, nvecs, npts)
+
+pointer a[ARB] # pointer to input vectors
+real b[ARB] # work array
+int nvecs[npts] # number of vectors
+int npts # number of points in vectors
+
+real pivot, temp, temp3
+int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR]
+define swap {temp=$1;$1=$2;$2=temp}
+define copy_ 10
+
+begin
+ do l = 0, npts-1 {
+ npix = nvecs[l+1]
+ if (npix <= 1)
+ next
+
+ do i = 1, npix
+ b[i] = Memr[a[i]+l]
+
+ # Special cases
+ if (npix <= 3) {
+ pivot = b[1]
+ temp = b[2]
+ if (npix == 2) {
+ if (temp < pivot) {
+ b[1] = temp
+ b[2] = pivot
+ } else
+ next
+ } else {
+ temp3 = b[3]
+ if (temp < pivot) { # bac|bca|cba
+ if (temp < temp3) { # bac|bca
+ b[1] = temp
+ if (pivot < temp3) # bac
+ b[2] = pivot
+ else { # bca
+ b[2] = temp3
+ b[3] = pivot
+ }
+ } else { # cba
+ b[1] = temp3
+ b[3] = pivot
+ }
+ } else if (temp3 < temp) { # acb|cab
+ b[3] = temp
+ if (pivot < temp3) # acb
+ b[2] = temp3
+ else { # cab
+ b[1] = temp3
+ b[2] = pivot
+ }
+ } else
+ next
+ }
+ goto copy_
+ }
+
+ # General case
+ do i = 1, npix
+ b[i] = Memr[a[i]+l]
+
+ lv[1] = 1
+ uv[1] = npix
+ p = 1
+
+ while (p > 0) {
+ if (lv[p] >= uv[p]) # only one elem in this subset
+ p = p - 1 # pop stack
+ else {
+ # Dummy do loop to trigger the Fortran optimizer.
+ do p = p, ARB {
+ i = lv[p] - 1
+ j = uv[p]
+
+ # Select as the pivot the element at the center of the
+ # array, to avoid quadratic behavior on an already
+ # sorted array.
+
+ k = (lv[p] + uv[p]) / 2
+ swap (b[j], b[k])
+ pivot = b[j] # pivot line
+
+ while (i < j) {
+ for (i=i+1; b[i] < pivot; i=i+1)
+ ;
+ for (j=j-1; j > i; j=j-1)
+ if (b[j] <= pivot)
+ break
+ if (i < j) # out of order pair
+ swap (b[i], b[j]) # interchange elements
+ }
+
+ j = uv[p] # move pivot to position i
+ swap (b[i], b[j]) # interchange elements
+
+ if (i-lv[p] < uv[p] - i) { # stack so shorter done first
+ lv[p+1] = lv[p]
+ uv[p+1] = i - 1
+ lv[p] = i + 1
+ } else {
+ lv[p+1] = i + 1
+ uv[p+1] = uv[p]
+ uv[p] = i - 1
+ }
+
+ break
+ }
+ p = p + 1 # push onto stack
+ }
+ }
+
+copy_
+ do i = 1, npix
+ Memr[a[i]+l] = b[i]
+ }
+end
+
+
+# IC_2SORT -- Quicksort. This is based on the VOPS asrt except that
+# the input is an array of pointers to image lines and the sort is done
+# across the image lines at each point along the lines. The number of
+# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3
+# pixels per point are treated specially. A second integer set of
+# vectors is sorted.
+
+procedure ic_2sortr (a, b, c, d, nvecs, npts)
+
+pointer a[ARB] # pointer to input vectors
+real b[ARB] # work array
+pointer c[ARB] # pointer to associated integer vectors
+int d[ARB] # work array
+int nvecs[npts] # number of vectors
+int npts # number of points in vectors
+
+real pivot, temp, temp3
+int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp
+define swap {temp=$1;$1=$2;$2=temp}
+define iswap {itemp=$1;$1=$2;$2=itemp}
+define copy_ 10
+
+begin
+ do l = 0, npts-1 {
+ npix = nvecs[l+1]
+ if (npix <= 1)
+ next
+
+ do i = 1, npix {
+ b[i] = Memr[a[i]+l]
+ d[i] = Memi[c[i]+l]
+ }
+
+ # Special cases
+ if (npix <= 3) {
+ pivot = b[1]
+ temp = b[2]
+ if (npix == 2) {
+ if (temp < pivot) {
+ b[1] = temp
+ b[2] = pivot
+ iswap (d[1], d[2])
+ } else
+ next
+ } else {
+ temp3 = b[3]
+ if (temp < pivot) { # bac|bca|cba
+ if (temp < temp3) { # bac|bca
+ b[1] = temp
+ if (pivot < temp3) { # bac
+ b[2] = pivot
+ iswap (d[1], d[2])
+ } else { # bca
+ b[2] = temp3
+ b[3] = pivot
+ itemp = d[2]
+ d[2] = d[3]
+ d[3] = d[1]
+ d[1] = itemp
+ }
+ } else { # cba
+ b[1] = temp3
+ b[3] = pivot
+ iswap (d[1], d[3])
+ }
+ } else if (temp3 < temp) { # acb|cab
+ b[3] = temp
+ if (pivot < temp3) { # acb
+ b[2] = temp3
+ iswap (d[2], d[3])
+ } else { # cab
+ b[1] = temp3
+ b[2] = pivot
+ itemp = d[2]
+ d[2] = d[1]
+ d[1] = d[3]
+ d[3] = itemp
+ }
+ } else
+ next
+ }
+ goto copy_
+ }
+
+ # General case
+ lv[1] = 1
+ uv[1] = npix
+ p = 1
+
+ while (p > 0) {
+ if (lv[p] >= uv[p]) # only one elem in this subset
+ p = p - 1 # pop stack
+ else {
+ # Dummy do loop to trigger the Fortran optimizer.
+ do p = p, ARB {
+ i = lv[p] - 1
+ j = uv[p]
+
+ # Select as the pivot the element at the center of the
+ # array, to avoid quadratic behavior on an already
+ # sorted array.
+
+ k = (lv[p] + uv[p]) / 2
+ swap (b[j], b[k]); swap (d[j], d[k])
+ pivot = b[j] # pivot line
+
+ while (i < j) {
+ for (i=i+1; b[i] < pivot; i=i+1)
+ ;
+ for (j=j-1; j > i; j=j-1)
+ if (b[j] <= pivot)
+ break
+ if (i < j) { # out of order pair
+ swap (b[i], b[j]) # interchange elements
+ swap (d[i], d[j])
+ }
+ }
+
+ j = uv[p] # move pivot to position i
+ swap (b[i], b[j]) # interchange elements
+ swap (d[i], d[j])
+
+ if (i-lv[p] < uv[p] - i) { # stack so shorter done first
+ lv[p+1] = lv[p]
+ uv[p+1] = i - 1
+ lv[p] = i + 1
+ } else {
+ lv[p+1] = i + 1
+ uv[p+1] = uv[p]
+ uv[p] = i - 1
+ }
+
+ break
+ }
+ p = p + 1 # push onto stack
+ }
+ }
+
+copy_
+ do i = 1, npix {
+ Memr[a[i]+l] = b[i]
+ Memi[c[i]+l] = d[i]
+ }
+ }
+end
+
+# IC_SORT -- Quicksort. This is based on the VOPS asrt except that
+# the input is an array of pointers to image lines and the sort is done
+# across the image lines at each point along the lines. The number of
+# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3
+# pixels per point are treated specially.
+
+procedure ic_sortd (a, b, nvecs, npts)
+
+pointer a[ARB] # pointer to input vectors
+double b[ARB] # work array
+int nvecs[npts] # number of vectors
+int npts # number of points in vectors
+
+double pivot, temp, temp3
+int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR]
+define swap {temp=$1;$1=$2;$2=temp}
+define copy_ 10
+
+begin
+ do l = 0, npts-1 {
+ npix = nvecs[l+1]
+ if (npix <= 1)
+ next
+
+ do i = 1, npix
+ b[i] = Memd[a[i]+l]
+
+ # Special cases
+ if (npix <= 3) {
+ pivot = b[1]
+ temp = b[2]
+ if (npix == 2) {
+ if (temp < pivot) {
+ b[1] = temp
+ b[2] = pivot
+ } else
+ next
+ } else {
+ temp3 = b[3]
+ if (temp < pivot) { # bac|bca|cba
+ if (temp < temp3) { # bac|bca
+ b[1] = temp
+ if (pivot < temp3) # bac
+ b[2] = pivot
+ else { # bca
+ b[2] = temp3
+ b[3] = pivot
+ }
+ } else { # cba
+ b[1] = temp3
+ b[3] = pivot
+ }
+ } else if (temp3 < temp) { # acb|cab
+ b[3] = temp
+ if (pivot < temp3) # acb
+ b[2] = temp3
+ else { # cab
+ b[1] = temp3
+ b[2] = pivot
+ }
+ } else
+ next
+ }
+ goto copy_
+ }
+
+ # General case
+ do i = 1, npix
+ b[i] = Memd[a[i]+l]
+
+ lv[1] = 1
+ uv[1] = npix
+ p = 1
+
+ while (p > 0) {
+ if (lv[p] >= uv[p]) # only one elem in this subset
+ p = p - 1 # pop stack
+ else {
+ # Dummy do loop to trigger the Fortran optimizer.
+ do p = p, ARB {
+ i = lv[p] - 1
+ j = uv[p]
+
+ # Select as the pivot the element at the center of the
+ # array, to avoid quadratic behavior on an already
+ # sorted array.
+
+ k = (lv[p] + uv[p]) / 2
+ swap (b[j], b[k])
+ pivot = b[j] # pivot line
+
+ while (i < j) {
+ for (i=i+1; b[i] < pivot; i=i+1)
+ ;
+ for (j=j-1; j > i; j=j-1)
+ if (b[j] <= pivot)
+ break
+ if (i < j) # out of order pair
+ swap (b[i], b[j]) # interchange elements
+ }
+
+ j = uv[p] # move pivot to position i
+ swap (b[i], b[j]) # interchange elements
+
+ if (i-lv[p] < uv[p] - i) { # stack so shorter done first
+ lv[p+1] = lv[p]
+ uv[p+1] = i - 1
+ lv[p] = i + 1
+ } else {
+ lv[p+1] = i + 1
+ uv[p+1] = uv[p]
+ uv[p] = i - 1
+ }
+
+ break
+ }
+ p = p + 1 # push onto stack
+ }
+ }
+
+copy_
+ do i = 1, npix
+ Memd[a[i]+l] = b[i]
+ }
+end
+
+
+# IC_2SORT -- Quicksort. This is based on the VOPS asrt except that
+# the input is an array of pointers to image lines and the sort is done
+# across the image lines at each point along the lines. The number of
+# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3
+# pixels per point are treated specially. A second integer set of
+# vectors is sorted.
+
+procedure ic_2sortd (a, b, c, d, nvecs, npts)
+
+pointer a[ARB] # pointer to input vectors
+double b[ARB] # work array
+pointer c[ARB] # pointer to associated integer vectors
+int d[ARB] # work array
+int nvecs[npts] # number of vectors
+int npts # number of points in vectors
+
+double pivot, temp, temp3
+int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp
+define swap {temp=$1;$1=$2;$2=temp}
+define iswap {itemp=$1;$1=$2;$2=itemp}
+define copy_ 10
+
+begin
+ do l = 0, npts-1 {
+ npix = nvecs[l+1]
+ if (npix <= 1)
+ next
+
+ do i = 1, npix {
+ b[i] = Memd[a[i]+l]
+ d[i] = Memi[c[i]+l]
+ }
+
+ # Special cases
+ if (npix <= 3) {
+ pivot = b[1]
+ temp = b[2]
+ if (npix == 2) {
+ if (temp < pivot) {
+ b[1] = temp
+ b[2] = pivot
+ iswap (d[1], d[2])
+ } else
+ next
+ } else {
+ temp3 = b[3]
+ if (temp < pivot) { # bac|bca|cba
+ if (temp < temp3) { # bac|bca
+ b[1] = temp
+ if (pivot < temp3) { # bac
+ b[2] = pivot
+ iswap (d[1], d[2])
+ } else { # bca
+ b[2] = temp3
+ b[3] = pivot
+ itemp = d[2]
+ d[2] = d[3]
+ d[3] = d[1]
+ d[1] = itemp
+ }
+ } else { # cba
+ b[1] = temp3
+ b[3] = pivot
+ iswap (d[1], d[3])
+ }
+ } else if (temp3 < temp) { # acb|cab
+ b[3] = temp
+ if (pivot < temp3) { # acb
+ b[2] = temp3
+ iswap (d[2], d[3])
+ } else { # cab
+ b[1] = temp3
+ b[2] = pivot
+ itemp = d[2]
+ d[2] = d[1]
+ d[1] = d[3]
+ d[3] = itemp
+ }
+ } else
+ next
+ }
+ goto copy_
+ }
+
+ # General case
+ lv[1] = 1
+ uv[1] = npix
+ p = 1
+
+ while (p > 0) {
+ if (lv[p] >= uv[p]) # only one elem in this subset
+ p = p - 1 # pop stack
+ else {
+ # Dummy do loop to trigger the Fortran optimizer.
+ do p = p, ARB {
+ i = lv[p] - 1
+ j = uv[p]
+
+ # Select as the pivot the element at the center of the
+ # array, to avoid quadratic behavior on an already
+ # sorted array.
+
+ k = (lv[p] + uv[p]) / 2
+ swap (b[j], b[k]); swap (d[j], d[k])
+ pivot = b[j] # pivot line
+
+ while (i < j) {
+ for (i=i+1; b[i] < pivot; i=i+1)
+ ;
+ for (j=j-1; j > i; j=j-1)
+ if (b[j] <= pivot)
+ break
+ if (i < j) { # out of order pair
+ swap (b[i], b[j]) # interchange elements
+ swap (d[i], d[j])
+ }
+ }
+
+ j = uv[p] # move pivot to position i
+ swap (b[i], b[j]) # interchange elements
+ swap (d[i], d[j])
+
+ if (i-lv[p] < uv[p] - i) { # stack so shorter done first
+ lv[p+1] = lv[p]
+ uv[p+1] = i - 1
+ lv[p] = i + 1
+ } else {
+ lv[p+1] = i + 1
+ uv[p+1] = uv[p]
+ uv[p] = i - 1
+ }
+
+ break
+ }
+ p = p + 1 # push onto stack
+ }
+ }
+
+copy_
+ do i = 1, npix {
+ Memd[a[i]+l] = b[i]
+ Memi[c[i]+l] = d[i]
+ }
+ }
+end
diff --git a/pkg/obsolete/imcombine/generic/icstat.x b/pkg/obsolete/imcombine/generic/icstat.x
new file mode 100644
index 00000000..433f1df5
--- /dev/null
+++ b/pkg/obsolete/imcombine/generic/icstat.x
@@ -0,0 +1,880 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include "../icombine.h"
+
+define NMAX 10000 # Maximum number of pixels to sample
+
+
+# IC_STAT -- Compute image statistics within specified section.
+# The image section is relative to a reference image which may be
+# different than the input image and may have an offset. Only a
+# subsample of pixels is used. Masked and thresholded pixels are
+# ignored. Only the desired statistics are computed to increase
+# efficiency.
+
+procedure ic_stats (im, imref, section, offsets, image, nimages,
+ domode, domedian, domean, mode, median, mean)
+
+pointer im # Data image
+pointer imref # Reference image for image section
+char section[ARB] # Image section
+int offsets[nimages,ARB] # Image section offset from data to reference
+int image # Image index (for mask I/O)
+int nimages # Number of images in offsets.
+bool domode, domedian, domean # Statistics to compute
+real mode, median, mean # Statistics
+
+int i, j, ndim, n, nv
+real a
+pointer sp, v1, v2, dv, va, vb
+pointer data, mask, dp, lp, mp, imgnls()
+short ic_modes()
+real asums()
+
+
+include "../icombine.com"
+
+begin
+ call smark (sp)
+ call salloc (v1, IM_MAXDIM, TY_LONG)
+ call salloc (v2, IM_MAXDIM, TY_LONG)
+ call salloc (dv, IM_MAXDIM, TY_LONG)
+ call salloc (va, IM_MAXDIM, TY_LONG)
+ call salloc (vb, IM_MAXDIM, TY_LONG)
+
+ # Determine the image section parameters. This must be in terms of
+ # the data image pixel coordinates though the section may be specified
+ # in terms of the reference image coordinates. Limit the number of
+ # pixels in each dimension to a maximum.
+
+ ndim = IM_NDIM(im)
+ if (project)
+ ndim = ndim - 1
+ call amovki (1, Memi[v1], IM_MAXDIM)
+ call amovki (1, Memi[va], IM_MAXDIM)
+ call amovki (1, Memi[dv], IM_MAXDIM)
+ call amovi (IM_LEN(imref,1), Memi[vb], ndim)
+ call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim)
+ if (im != imref)
+ do i = 1, ndim {
+ Memi[va+i-1] = Memi[va+i-1] - offsets[image,i]
+ Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i]
+ }
+
+ do j = 1, 10 {
+ n = 1
+ do i = 0, ndim-1 {
+ Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i]))
+ Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i]))
+ Memi[dv+i] = j
+ nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1)
+ Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i]
+ n = n * nv
+ }
+ if (n < NMAX)
+ break
+ }
+
+ call amovl (Memi[v1], Memi[va], IM_MAXDIM)
+ Memi[va] = 1
+ if (project)
+ Memi[va+ndim] = image
+ call amovl (Memi[va], Memi[vb], IM_MAXDIM)
+
+ # Accumulate the pixel values within the section. Masked pixels and
+ # thresholded pixels are ignored.
+
+ call salloc (data, n, TY_SHORT)
+ dp = data
+ while (imgnls (im, lp, Memi[vb]) != EOF) {
+ call ic_mget1 (im, image, offsets[image,1], Memi[va], mask)
+ lp = lp + Memi[v1] - 1
+ if (dflag == D_ALL) {
+ if (dothresh) {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ a = Mems[lp]
+ if (a >= lthresh && a <= hthresh) {
+ Mems[dp] = a
+ dp = dp + 1
+ }
+ lp = lp + Memi[dv]
+ }
+ } else {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ Mems[dp] = Mems[lp]
+ dp = dp + 1
+ lp = lp + Memi[dv]
+ }
+ }
+ } else if (dflag == D_MIX) {
+ mp = mask + Memi[v1] - 1
+ if (dothresh) {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ if (Memi[mp] == 0) {
+ a = Mems[lp]
+ if (a >= lthresh && a <= hthresh) {
+ Mems[dp] = a
+ dp = dp + 1
+ }
+ }
+ mp = mp + Memi[dv]
+ lp = lp + Memi[dv]
+ }
+ } else {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ if (Memi[mp] == 0) {
+ Mems[dp] = Mems[lp]
+ dp = dp + 1
+ }
+ mp = mp + Memi[dv]
+ lp = lp + Memi[dv]
+ }
+ }
+ }
+ for (i=2; i<=ndim; i=i+1) {
+ Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1]
+ if (Memi[va+i-1] <= Memi[v2+i-1])
+ break
+ Memi[va+i-1] = Memi[v1+i-1]
+ }
+ if (i > ndim)
+ break
+ call amovl (Memi[va], Memi[vb], IM_MAXDIM)
+ }
+
+ n = dp - data
+ if (n < 1) {
+ call sfree (sp)
+ call error (1, "Image section contains no pixels")
+ }
+
+ # Compute only statistics needed.
+ if (domode || domedian) {
+ call asrts (Mems[data], Mems[data], n)
+ mode = ic_modes (Mems[data], n)
+ median = Mems[data+n/2-1]
+ }
+ if (domean)
+ mean = asums (Mems[data], n) / n
+
+ call sfree (sp)
+end
+
+
+define NMIN 10 # Minimum number of pixels for mode calculation
+define ZRANGE 0.8 # Fraction of pixels about median to use
+define ZSTEP 0.01 # Step size for search for mode
+define ZBIN 0.1 # Bin size for mode.
+
+# IC_MODE -- Compute mode of an array. The mode is found by binning
+# with a bin size based on the data range over a fraction of the
+# pixels about the median and a bin step which may be smaller than the
+# bin size. If there are too few points the median is returned.
+# The input array must be sorted.
+
+short procedure ic_modes (a, n)
+
+short a[n] # Data array
+int n # Number of points
+
+int i, j, k, nmax
+real z1, z2, zstep, zbin
+short mode
+bool fp_equalr()
+
+begin
+ if (n < NMIN)
+ return (a[n/2])
+
+ # Compute the mode. The array must be sorted. Consider a
+ # range of values about the median point. Use a bin size which
+ # is ZBIN of the range. Step the bin limits in ZSTEP fraction of
+ # the bin size.
+
+ i = 1 + n * (1. - ZRANGE) / 2.
+ j = 1 + n * (1. + ZRANGE) / 2.
+ z1 = a[i]
+ z2 = a[j]
+ if (fp_equalr (z1, z2)) {
+ mode = z1
+ return (mode)
+ }
+
+ zstep = ZSTEP * (z2 - z1)
+ zbin = ZBIN * (z2 - z1)
+ zstep = max (1., zstep)
+ zbin = max (1., zbin)
+
+ z1 = z1 - zstep
+ k = i
+ nmax = 0
+ repeat {
+ z1 = z1 + zstep
+ z2 = z1 + zbin
+ for (; i < j && a[i] < z1; i=i+1)
+ ;
+ for (; k < j && a[k] < z2; k=k+1)
+ ;
+ if (k - i > nmax) {
+ nmax = k - i
+ mode = a[(i+k)/2]
+ }
+ } until (k >= j)
+
+ return (mode)
+end
+
+# IC_STAT -- Compute image statistics within specified section.
+# The image section is relative to a reference image which may be
+# different than the input image and may have an offset. Only a
+# subsample of pixels is used. Masked and thresholded pixels are
+# ignored. Only the desired statistics are computed to increase
+# efficiency.
+
+procedure ic_stati (im, imref, section, offsets, image, nimages,
+ domode, domedian, domean, mode, median, mean)
+
+pointer im # Data image
+pointer imref # Reference image for image section
+char section[ARB] # Image section
+int offsets[nimages,ARB] # Image section offset from data to reference
+int image # Image index (for mask I/O)
+int nimages # Number of images in offsets.
+bool domode, domedian, domean # Statistics to compute
+real mode, median, mean # Statistics
+
+int i, j, ndim, n, nv
+real a
+pointer sp, v1, v2, dv, va, vb
+pointer data, mask, dp, lp, mp, imgnli()
+int ic_modei()
+real asumi()
+
+
+include "../icombine.com"
+
+begin
+ call smark (sp)
+ call salloc (v1, IM_MAXDIM, TY_LONG)
+ call salloc (v2, IM_MAXDIM, TY_LONG)
+ call salloc (dv, IM_MAXDIM, TY_LONG)
+ call salloc (va, IM_MAXDIM, TY_LONG)
+ call salloc (vb, IM_MAXDIM, TY_LONG)
+
+ # Determine the image section parameters. This must be in terms of
+ # the data image pixel coordinates though the section may be specified
+ # in terms of the reference image coordinates. Limit the number of
+ # pixels in each dimension to a maximum.
+
+ ndim = IM_NDIM(im)
+ if (project)
+ ndim = ndim - 1
+ call amovki (1, Memi[v1], IM_MAXDIM)
+ call amovki (1, Memi[va], IM_MAXDIM)
+ call amovki (1, Memi[dv], IM_MAXDIM)
+ call amovi (IM_LEN(imref,1), Memi[vb], ndim)
+ call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim)
+ if (im != imref)
+ do i = 1, ndim {
+ Memi[va+i-1] = Memi[va+i-1] - offsets[image,i]
+ Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i]
+ }
+
+ do j = 1, 10 {
+ n = 1
+ do i = 0, ndim-1 {
+ Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i]))
+ Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i]))
+ Memi[dv+i] = j
+ nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1)
+ Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i]
+ n = n * nv
+ }
+ if (n < NMAX)
+ break
+ }
+
+ call amovl (Memi[v1], Memi[va], IM_MAXDIM)
+ Memi[va] = 1
+ if (project)
+ Memi[va+ndim] = image
+ call amovl (Memi[va], Memi[vb], IM_MAXDIM)
+
+ # Accumulate the pixel values within the section. Masked pixels and
+ # thresholded pixels are ignored.
+
+ call salloc (data, n, TY_INT)
+ dp = data
+ while (imgnli (im, lp, Memi[vb]) != EOF) {
+ call ic_mget1 (im, image, offsets[image,1], Memi[va], mask)
+ lp = lp + Memi[v1] - 1
+ if (dflag == D_ALL) {
+ if (dothresh) {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ a = Memi[lp]
+ if (a >= lthresh && a <= hthresh) {
+ Memi[dp] = a
+ dp = dp + 1
+ }
+ lp = lp + Memi[dv]
+ }
+ } else {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ Memi[dp] = Memi[lp]
+ dp = dp + 1
+ lp = lp + Memi[dv]
+ }
+ }
+ } else if (dflag == D_MIX) {
+ mp = mask + Memi[v1] - 1
+ if (dothresh) {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ if (Memi[mp] == 0) {
+ a = Memi[lp]
+ if (a >= lthresh && a <= hthresh) {
+ Memi[dp] = a
+ dp = dp + 1
+ }
+ }
+ mp = mp + Memi[dv]
+ lp = lp + Memi[dv]
+ }
+ } else {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ if (Memi[mp] == 0) {
+ Memi[dp] = Memi[lp]
+ dp = dp + 1
+ }
+ mp = mp + Memi[dv]
+ lp = lp + Memi[dv]
+ }
+ }
+ }
+ for (i=2; i<=ndim; i=i+1) {
+ Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1]
+ if (Memi[va+i-1] <= Memi[v2+i-1])
+ break
+ Memi[va+i-1] = Memi[v1+i-1]
+ }
+ if (i > ndim)
+ break
+ call amovl (Memi[va], Memi[vb], IM_MAXDIM)
+ }
+
+ n = dp - data
+ if (n < 1) {
+ call sfree (sp)
+ call error (1, "Image section contains no pixels")
+ }
+
+ # Compute only statistics needed.
+ if (domode || domedian) {
+ call asrti (Memi[data], Memi[data], n)
+ mode = ic_modei (Memi[data], n)
+ median = Memi[data+n/2-1]
+ }
+ if (domean)
+ mean = asumi (Memi[data], n) / n
+
+ call sfree (sp)
+end
+
+
+define NMIN 10 # Minimum number of pixels for mode calculation
+define ZRANGE 0.8 # Fraction of pixels about median to use
+define ZSTEP 0.01 # Step size for search for mode
+define ZBIN 0.1 # Bin size for mode.
+
+# IC_MODE -- Compute mode of an array. The mode is found by binning
+# with a bin size based on the data range over a fraction of the
+# pixels about the median and a bin step which may be smaller than the
+# bin size. If there are too few points the median is returned.
+# The input array must be sorted.
+
+int procedure ic_modei (a, n)
+
+int a[n] # Data array
+int n # Number of points
+
+int i, j, k, nmax
+real z1, z2, zstep, zbin
+int mode
+bool fp_equalr()
+
+begin
+ if (n < NMIN)
+ return (a[n/2])
+
+ # Compute the mode. The array must be sorted. Consider a
+ # range of values about the median point. Use a bin size which
+ # is ZBIN of the range. Step the bin limits in ZSTEP fraction of
+ # the bin size.
+
+ i = 1 + n * (1. - ZRANGE) / 2.
+ j = 1 + n * (1. + ZRANGE) / 2.
+ z1 = a[i]
+ z2 = a[j]
+ if (fp_equalr (z1, z2)) {
+ mode = z1
+ return (mode)
+ }
+
+ zstep = ZSTEP * (z2 - z1)
+ zbin = ZBIN * (z2 - z1)
+ zstep = max (1., zstep)
+ zbin = max (1., zbin)
+
+ z1 = z1 - zstep
+ k = i
+ nmax = 0
+ repeat {
+ z1 = z1 + zstep
+ z2 = z1 + zbin
+ for (; i < j && a[i] < z1; i=i+1)
+ ;
+ for (; k < j && a[k] < z2; k=k+1)
+ ;
+ if (k - i > nmax) {
+ nmax = k - i
+ mode = a[(i+k)/2]
+ }
+ } until (k >= j)
+
+ return (mode)
+end
+
+# IC_STAT -- Compute image statistics within specified section.
+# The image section is relative to a reference image which may be
+# different than the input image and may have an offset. Only a
+# subsample of pixels is used. Masked and thresholded pixels are
+# ignored. Only the desired statistics are computed to increase
+# efficiency.
+
+procedure ic_statr (im, imref, section, offsets, image, nimages,
+ domode, domedian, domean, mode, median, mean)
+
+pointer im # Data image
+pointer imref # Reference image for image section
+char section[ARB] # Image section
+int offsets[nimages,ARB] # Image section offset from data to reference
+int image # Image index (for mask I/O)
+int nimages # Number of images in offsets.
+bool domode, domedian, domean # Statistics to compute
+real mode, median, mean # Statistics
+
+int i, j, ndim, n, nv
+real a
+pointer sp, v1, v2, dv, va, vb
+pointer data, mask, dp, lp, mp, imgnlr()
+real ic_moder()
+real asumr()
+
+
+include "../icombine.com"
+
+begin
+ call smark (sp)
+ call salloc (v1, IM_MAXDIM, TY_LONG)
+ call salloc (v2, IM_MAXDIM, TY_LONG)
+ call salloc (dv, IM_MAXDIM, TY_LONG)
+ call salloc (va, IM_MAXDIM, TY_LONG)
+ call salloc (vb, IM_MAXDIM, TY_LONG)
+
+ # Determine the image section parameters. This must be in terms of
+ # the data image pixel coordinates though the section may be specified
+ # in terms of the reference image coordinates. Limit the number of
+ # pixels in each dimension to a maximum.
+
+ ndim = IM_NDIM(im)
+ if (project)
+ ndim = ndim - 1
+ call amovki (1, Memi[v1], IM_MAXDIM)
+ call amovki (1, Memi[va], IM_MAXDIM)
+ call amovki (1, Memi[dv], IM_MAXDIM)
+ call amovi (IM_LEN(imref,1), Memi[vb], ndim)
+ call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim)
+ if (im != imref)
+ do i = 1, ndim {
+ Memi[va+i-1] = Memi[va+i-1] - offsets[image,i]
+ Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i]
+ }
+
+ do j = 1, 10 {
+ n = 1
+ do i = 0, ndim-1 {
+ Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i]))
+ Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i]))
+ Memi[dv+i] = j
+ nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1)
+ Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i]
+ n = n * nv
+ }
+ if (n < NMAX)
+ break
+ }
+
+ call amovl (Memi[v1], Memi[va], IM_MAXDIM)
+ Memi[va] = 1
+ if (project)
+ Memi[va+ndim] = image
+ call amovl (Memi[va], Memi[vb], IM_MAXDIM)
+
+ # Accumulate the pixel values within the section. Masked pixels and
+ # thresholded pixels are ignored.
+
+ call salloc (data, n, TY_REAL)
+ dp = data
+ while (imgnlr (im, lp, Memi[vb]) != EOF) {
+ call ic_mget1 (im, image, offsets[image,1], Memi[va], mask)
+ lp = lp + Memi[v1] - 1
+ if (dflag == D_ALL) {
+ if (dothresh) {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ a = Memr[lp]
+ if (a >= lthresh && a <= hthresh) {
+ Memr[dp] = a
+ dp = dp + 1
+ }
+ lp = lp + Memi[dv]
+ }
+ } else {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ Memr[dp] = Memr[lp]
+ dp = dp + 1
+ lp = lp + Memi[dv]
+ }
+ }
+ } else if (dflag == D_MIX) {
+ mp = mask + Memi[v1] - 1
+ if (dothresh) {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ if (Memi[mp] == 0) {
+ a = Memr[lp]
+ if (a >= lthresh && a <= hthresh) {
+ Memr[dp] = a
+ dp = dp + 1
+ }
+ }
+ mp = mp + Memi[dv]
+ lp = lp + Memi[dv]
+ }
+ } else {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ if (Memi[mp] == 0) {
+ Memr[dp] = Memr[lp]
+ dp = dp + 1
+ }
+ mp = mp + Memi[dv]
+ lp = lp + Memi[dv]
+ }
+ }
+ }
+ for (i=2; i<=ndim; i=i+1) {
+ Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1]
+ if (Memi[va+i-1] <= Memi[v2+i-1])
+ break
+ Memi[va+i-1] = Memi[v1+i-1]
+ }
+ if (i > ndim)
+ break
+ call amovl (Memi[va], Memi[vb], IM_MAXDIM)
+ }
+
+ n = dp - data
+ if (n < 1) {
+ call sfree (sp)
+ call error (1, "Image section contains no pixels")
+ }
+
+ # Compute only statistics needed.
+ if (domode || domedian) {
+ call asrtr (Memr[data], Memr[data], n)
+ mode = ic_moder (Memr[data], n)
+ median = Memr[data+n/2-1]
+ }
+ if (domean)
+ mean = asumr (Memr[data], n) / n
+
+ call sfree (sp)
+end
+
+
+define NMIN 10 # Minimum number of pixels for mode calculation
+define ZRANGE 0.8 # Fraction of pixels about median to use
+define ZSTEP 0.01 # Step size for search for mode
+define ZBIN 0.1 # Bin size for mode.
+
+# IC_MODE -- Compute mode of an array. The mode is found by binning
+# with a bin size based on the data range over a fraction of the
+# pixels about the median and a bin step which may be smaller than the
+# bin size. If there are too few points the median is returned.
+# The input array must be sorted.
+
+real procedure ic_moder (a, n)
+
+real a[n] # Data array
+int n # Number of points
+
+int i, j, k, nmax
+real z1, z2, zstep, zbin
+real mode
+bool fp_equalr()
+
+begin
+ if (n < NMIN)
+ return (a[n/2])
+
+ # Compute the mode. The array must be sorted. Consider a
+ # range of values about the median point. Use a bin size which
+ # is ZBIN of the range. Step the bin limits in ZSTEP fraction of
+ # the bin size.
+
+ i = 1 + n * (1. - ZRANGE) / 2.
+ j = 1 + n * (1. + ZRANGE) / 2.
+ z1 = a[i]
+ z2 = a[j]
+ if (fp_equalr (z1, z2)) {
+ mode = z1
+ return (mode)
+ }
+
+ zstep = ZSTEP * (z2 - z1)
+ zbin = ZBIN * (z2 - z1)
+
+ z1 = z1 - zstep
+ k = i
+ nmax = 0
+ repeat {
+ z1 = z1 + zstep
+ z2 = z1 + zbin
+ for (; i < j && a[i] < z1; i=i+1)
+ ;
+ for (; k < j && a[k] < z2; k=k+1)
+ ;
+ if (k - i > nmax) {
+ nmax = k - i
+ mode = a[(i+k)/2]
+ }
+ } until (k >= j)
+
+ return (mode)
+end
+
+# IC_STAT -- Compute image statistics within specified section.
+# The image section is relative to a reference image which may be
+# different than the input image and may have an offset. Only a
+# subsample of pixels is used. Masked and thresholded pixels are
+# ignored. Only the desired statistics are computed to increase
+# efficiency.
+
+procedure ic_statd (im, imref, section, offsets, image, nimages,
+ domode, domedian, domean, mode, median, mean)
+
+pointer im # Data image
+pointer imref # Reference image for image section
+char section[ARB] # Image section
+int offsets[nimages,ARB] # Image section offset from data to reference
+int image # Image index (for mask I/O)
+int nimages # Number of images in offsets.
+bool domode, domedian, domean # Statistics to compute
+real mode, median, mean # Statistics
+
+int i, j, ndim, n, nv
+real a
+pointer sp, v1, v2, dv, va, vb
+pointer data, mask, dp, lp, mp, imgnld()
+double ic_moded()
+double asumd()
+
+
+include "../icombine.com"
+
+begin
+ call smark (sp)
+ call salloc (v1, IM_MAXDIM, TY_LONG)
+ call salloc (v2, IM_MAXDIM, TY_LONG)
+ call salloc (dv, IM_MAXDIM, TY_LONG)
+ call salloc (va, IM_MAXDIM, TY_LONG)
+ call salloc (vb, IM_MAXDIM, TY_LONG)
+
+ # Determine the image section parameters. This must be in terms of
+ # the data image pixel coordinates though the section may be specified
+ # in terms of the reference image coordinates. Limit the number of
+ # pixels in each dimension to a maximum.
+
+ ndim = IM_NDIM(im)
+ if (project)
+ ndim = ndim - 1
+ call amovki (1, Memi[v1], IM_MAXDIM)
+ call amovki (1, Memi[va], IM_MAXDIM)
+ call amovki (1, Memi[dv], IM_MAXDIM)
+ call amovi (IM_LEN(imref,1), Memi[vb], ndim)
+ call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim)
+ if (im != imref)
+ do i = 1, ndim {
+ Memi[va+i-1] = Memi[va+i-1] - offsets[image,i]
+ Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i]
+ }
+
+ do j = 1, 10 {
+ n = 1
+ do i = 0, ndim-1 {
+ Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i]))
+ Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i]))
+ Memi[dv+i] = j
+ nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1)
+ Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i]
+ n = n * nv
+ }
+ if (n < NMAX)
+ break
+ }
+
+ call amovl (Memi[v1], Memi[va], IM_MAXDIM)
+ Memi[va] = 1
+ if (project)
+ Memi[va+ndim] = image
+ call amovl (Memi[va], Memi[vb], IM_MAXDIM)
+
+ # Accumulate the pixel values within the section. Masked pixels and
+ # thresholded pixels are ignored.
+
+ call salloc (data, n, TY_DOUBLE)
+ dp = data
+ while (imgnld (im, lp, Memi[vb]) != EOF) {
+ call ic_mget1 (im, image, offsets[image,1], Memi[va], mask)
+ lp = lp + Memi[v1] - 1
+ if (dflag == D_ALL) {
+ if (dothresh) {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ a = Memd[lp]
+ if (a >= lthresh && a <= hthresh) {
+ Memd[dp] = a
+ dp = dp + 1
+ }
+ lp = lp + Memi[dv]
+ }
+ } else {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ Memd[dp] = Memd[lp]
+ dp = dp + 1
+ lp = lp + Memi[dv]
+ }
+ }
+ } else if (dflag == D_MIX) {
+ mp = mask + Memi[v1] - 1
+ if (dothresh) {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ if (Memi[mp] == 0) {
+ a = Memd[lp]
+ if (a >= lthresh && a <= hthresh) {
+ Memd[dp] = a
+ dp = dp + 1
+ }
+ }
+ mp = mp + Memi[dv]
+ lp = lp + Memi[dv]
+ }
+ } else {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ if (Memi[mp] == 0) {
+ Memd[dp] = Memd[lp]
+ dp = dp + 1
+ }
+ mp = mp + Memi[dv]
+ lp = lp + Memi[dv]
+ }
+ }
+ }
+ for (i=2; i<=ndim; i=i+1) {
+ Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1]
+ if (Memi[va+i-1] <= Memi[v2+i-1])
+ break
+ Memi[va+i-1] = Memi[v1+i-1]
+ }
+ if (i > ndim)
+ break
+ call amovl (Memi[va], Memi[vb], IM_MAXDIM)
+ }
+
+ n = dp - data
+ if (n < 1) {
+ call sfree (sp)
+ call error (1, "Image section contains no pixels")
+ }
+
+ # Compute only statistics needed.
+ if (domode || domedian) {
+ call asrtd (Memd[data], Memd[data], n)
+ mode = ic_moded (Memd[data], n)
+ median = Memd[data+n/2-1]
+ }
+ if (domean)
+ mean = asumd (Memd[data], n) / n
+
+ call sfree (sp)
+end
+
+
+define NMIN 10 # Minimum number of pixels for mode calculation
+define ZRANGE 0.8 # Fraction of pixels about median to use
+define ZSTEP 0.01 # Step size for search for mode
+define ZBIN 0.1 # Bin size for mode.
+
+# IC_MODE -- Compute mode of an array. The mode is found by binning
+# with a bin size based on the data range over a fraction of the
+# pixels about the median and a bin step which may be smaller than the
+# bin size. If there are too few points the median is returned.
+# The input array must be sorted.
+
+double procedure ic_moded (a, n)
+
+double a[n] # Data array
+int n # Number of points
+
+int i, j, k, nmax
+real z1, z2, zstep, zbin
+double mode
+bool fp_equalr()
+
+begin
+ if (n < NMIN)
+ return (a[n/2])
+
+ # Compute the mode. The array must be sorted. Consider a
+ # range of values about the median point. Use a bin size which
+ # is ZBIN of the range. Step the bin limits in ZSTEP fraction of
+ # the bin size.
+
+ i = 1 + n * (1. - ZRANGE) / 2.
+ j = 1 + n * (1. + ZRANGE) / 2.
+ z1 = a[i]
+ z2 = a[j]
+ if (fp_equalr (z1, z2)) {
+ mode = z1
+ return (mode)
+ }
+
+ zstep = ZSTEP * (z2 - z1)
+ zbin = ZBIN * (z2 - z1)
+
+ z1 = z1 - zstep
+ k = i
+ nmax = 0
+ repeat {
+ z1 = z1 + zstep
+ z2 = z1 + zbin
+ for (; i < j && a[i] < z1; i=i+1)
+ ;
+ for (; k < j && a[k] < z2; k=k+1)
+ ;
+ if (k - i > nmax) {
+ nmax = k - i
+ mode = a[(i+k)/2]
+ }
+ } until (k >= j)
+
+ return (mode)
+end
+
diff --git a/pkg/obsolete/imcombine/generic/mkpkg b/pkg/obsolete/imcombine/generic/mkpkg
new file mode 100644
index 00000000..8e80222b
--- /dev/null
+++ b/pkg/obsolete/imcombine/generic/mkpkg
@@ -0,0 +1,23 @@
+# Make IMCOMBINE.
+
+$checkout libpkg.a ../../../../
+$update libpkg.a
+$checkin libpkg.a ../../../../
+$exit
+
+libpkg.a:
+ icaclip.x ../icombine.com ../icombine.h
+ icaverage.x ../icombine.com ../icombine.h <imhdr.h>
+ iccclip.x ../icombine.com ../icombine.h
+ icgdata.x ../icombine.com ../icombine.h <imhdr.h> <mach.h>
+ icgrow.x ../icombine.com ../icombine.h <imhdr.h> <pmset.h>
+ icmedian.x ../icombine.com ../icombine.h
+ icmm.x ../icombine.com ../icombine.h
+ icombine.x ../icombine.com ../icombine.h <error.h> <imhdr.h>\
+ <imset.h> <mach.h> <pmset.h> <syserr.h>
+ icpclip.x ../icombine.com ../icombine.h
+ icsclip.x ../icombine.com ../icombine.h
+ icsigma.x ../icombine.com ../icombine.h <imhdr.h>
+ icsort.x
+ icstat.x ../icombine.com ../icombine.h <imhdr.h>
+ ;
diff --git a/pkg/obsolete/imcombine/icaclip.gx b/pkg/obsolete/imcombine/icaclip.gx
new file mode 100644
index 00000000..677e561c
--- /dev/null
+++ b/pkg/obsolete/imcombine/icaclip.gx
@@ -0,0 +1,573 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include "../icombine.h"
+
+define MINCLIP 3 # Minimum number of images for this algorithm
+
+$for (sird)
+# IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average
+# The average sigma is normalized by the expected poisson sigma.
+
+procedure ic_aavsigclip$t (d, m, n, scales, zeros, nimages, npts, average)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+$if (datatype == sil)
+real average[npts] # Average
+$else
+PIXEL average[npts] # Average
+$endif
+
+int i, j, k, l, jj, n1, n2, nin, nk, maxkeep
+$if (datatype == sil)
+real d1, low, high, sum, a, s, s1, r, one
+data one /1.0/
+$else
+PIXEL d1, low, high, sum, a, s, s1, r, one
+data one /1$f/
+$endif
+pointer sp, sums, resid, dp1, dp2, mp1, mp2
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (sums, npts, TY_REAL)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Since the unweighted average is computed here possibly skip combining
+ if (dowts || combine != AVERAGE)
+ docombine = true
+ else
+ docombine = false
+
+ # Compute the unweighted average with the high and low rejected and
+ # the poisson scaled average sigma. There must be at least three
+ # pixels at each point to define the average and contributions to
+ # the mean sigma. Corrections for differences in the image
+ # scale factors are selected by the doscale1 flag.
+
+ nin = n[1]
+ s = 0.
+ n2 = 0
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (n1 < 3)
+ next
+
+ # Unweighted average with the high and low rejected
+ low = Mem$t[d[1]+k]
+ high = Mem$t[d[2]+k]
+ if (low > high) {
+ d1 = low
+ low = high
+ high = d1
+ }
+ sum = 0.
+ do j = 3, n1 {
+ d1 = Mem$t[d[j]+k]
+ if (d1 < low) {
+ sum = sum + low
+ low = d1
+ } else if (d1 > high) {
+ sum = sum + high
+ high = d1
+ } else
+ sum = sum + d1
+ }
+ a = sum / (n1 - 2)
+ sum = sum + low + high
+
+ # Poisson scaled sigma accumulation
+ if (doscale1) {
+ do j = 1, n1 {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+
+ d1 = Mem$t[dp1]
+ l = Memi[mp1]
+ s1 = max (one, (a + zeros[l]) / scales[l])
+ s = s + (d1 - a) ** 2 / s1
+ }
+ } else {
+ s1 = max (one, a)
+ do j = 1, n1
+ s = s + (Mem$t[d[j]+k] - a) ** 2 / s1
+ }
+ n2 = n2 + n1
+
+ # Save the average and sum for later.
+ average[i] = a
+ Memr[sums+k] = sum
+ }
+
+ # Here is the final sigma.
+ if (n2 > 1)
+ s = sqrt (s / (n2 - 1))
+
+ # Reject pixels and compute the final average (if needed).
+ # There must be at least three pixels at each point for rejection.
+ # Iteratively scale the mean sigma and reject pixels
+ # Compact the data and keep track of the image IDs if needed.
+
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 <= max (2, maxkeep)) {
+ if (!docombine) {
+ if (n1 == 0)
+ average[i] = blank
+ else {
+ sum = Mem$t[d[1]+k]
+ do j = 2, n1
+ sum = sum + Mem$t[d[j]+k]
+ average[i] = sum / n1
+ }
+ }
+ next
+ }
+
+ a = average[i]
+ sum = Memr[sums+k]
+
+ repeat {
+ n2 = n1
+ if (s > 0.) {
+ if (doscale1) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+
+ d1 = Mem$t[dp1]
+ l = Memi[mp1]
+ s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l]))
+ r = (d1 - a) / s1
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Mem$t[dp1] = Mem$t[dp2]
+ Mem$t[dp2] = d1
+ mp2 = m[n1] + k
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ } else {
+ s1 = s * sqrt (max (one, a))
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ d1 = Mem$t[dp1]
+ r = (d1 - a) / s1
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Mem$t[dp1] = Mem$t[dp2]
+ Mem$t[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ }
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ }
+ if (n1 > 1)
+ a = sum / n1
+ } until (n1 == n2 || n1 <= max (2, maxkeep))
+
+ # If too many are rejected add some back in.
+ # Pixels with equal residuals are added together.
+ if (n1 < maxkeep) {
+ nk = maxkeep
+ if (doscale1) {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Mem$t[dp1]
+ Mem$t[dp1] = Mem$t[dp2]
+ Mem$t[dp2] = d1
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ sum = sum + Mem$t[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ } else {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Mem$t[dp1]
+ Mem$t[dp1] = Mem$t[dp2]
+ Mem$t[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ }
+ sum = sum + Mem$t[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ }
+ if (n1 > 1)
+ a = sum / n1
+ }
+
+ # Save the average if needed.
+ n[i] = n1
+ if (!docombine) {
+ if (n1 > 0)
+ average[i] = a
+ else
+ average[i] = blank
+ }
+ }
+
+ # Check if the data flag has to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median
+# The average sigma is normalized by the expected poisson sigma.
+
+procedure ic_mavsigclip$t (d, m, n, scales, zeros, nimages, npts, median)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+$if (datatype == sil)
+real median[npts] # Median
+$else
+PIXEL median[npts] # Median
+$endif
+
+int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep
+pointer sp, resid, mp1, mp2
+$if (datatype == sil)
+real med, low, high, r, s, s1, one
+data one /1.0/
+$else
+PIXEL med, low, high, r, s, s1, one
+data one /1$f/
+$endif
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Compute the poisson scaled average sigma about the median.
+ # There must be at least three pixels at each point to define
+ # the mean sigma. Corrections for differences in the image
+ # scale factors are selected by the doscale1 flag.
+
+ s = 0.
+ n2 = 0
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (n1 < 3) {
+ if (n1 == 0)
+ median[i] = blank
+ else if (n1 == 1)
+ median[i] = Mem$t[d[1]+k]
+ else {
+ low = Mem$t[d[1]+k]
+ high = Mem$t[d[2]+k]
+ median[i] = (low + high) / 2.
+ }
+ next
+ }
+
+ # Median
+ n3 = 1 + n1 / 2
+ if (mod (n1, 2) == 0) {
+ low = Mem$t[d[n3-1]+k]
+ high = Mem$t[d[n3]+k]
+ med = (low + high) / 2.
+ } else
+ med = Mem$t[d[n3]+k]
+
+ # Poisson scaled sigma accumulation
+ if (doscale1) {
+ do j = 1, n1 {
+ l = Memi[m[j]+k]
+ s1 = max (one, (med + zeros[l]) / scales[l])
+ s = s + (Mem$t[d[j]+k] - med) ** 2 / s1
+ }
+ } else {
+ s1 = max (one, med)
+ do j = 1, n1
+ s = s + (Mem$t[d[j]+k] - med) ** 2 / s1
+ }
+ n2 = n2 + n1
+
+ # Save the median for later.
+ median[i] = med
+ }
+
+ # Here is the final sigma.
+ if (n2 > 1)
+ s = sqrt (s / (n2 - 1))
+ else
+ return
+
+ # Compute individual sigmas and iteratively clip.
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 < max (3, maxkeep+1))
+ next
+ nl = 1
+ nh = n1
+ med = median[i]
+
+ repeat {
+ n2 = n1
+ n3 = nl + n1 / 2
+
+ if (n1 >= max (MINCLIP, maxkeep+1) && s > 0.) {
+ if (doscale1) {
+ for (; nl <= n2; nl = nl + 1) {
+ l = Memi[m[nl]+k]
+ s1 = s * sqrt (max (one, (med+zeros[l])/scales[l]))
+ r = (med - Mem$t[d[nl]+k]) / s1
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ l = Memi[m[nh]+k]
+ s1 = s * sqrt (max (one, (med+zeros[l])/scales[l]))
+ r = (Mem$t[d[nh]+k] - med) / s1
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ } else {
+ s1 = s * sqrt (max (one, med))
+ for (; nl <= n2; nl = nl + 1) {
+ r = (med - Mem$t[d[nl]+k]) / s1
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ r = (Mem$t[d[nh]+k] - med) / s1
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+
+ # Recompute median
+ if (n1 < n2) {
+ if (n1 > 0) {
+ n3 = nl + n1 / 2
+ if (mod (n1, 2) == 0) {
+ low = Mem$t[d[n3-1]+k]
+ high = Mem$t[d[n3]+k]
+ med = (low + high) / 2.
+ } else
+ med = Mem$t[d[n3]+k]
+ } else
+ med = blank
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ # If too many are rejected add some back in.
+ # Pixels with equal residuals are added together.
+ while (n1 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n1 = nh - nl + 1
+
+ # Recompute median
+ if (n1 < n2) {
+ if (n1 > 0) {
+ n3 = nl + n1 / 2
+ if (mod (n1, 2) == 0) {
+ low = Mem$t[d[n3-1]+k]
+ high = Mem$t[d[n3]+k]
+ med = (low + high) / 2.
+ } else
+ med = Mem$t[d[n3]+k]
+ } else
+ med = blank
+ }
+ }
+
+ # Only set median and reorder if needed
+ n[i] = n1
+ if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ j = max (nl, n1 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Mem$t[d[l]+k] = Mem$t[d[j]+k]
+ if (grow >= 1.) {
+ mp1 = m[l] + k
+ mp2 = m[j] + k
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+k] = Memi[m[j]+k]
+ j = j + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Mem$t[d[l]+k] = Mem$t[d[j]+k]
+ j = j + 1
+ }
+ }
+ }
+
+ if (combine == MEDIAN)
+ median[i] = med
+ }
+
+ # Check if data flag needs to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag that the median is computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+$endfor
diff --git a/pkg/obsolete/imcombine/icaverage.gx b/pkg/obsolete/imcombine/icaverage.gx
new file mode 100644
index 00000000..505f4577
--- /dev/null
+++ b/pkg/obsolete/imcombine/icaverage.gx
@@ -0,0 +1,97 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include "../icombine.h"
+
+$for (sird)
+# IC_AVERAGE -- Compute the average image line.
+# Options include a weight average.
+
+procedure ic_average$t (d, m, n, wts, npts, doblank, average)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image ID pointers
+int n[npts] # Number of points
+real wts[ARB] # Weights
+int npts # Number of output points per line
+int doblank # Set blank values?
+$if (datatype == sil)
+real average[npts] # Average (returned)
+$else
+PIXEL average[npts] # Average (returned)
+$endif
+
+int i, j, k
+real sumwt, wt
+$if (datatype == sil)
+real sum
+$else
+PIXEL sum
+$endif
+
+include "../icombine.com"
+
+begin
+ # If no data has been excluded do the average without checking the
+ # number of points and using the fact that the weights are normalized.
+ # If all the data has been excluded set the average to the blank value
+ # if requested.
+
+ if (dflag == D_ALL) {
+ if (dowts) {
+ do i = 1, npts {
+ k = i - 1
+ wt = wts[Memi[m[1]+k]]
+ sum = Mem$t[d[1]+k] * wt
+ do j = 2, n[i] {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + Mem$t[d[j]+k] * wt
+ }
+ average[i] = sum
+ }
+ } else {
+ do i = 1, npts {
+ k = i - 1
+ sum = Mem$t[d[1]+k]
+ do j = 2, n[i]
+ sum = sum + Mem$t[d[j]+k]
+ average[i] = sum / n[i]
+ }
+ }
+ } else if (dflag == D_NONE) {
+ if (doblank == YES) {
+ do i = 1, npts
+ average[i] = blank
+ }
+ } else {
+ if (dowts) {
+ do i = 1, npts {
+ if (n[i] > 0) {
+ k = i - 1
+ wt = wts[Memi[m[1]+k]]
+ sum = Mem$t[d[1]+k] * wt
+ sumwt = wt
+ do j = 2, n[i] {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + Mem$t[d[j]+k] * wt
+ sumwt = sumwt + wt
+ }
+ average[i] = sum / sumwt
+ } else if (doblank == YES)
+ average[i] = blank
+ }
+ } else {
+ do i = 1, npts {
+ if (n[i] > 0) {
+ k = i - 1
+ sum = Mem$t[d[1]+k]
+ do j = 2, n[i]
+ sum = sum + Mem$t[d[j]+k]
+ average[i] = sum / n[i]
+ } else if (doblank == YES)
+ average[i] = blank
+ }
+ }
+ }
+end
+$endfor
diff --git a/pkg/obsolete/imcombine/iccclip.gx b/pkg/obsolete/imcombine/iccclip.gx
new file mode 100644
index 00000000..609b3448
--- /dev/null
+++ b/pkg/obsolete/imcombine/iccclip.gx
@@ -0,0 +1,471 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include "../icombine.h"
+
+define MINCLIP 2 # Mininum number of images for algorithm
+
+$for (sird)
+# IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average
+
+procedure ic_accdclip$t (d, m, n, scales, zeros, nm, nimages, npts, average)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+real nm[3,nimages] # Noise model parameters
+int nimages # Number of images
+int npts # Number of output points per line
+$if (datatype == sil)
+real average[npts] # Average
+$else
+PIXEL average[npts] # Average
+$endif
+
+int i, j, k, l, jj, n1, n2, nin, nk, maxkeep
+$if (datatype == sil)
+real d1, low, high, sum, a, s, r, zero
+data zero /0.0/
+$else
+PIXEL d1, low, high, sum, a, s, r, zero
+data zero /0$f/
+$endif
+pointer sp, resid, dp1, dp2, mp1, mp2
+
+include "../icombine.com"
+
+begin
+ # If there are no pixels go on to the combining. Since the unweighted
+ # average is computed here possibly skip the combining later.
+
+ # There must be at least max (1, nkeep) pixels.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ } else if (dowts || combine != AVERAGE)
+ docombine = true
+ else
+ docombine = false
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # There must be at least two pixels for rejection. The initial
+ # average is the low/high rejected average except in the case of
+ # just two pixels. The rejections are iterated and the average
+ # is recomputed. Corrections for scaling may be performed.
+ # Depending on other flags the image IDs may also need to be adjusted.
+
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 <= max (MINCLIP-1, maxkeep)) {
+ if (!docombine) {
+ if (n1 == 0)
+ average[i] = blank
+ else {
+ sum = Mem$t[d[1]+k]
+ do j = 2, n1
+ sum = sum + Mem$t[d[j]+k]
+ average[i] = sum / n1
+ }
+ }
+ next
+ }
+
+ repeat {
+ if (n1 == 2) {
+ sum = Mem$t[d[1]+k]
+ sum = sum + Mem$t[d[2]+k]
+ a = sum / 2
+ } else {
+ low = Mem$t[d[1]+k]
+ high = Mem$t[d[2]+k]
+ if (low > high) {
+ d1 = low
+ low = high
+ high = d1
+ }
+ sum = 0.
+ do j = 3, n1 {
+ d1 = Mem$t[d[j]+k]
+ if (d1 < low) {
+ sum = sum + low
+ low = d1
+ } else if (d1 > high) {
+ sum = sum + high
+ high = d1
+ } else
+ sum = sum + d1
+ }
+ a = sum / (n1 - 2)
+ sum = sum + low + high
+ }
+ n2 = n1
+ if (doscale1) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+
+ l = Memi[mp1]
+ s = scales[l]
+ d1 = max (zero, s * (a + zeros[l]))
+ s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s
+
+ d1 = Mem$t[dp1]
+ r = (d1 - a) / s
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Mem$t[dp1] = Mem$t[dp2]
+ Mem$t[dp2] = d1
+ mp2 = m[n1] + k
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ } else {
+ if (!keepids) {
+ s = max (zero, a)
+ s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2)
+ }
+ for (j=1; j<=n1; j=j+1) {
+ if (keepids) {
+ l = Memi[m[j]+k]
+ s = max (zero, a)
+ s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2)
+ }
+ dp1 = d[j] + k
+ d1 = Mem$t[dp1]
+ r = (d1 - a) / s
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs(r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Mem$t[dp1] = Mem$t[dp2]
+ Mem$t[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ }
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ if (n1 < maxkeep) {
+ nk = maxkeep
+ if (doscale1) {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Mem$t[dp1]
+ Mem$t[dp1] = Mem$t[dp2]
+ Mem$t[dp2] = d1
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ sum = sum + Mem$t[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ } else {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Mem$t[dp1]
+ Mem$t[dp1] = Mem$t[dp2]
+ Mem$t[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ }
+ sum = sum + Mem$t[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ }
+ }
+
+ n[i] = n1
+ if (!docombine)
+ if (n1 > 0)
+ average[i] = sum / n1
+ else
+ average[i] = blank
+ }
+
+ # Check if the data flag has to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median
+
+procedure ic_mccdclip$t (d, m, n, scales, zeros, nm, nimages, npts, median)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+real nm[3,nimages] # Noise model
+int nimages # Number of images
+int npts # Number of output points per line
+$if (datatype == sil)
+real median[npts] # Median
+$else
+PIXEL median[npts] # Median
+$endif
+
+int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep
+real r, s
+pointer sp, resid, mp1, mp2
+$if (datatype == sil)
+real med, zero
+data zero /0.0/
+$else
+PIXEL med, zero
+data zero /0$f/
+$endif
+
+include "../icombine.com"
+
+begin
+ # There must be at least max (MINCLIP, nkeep+1) pixels.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Compute median and sigma and iteratively clip.
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ nl = 1
+ nh = n1
+
+ repeat {
+ n2 = n1
+ n3 = nl + n1 / 2
+
+ if (n1 == 0)
+ med = blank
+ else if (mod (n1, 2) == 0) {
+ med = Mem$t[d[n3-1]+k]
+ med = (med + Mem$t[d[n3]+k]) / 2.
+ } else
+ med = Mem$t[d[n3]+k]
+
+ if (n1 >= max (MINCLIP, maxkeep+1)) {
+ if (doscale1) {
+ for (; nl <= n2; nl = nl + 1) {
+ l = Memi[m[nl]+k]
+ s = scales[l]
+ r = max (zero, s * (med + zeros[l]))
+ s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s
+ r = (med - Mem$t[d[nl]+k]) / s
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ l = Memi[m[nh]+k]
+ s = scales[l]
+ r = max (zero, s * (med + zeros[l]))
+ s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s
+ r = (Mem$t[d[nh]+k] - med) / s
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ } else {
+ if (!keepids) {
+ s = max (zero, med)
+ s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2)
+ }
+ for (; nl <= n2; nl = nl + 1) {
+ if (keepids) {
+ l = Memi[m[nl]+k]
+ s = max (zero, med)
+ s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2)
+ }
+ r = (med - Mem$t[d[nl]+k]) / s
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ if (keepids) {
+ l = Memi[m[nh]+k]
+ s = max (zero, med)
+ s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2)
+ }
+ r = (Mem$t[d[nh]+k] - med) / s
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ while (n1 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n1 = nh - nl + 1
+ }
+
+ # Only set median and reorder if needed
+ n[i] = n1
+ if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ j = max (nl, n1 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Mem$t[d[l]+k] = Mem$t[d[j]+k]
+ if (grow >= 1.) {
+ mp1 = m[l] + k
+ mp2 = m[j] + k
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+k] = Memi[m[j]+k]
+ j = j + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Mem$t[d[l]+k] = Mem$t[d[j]+k]
+ j = j + 1
+ }
+ }
+ }
+
+ if (combine == MEDIAN)
+ median[i] = med
+ }
+
+ # Check if data flag needs to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag that the median is computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+$endfor
diff --git a/pkg/obsolete/imcombine/icgdata.gx b/pkg/obsolete/imcombine/icgdata.gx
new file mode 100644
index 00000000..ce71a3eb
--- /dev/null
+++ b/pkg/obsolete/imcombine/icgdata.gx
@@ -0,0 +1,235 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include <mach.h>
+include "../icombine.h"
+
+$for (sird)
+# IC_GDATA -- Get line of image and mask data and apply threshold and scaling.
+# Entirely empty lines are excluded. The data are compacted within the
+# input data buffers. If it is required, the connection to the original
+# image index is kept in the returned m data pointers.
+
+procedure ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, scales,
+ zeros, nimages, npts, v1, v2)
+
+pointer in[nimages] # Input images
+pointer out[3] # Output images
+pointer dbuf[nimages] # Data buffers
+pointer d[nimages] # Data pointers
+pointer id[nimages] # ID pointers
+int n[npts] # Number of good pixels
+pointer m[nimages] # Mask pointers
+int lflag[nimages] # Empty mask flags
+int offsets[nimages,ARB] # Image offsets
+real scales[nimages] # Scale factors
+real zeros[nimages] # Zero offset factors
+int nimages # Number of input images
+int npts # NUmber of output points per line
+long v1[ARB], v2[ARB] # Line vectors
+
+int i, j, k, l, ndim, nused
+real a, b
+pointer buf, dp, ip, mp, imgnl$t()
+
+include "../icombine.com"
+
+begin
+ # Get masks and return if there is no data
+ call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages)
+ if (dflag == D_NONE) {
+ call aclri (n, npts)
+ return
+ }
+
+ # Get data and fill data buffers. Correct for offsets if needed.
+ ndim = IM_NDIM(out[1])
+ do i = 1, nimages {
+ if (lflag[i] == D_NONE)
+ next
+ if (dbuf[i] == NULL) {
+ call amovl (v1, v2, IM_MAXDIM)
+ if (project)
+ v2[ndim+1] = i
+ j = imgnl$t (in[i], d[i], v2)
+ } else {
+ v2[1] = v1[1]
+ do j = 2, ndim
+ v2[j] = v1[j] - offsets[i,j]
+ if (project)
+ v2[ndim+1] = i
+ j = imgnl$t (in[i], buf, v2)
+ call amov$t (Mem$t[buf], Mem$t[dbuf[i]+offsets[i,1]],
+ IM_LEN(in[i],1))
+ d[i] = dbuf[i]
+ }
+ }
+
+ # Apply threshold if needed
+ if (dothresh) {
+ do i = 1, nimages {
+ dp = d[i]
+ if (lflag[i] == D_ALL) {
+ do j = 1, npts {
+ a = Mem$t[dp]
+ if (a < lthresh || a > hthresh) {
+ Memi[m[i]+j-1] = 1
+ lflag[i] = D_MIX
+ dflag = D_MIX
+ }
+ dp = dp + 1
+ }
+ } else if (lflag[i] == D_MIX) {
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ a = Mem$t[dp]
+ if (a < lthresh || a > hthresh) {
+ Memi[m[i]+j-1] = 1
+ dflag = D_MIX
+ }
+ }
+ dp = dp + 1
+ mp = mp + 1
+ }
+ }
+
+ # Check for completely empty lines
+ if (lflag[i] == D_MIX) {
+ lflag[i] = D_NONE
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ lflag[i] = D_MIX
+ break
+ }
+ mp = mp + 1
+ }
+ }
+ }
+ }
+
+ # Apply scaling (avoiding masked pixels which might overflow?)
+ if (doscale) {
+ if (dflag == D_ALL) {
+ do i = 1, nimages {
+ dp = d[i]
+ a = scales[i]
+ b = -zeros[i]
+ do j = 1, npts {
+ Mem$t[dp] = Mem$t[dp] / a + b
+ dp = dp + 1
+ }
+ }
+ } else if (dflag == D_MIX) {
+ do i = 1, nimages {
+ dp = d[i]
+ a = scales[i]
+ b = -zeros[i]
+ if (lflag[i] == D_ALL) {
+ do j = 1, npts {
+ Mem$t[dp] = Mem$t[dp] / a + b
+ dp = dp + 1
+ }
+ } else if (lflag[i] == D_MIX) {
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0)
+ Mem$t[dp] = Mem$t[dp] / a + b
+ dp = dp + 1
+ mp = mp + 1
+ }
+ }
+ }
+ }
+ }
+
+ # Sort pointers to exclude unused images.
+ # Use the lflag array to keep track of the image index.
+
+ if (dflag == D_ALL)
+ nused = nimages
+ else {
+ nused = 0
+ do i = 1, nimages
+ if (lflag[i] != D_NONE) {
+ nused = nused + 1
+ d[nused] = d[i]
+ m[nused] = m[i]
+ lflag[nused] = i
+ }
+ if (nused == 0)
+ dflag = D_NONE
+ }
+
+ # Compact data to remove bad pixels
+ # Keep track of the image indices if needed
+ # If growing mark the end of the included image indices with zero
+
+ if (dflag == D_ALL) {
+ call amovki (nused, n, npts)
+ if (keepids)
+ do i = 1, nimages
+ call amovki (i, Memi[id[i]], npts)
+ } else if (dflag == D_NONE)
+ call aclri (n, npts)
+ else {
+ call aclri (n, npts)
+ if (keepids) {
+ do i = 1, nused {
+ l = lflag[i]
+ dp = d[i]
+ ip = id[i]
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ n[j] = n[j] + 1
+ k = n[j]
+ if (k < i) {
+ Mem$t[d[k]+j-1] = Mem$t[dp]
+ Memi[id[k]+j-1] = l
+ } else
+ Memi[ip] = l
+ }
+ dp = dp + 1
+ ip = ip + 1
+ mp = mp + 1
+ }
+ }
+ if (grow >= 1.) {
+ do j = 1, npts {
+ do i = n[j]+1, nimages
+ Memi[id[i]+j-1] = 0
+ }
+ }
+ } else {
+ do i = 1, nused {
+ dp = d[i]
+ mp = m[i]
+ do j = 1, npts {
+ if (Memi[mp] == 0) {
+ n[j] = n[j] + 1
+ k = n[j]
+ if (k < i)
+ Mem$t[d[k]+j-1] = Mem$t[dp]
+ }
+ dp = dp + 1
+ mp = mp + 1
+ }
+ }
+ }
+ }
+
+ # Sort the pixels and IDs if needed
+ if (mclip) {
+ call malloc (dp, nimages, TY_PIXEL)
+ if (keepids) {
+ call malloc (ip, nimages, TY_INT)
+ call ic_2sort$t (d, Mem$t[dp], id, Memi[ip], n, npts)
+ call mfree (ip, TY_INT)
+ } else
+ call ic_sort$t (d, Mem$t[dp], n, npts)
+ call mfree (dp, TY_PIXEL)
+ }
+end
+$endfor
diff --git a/pkg/obsolete/imcombine/icgrow.gx b/pkg/obsolete/imcombine/icgrow.gx
new file mode 100644
index 00000000..8b28aec5
--- /dev/null
+++ b/pkg/obsolete/imcombine/icgrow.gx
@@ -0,0 +1,123 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include <pmset.h>
+include "../icombine.h"
+
+# IC_GROW -- Mark neigbors of rejected pixels.
+# The rejected pixels (original plus grown) are saved in pixel masks.
+
+procedure ic_grow (out, v, m, n, buf, nimages, npts, pms)
+
+pointer out # Output image pointer
+long v[ARB] # Output vector
+pointer m[ARB] # Image id pointers
+int n[ARB] # Number of good pixels
+int buf[npts,nimages] # Working buffer
+int nimages # Number of images
+int npts # Number of output points per line
+pointer pms # Pointer to array of pixel masks
+
+int i, j, k, l, line, nl, rop, igrow, nset, or()
+real grow2, i2
+pointer mp, pm, pm_newmask()
+errchk pm_newmask()
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_NONE || grow == 0.)
+ return
+
+ line = v[2]
+ nl = IM_LEN(out,2)
+ rop = or (PIX_SRC, PIX_DST)
+
+ igrow = grow
+ grow2 = grow**2
+ do l = 0, igrow {
+ i2 = grow2 - l * l
+ call aclri (buf, npts*nimages)
+ nset = 0
+ do j = 1, npts {
+ do k = n[j]+1, nimages {
+ mp = Memi[m[k]+j-1]
+ if (mp == 0)
+ next
+ do i = 0, igrow {
+ if (i**2 > i2)
+ next
+ if (j > i)
+ buf[j-i,mp] = 1
+ if (j+i <= npts)
+ buf[j+i,mp] = 1
+ nset = nset + 1
+ }
+ }
+ }
+ if (nset == 0)
+ return
+
+ if (pms == NULL) {
+ call malloc (pms, nimages, TY_POINTER)
+ do i = 1, nimages
+ Memi[pms+i-1] = pm_newmask (out, 1)
+ }
+ do i = 1, nimages {
+ pm = Memi[pms+i-1]
+ v[2] = line - l
+ if (v[2] > 0)
+ call pmplpi (pm, v, buf[1,i], 1, npts, rop)
+ v[2] = line + l
+ if (v[2] <= nl)
+ call pmplpi (pm, v, buf[1,i], 1, npts, rop)
+ }
+ }
+ v[2] = line
+end
+
+
+$for (sird)
+# IC_GROW$T -- Reject pixels.
+
+procedure ic_grow$t (v, d, m, n, buf, nimages, npts, pms)
+
+long v[ARB] # Output vector
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image id pointers
+int n[ARB] # Number of good pixels
+int buf[ARB] # Buffer of npts
+int nimages # Number of images
+int npts # Number of output points per line
+pointer pms # Pointer to array of pixel masks
+
+int i, j, k
+pointer pm
+bool pl_linenotempty()
+
+include "../icombine.com"
+
+begin
+ do k = 1, nimages {
+ pm = Memi[pms+k-1]
+ if (!pl_linenotempty (pm, v))
+ next
+ call pmglpi (pm, v, buf, 1, npts, PIX_SRC)
+ do i = 1, npts {
+ if (buf[i] == 0)
+ next
+ for (j = 1; j <= n[i]; j = j + 1) {
+ if (Memi[m[j]+i-1] == k) {
+ if (j < n[i]) {
+ Mem$t[d[j]+i-1] = Mem$t[d[n[i]]+i-1]
+ Memi[m[j]+i-1] = Memi[m[n[i]]+i-1]
+ }
+ n[i] = n[i] - 1
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+ }
+end
+$endfor
diff --git a/pkg/obsolete/imcombine/icimstack.x b/pkg/obsolete/imcombine/icimstack.x
new file mode 100644
index 00000000..f3f6eaa5
--- /dev/null
+++ b/pkg/obsolete/imcombine/icimstack.x
@@ -0,0 +1,129 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <error.h>
+include <imhdr.h>
+
+
+# IC_IMSTACK -- Stack images into a single image of higher dimension.
+
+procedure ic_imstack (list, output)
+
+int list #I List of images
+char output #I Name of output image
+
+int i, j, npix
+long line_in[IM_MAXDIM], line_out[IM_MAXDIM]
+pointer sp, input, key, in, out, buf_in, buf_out, ptr
+
+int imtgetim(), imtlen()
+int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx()
+int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx()
+pointer immap()
+errchk immap
+
+begin
+ call smark (sp)
+ call salloc (input, SZ_FNAME, TY_CHAR)
+ call salloc (key, SZ_FNAME, TY_CHAR)
+
+ iferr {
+ # Add each input image to the output image.
+ out = NULL
+ i = 0
+ while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) {
+
+ i = i + 1
+ in = NULL
+ ptr = immap (Memc[input], READ_ONLY, 0)
+ in = ptr
+
+ # For the first input image map the output image as a copy
+ # and increment the dimension. Set the output line counter.
+
+ if (i == 1) {
+ ptr = immap (output, NEW_COPY, in)
+ out = ptr
+ IM_NDIM(out) = IM_NDIM(out) + 1
+ IM_LEN(out, IM_NDIM(out)) = imtlen (list)
+ npix = IM_LEN(out, 1)
+ call amovkl (long(1), line_out, IM_MAXDIM)
+ }
+
+ # Check next input image for consistency with the output image.
+ if (IM_NDIM(in) != IM_NDIM(out) - 1)
+ call error (0, "Input images not consistent")
+ do j = 1, IM_NDIM(in) {
+ if (IM_LEN(in, j) != IM_LEN(out, j))
+ call error (0, "Input images not consistent")
+ }
+
+ call sprintf (Memc[key], SZ_FNAME, "stck%04d")
+ call pargi (i)
+ call imastr (out, Memc[key], Memc[input])
+
+ # Copy the input lines from the image to the next lines of
+ # the output image. Switch on the output data type to optimize
+ # IMIO.
+
+ call amovkl (long(1), line_in, IM_MAXDIM)
+ switch (IM_PIXTYPE (out)) {
+ case TY_SHORT:
+ while (imgnls (in, buf_in, line_in) != EOF) {
+ if (impnls (out, buf_out, line_out) == EOF)
+ call error (0, "Error writing output image")
+ call amovs (Mems[buf_in], Mems[buf_out], npix)
+ }
+ case TY_INT:
+ while (imgnli (in, buf_in, line_in) != EOF) {
+ if (impnli (out, buf_out, line_out) == EOF)
+ call error (0, "Error writing output image")
+ call amovi (Memi[buf_in], Memi[buf_out], npix)
+ }
+ case TY_USHORT, TY_LONG:
+ while (imgnll (in, buf_in, line_in) != EOF) {
+ if (impnll (out, buf_out, line_out) == EOF)
+ call error (0, "Error writing output image")
+ call amovl (Meml[buf_in], Meml[buf_out], npix)
+ }
+ case TY_REAL:
+ while (imgnlr (in, buf_in, line_in) != EOF) {
+ if (impnlr (out, buf_out, line_out) == EOF)
+ call error (0, "Error writing output image")
+ call amovr (Memr[buf_in], Memr[buf_out], npix)
+ }
+ case TY_DOUBLE:
+ while (imgnld (in, buf_in, line_in) != EOF) {
+ if (impnld (out, buf_out, line_out) == EOF)
+ call error (0, "Error writing output image")
+ call amovd (Memd[buf_in], Memd[buf_out], npix)
+ }
+ case TY_COMPLEX:
+ while (imgnlx (in, buf_in, line_in) != EOF) {
+ if (impnlx (out, buf_out, line_out) == EOF)
+ call error (0, "Error writing output image")
+ call amovx (Memx[buf_in], Memx[buf_out], npix)
+ }
+ default:
+ while (imgnlr (in, buf_in, line_in) != EOF) {
+ if (impnlr (out, buf_out, line_out) == EOF)
+ call error (0, "Error writing output image")
+ call amovr (Memr[buf_in], Memr[buf_out], npix)
+ }
+ }
+ call imunmap (in)
+ }
+ } then {
+ if (out != NULL) {
+ call imunmap (out)
+ call imdelete (out)
+ }
+ if (in != NULL)
+ call imunmap (in)
+ call sfree (sp)
+ call erract (EA_ERROR)
+ }
+
+ # Finish up.
+ call imunmap (out)
+ call sfree (sp)
+end
diff --git a/pkg/obsolete/imcombine/iclog.x b/pkg/obsolete/imcombine/iclog.x
new file mode 100644
index 00000000..f373e9e4
--- /dev/null
+++ b/pkg/obsolete/imcombine/iclog.x
@@ -0,0 +1,384 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include <imset.h>
+include <mach.h>
+include "icombine.h"
+
+# IC_LOG -- Output log information is a log file has been specfied.
+
+procedure ic_log (in, out, ncombine, exptime, sname, zname, wname,
+ mode, median, mean, scales, zeros, wts, offsets, nimages,
+ dozero, nout, expname, exposure)
+
+pointer in[nimages] # Input images
+pointer out[4] # Output images
+int ncombine[nimages] # Number of previous combined images
+real exptime[nimages] # Exposure times
+char sname[ARB] # Scale name
+char zname[ARB] # Zero name
+char wname[ARB] # Weight name
+real mode[nimages] # Modes
+real median[nimages] # Medians
+real mean[nimages] # Means
+real scales[nimages] # Scale factors
+real zeros[nimages] # Zero or sky levels
+real wts[nimages] # Weights
+int offsets[nimages,ARB] # Image offsets
+int nimages # Number of images
+bool dozero # Zero flag
+int nout # Number of images combined in output
+char expname[ARB] # Exposure name
+real exposure # Output exposure
+
+int i, j, stack, ctor()
+real rval, imgetr()
+long clktime()
+bool prncombine, prexptime, prmode, prmedian, prmean, prmask
+bool prrdn, prgain, prsn
+pointer sp, fname, key
+errchk imgetr
+
+include "icmask.com"
+include "icombine.com"
+
+begin
+ if (logfd == NULL)
+ return
+
+ call smark (sp)
+ call salloc (fname, SZ_LINE, TY_CHAR)
+
+ stack = NO
+ if (project) {
+ ifnoerr (call imgstr (in[1], "stck0001", Memc[fname], SZ_LINE))
+ stack = YES
+ }
+ if (stack == YES)
+ call salloc (key, SZ_FNAME, TY_CHAR)
+
+ # Time stamp the log and print parameter information.
+
+ call cnvdate (clktime(0), Memc[fname], SZ_LINE)
+ call fprintf (logfd, "\n%s: IMCOMBINE\n")
+ call pargstr (Memc[fname])
+ switch (combine) {
+ case AVERAGE:
+ call fprintf (logfd, " combine = average, ")
+ case MEDIAN:
+ call fprintf (logfd, " combine = median, ")
+ }
+ call fprintf (logfd, "scale = %s, zero = %s, weight = %s\n")
+ call pargstr (sname)
+ call pargstr (zname)
+ call pargstr (wname)
+
+ switch (reject) {
+ case MINMAX:
+ call fprintf (logfd, " reject = minmax, nlow = %d, nhigh = %d\n")
+ call pargi (nint (flow * nimages))
+ call pargi (nint (fhigh * nimages))
+ case CCDCLIP:
+ call fprintf (logfd, " reject = ccdclip, mclip = %b, nkeep = %d\n")
+ call pargb (mclip)
+ call pargi (nkeep)
+ call fprintf (logfd,
+ " rdnoise = %s, gain = %s, snoise = %s, sigma = %g, hsigma = %g\n")
+ call pargstr (Memc[rdnoise])
+ call pargstr (Memc[gain])
+ call pargstr (Memc[snoise])
+ call pargr (lsigma)
+ call pargr (hsigma)
+ case CRREJECT:
+ call fprintf (logfd,
+ " reject = crreject, mclip = %b, nkeep = %d\n")
+ call pargb (mclip)
+ call pargi (nkeep)
+ call fprintf (logfd,
+ " rdnoise = %s, gain = %s, snoise = %s, hsigma = %g\n")
+ call pargstr (Memc[rdnoise])
+ call pargstr (Memc[gain])
+ call pargstr (Memc[snoise])
+ call pargr (hsigma)
+ case PCLIP:
+ call fprintf (logfd, " reject = pclip, nkeep = %d\n")
+ call pargi (nkeep)
+ call fprintf (logfd, " pclip = %g, lsigma = %g, hsigma = %g\n")
+ call pargr (pclip)
+ call pargr (lsigma)
+ call pargr (hsigma)
+ case SIGCLIP:
+ call fprintf (logfd, " reject = sigclip, mclip = %b, nkeep = %d\n")
+ call pargb (mclip)
+ call pargi (nkeep)
+ call fprintf (logfd, " lsigma = %g, hsigma = %g\n")
+ call pargr (lsigma)
+ call pargr (hsigma)
+ case AVSIGCLIP:
+ call fprintf (logfd,
+ " reject = avsigclip, mclip = %b, nkeep = %d\n")
+ call pargb (mclip)
+ call pargi (nkeep)
+ call fprintf (logfd, " lsigma = %g, hsigma = %g\n")
+ call pargr (lsigma)
+ call pargr (hsigma)
+ }
+ if (reject != NONE && grow >= 1.) {
+ call fprintf (logfd, " grow = %g\n")
+ call pargr (grow)
+ }
+ if (dothresh) {
+ if (lthresh > -MAX_REAL && hthresh < MAX_REAL) {
+ call fprintf (logfd, " lthreshold = %g, hthreshold = %g\n")
+ call pargr (lthresh)
+ call pargr (hthresh)
+ } else if (lthresh > -MAX_REAL) {
+ call fprintf (logfd, " lthreshold = %g\n")
+ call pargr (lthresh)
+ } else {
+ call fprintf (logfd, " hthreshold = %g\n")
+ call pargr (hthresh)
+ }
+ }
+ call fprintf (logfd, " blank = %g\n")
+ call pargr (blank)
+ call clgstr ("statsec", Memc[fname], SZ_LINE)
+ if (Memc[fname] != EOS) {
+ call fprintf (logfd, " statsec = %s\n")
+ call pargstr (Memc[fname])
+ }
+
+ if (mtype != M_NONE) {
+ switch (mtype) {
+ case M_BOOLEAN, M_GOODVAL:
+ call fprintf (logfd, " masktype = goodval, maskval = %d\n")
+ call pargi (mvalue)
+ case M_BADVAL:
+ call fprintf (logfd, " masktype = badval, maskval = %d\n")
+ call pargi (mvalue)
+ case M_GOODBITS:
+ call fprintf (logfd, " masktype = goodbits, maskval = %d\n")
+ call pargi (mvalue)
+ case M_BADBITS:
+ call fprintf (logfd, " masktype = badbits, maskval = %d\n")
+ call pargi (mvalue)
+ }
+ }
+
+ # Print information pertaining to individual images as a set of
+ # columns with the image name being the first column. Determine
+ # what information is relevant and print the appropriate header.
+
+ prncombine = false
+ prexptime = false
+ prmode = false
+ prmedian = false
+ prmean = false
+ prmask = false
+ prrdn = false
+ prgain = false
+ prsn = false
+ do i = 1, nimages {
+ if (ncombine[i] != ncombine[1])
+ prncombine = true
+ if (exptime[i] != exptime[1])
+ prexptime = true
+ if (mode[i] != mode[1])
+ prmode = true
+ if (median[i] != median[1])
+ prmedian = true
+ if (mean[i] != mean[1])
+ prmean = true
+ if (mtype != M_NONE && Memi[pms+i-1] != NULL)
+ prmask = true
+ if (reject == CCDCLIP || reject == CRREJECT) {
+ j = 1
+ if (ctor (Memc[rdnoise], j, rval) == 0)
+ prrdn = true
+ j = 1
+ if (ctor (Memc[gain], j, rval) == 0)
+ prgain = true
+ j = 1
+ if (ctor (Memc[snoise], j, rval) == 0)
+ prsn = true
+ }
+ }
+
+ call fprintf (logfd, " %20s ")
+ call pargstr ("Images")
+ if (prncombine) {
+ call fprintf (logfd, " %6s")
+ call pargstr ("N")
+ }
+ if (prexptime) {
+ call fprintf (logfd, " %6s")
+ call pargstr ("Exp")
+ }
+ if (prmode) {
+ call fprintf (logfd, " %7s")
+ call pargstr ("Mode")
+ }
+ if (prmedian) {
+ call fprintf (logfd, " %7s")
+ call pargstr ("Median")
+ }
+ if (prmean) {
+ call fprintf (logfd, " %7s")
+ call pargstr ("Mean")
+ }
+ if (prrdn) {
+ call fprintf (logfd, " %7s")
+ call pargstr ("Rdnoise")
+ }
+ if (prgain) {
+ call fprintf (logfd, " %6s")
+ call pargstr ("Gain")
+ }
+ if (prsn) {
+ call fprintf (logfd, " %6s")
+ call pargstr ("Snoise")
+ }
+ if (doscale) {
+ call fprintf (logfd, " %6s")
+ call pargstr ("Scale")
+ }
+ if (dozero) {
+ call fprintf (logfd, " %7s")
+ call pargstr ("Zero")
+ }
+ if (dowts) {
+ call fprintf (logfd, " %6s")
+ call pargstr ("Weight")
+ }
+ if (!aligned) {
+ call fprintf (logfd, " %9s")
+ call pargstr ("Offsets")
+ }
+ if (prmask) {
+ call fprintf (logfd, " %s")
+ call pargstr ("Maskfile")
+ }
+ call fprintf (logfd, "\n")
+
+ do i = 1, nimages {
+ if (stack == YES) {
+ call sprintf (Memc[key], SZ_FNAME, "stck%04d")
+ call pargi (i)
+ ifnoerr (call imgstr (in[i], Memc[key], Memc[fname], SZ_LINE)) {
+ call fprintf (logfd, " %21s")
+ call pargstr (Memc[fname])
+ } else {
+ call imstats (in[i], IM_IMAGENAME, Memc[fname], SZ_LINE)
+ call fprintf (logfd, " %16s[%3d]")
+ call pargstr (Memc[fname])
+ call pargi (i)
+ }
+ } else if (project) {
+ call imstats (in[i], IM_IMAGENAME, Memc[fname], SZ_LINE)
+ call fprintf (logfd, " %16s[%3d]")
+ call pargstr (Memc[fname])
+ call pargi (i)
+ } else {
+ call imstats (in[i], IM_IMAGENAME, Memc[fname], SZ_LINE)
+ call fprintf (logfd, " %21s")
+ call pargstr (Memc[fname])
+ }
+ if (prncombine) {
+ call fprintf (logfd, " %6d")
+ call pargi (ncombine[i])
+ }
+ if (prexptime) {
+ call fprintf (logfd, " %6.1f")
+ call pargr (exptime[i])
+ }
+ if (prmode) {
+ call fprintf (logfd, " %7.5g")
+ call pargr (mode[i])
+ }
+ if (prmedian) {
+ call fprintf (logfd, " %7.5g")
+ call pargr (median[i])
+ }
+ if (prmean) {
+ call fprintf (logfd, " %7.5g")
+ call pargr (mean[i])
+ }
+ if (prrdn) {
+ rval = imgetr (in[i], Memc[rdnoise])
+ call fprintf (logfd, " %7g")
+ call pargr (rval)
+ }
+ if (prgain) {
+ rval = imgetr (in[i], Memc[gain])
+ call fprintf (logfd, " %6g")
+ call pargr (rval)
+ }
+ if (prsn) {
+ rval = imgetr (in[i], Memc[snoise])
+ call fprintf (logfd, " %6g")
+ call pargr (rval)
+ }
+ if (doscale) {
+ call fprintf (logfd, " %6.3f")
+ call pargr (1./scales[i])
+ }
+ if (dozero) {
+ call fprintf (logfd, " %7.5g")
+ call pargr (-zeros[i])
+ }
+ if (dowts) {
+ call fprintf (logfd, " %6.3f")
+ call pargr (wts[i])
+ }
+ if (!aligned) {
+ if (IM_NDIM(out[1]) == 1) {
+ call fprintf (logfd, " %9d")
+ call pargi (offsets[i,1])
+ } else {
+ do j = 1, IM_NDIM(out[1]) {
+ call fprintf (logfd, " %4d")
+ call pargi (offsets[i,j])
+ }
+ }
+ }
+ if (prmask && Memi[pms+i-1] != NULL) {
+ call imgstr (in[i], "BPM", Memc[fname], SZ_LINE)
+ call fprintf (logfd, " %s")
+ call pargstr (Memc[fname])
+ }
+ call fprintf (logfd, "\n")
+ }
+
+ # Log information about the output images.
+ call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_LINE)
+ call fprintf (logfd, "\n Output image = %s, ncombine = %d")
+ call pargstr (Memc[fname])
+ call pargi (nout)
+ if (expname[1] != EOS) {
+ call fprintf (logfd, ", %s = %g")
+ call pargstr (expname)
+ call pargr (exposure)
+ }
+ call fprintf (logfd, "\n")
+
+ if (out[4] != NULL) {
+ call imstats (out[4], IM_IMAGENAME, Memc[fname], SZ_LINE)
+ call fprintf (logfd, " Rejection mask = %s\n")
+ call pargstr (Memc[fname])
+ }
+
+ if (out[2] != NULL) {
+ call imstats (out[2], IM_IMAGENAME, Memc[fname], SZ_LINE)
+ call fprintf (logfd, " Pixel list image = %s\n")
+ call pargstr (Memc[fname])
+ }
+
+ if (out[3] != NULL) {
+ call imstats (out[3], IM_IMAGENAME, Memc[fname], SZ_LINE)
+ call fprintf (logfd, " Sigma image = %s\n")
+ call pargstr (Memc[fname])
+ }
+
+ call flush (logfd)
+ call sfree (sp)
+end
diff --git a/pkg/obsolete/imcombine/icmask.com b/pkg/obsolete/imcombine/icmask.com
new file mode 100644
index 00000000..baba6f6a
--- /dev/null
+++ b/pkg/obsolete/imcombine/icmask.com
@@ -0,0 +1,8 @@
+# IMCMASK -- Common for IMCOMBINE mask interface.
+
+int mtype # Mask type
+int mvalue # Mask value
+pointer bufs # Pointer to data line buffers
+pointer pms # Pointer to array of PMIO pointers
+
+common /imcmask/ mtype, mvalue, bufs, pms
diff --git a/pkg/obsolete/imcombine/icmask.x b/pkg/obsolete/imcombine/icmask.x
new file mode 100644
index 00000000..9aeec395
--- /dev/null
+++ b/pkg/obsolete/imcombine/icmask.x
@@ -0,0 +1,314 @@
+include <imhdr.h>
+include <pmset.h>
+include "icombine.h"
+
+# IC_MASK -- ICOMBINE mask interface
+#
+# IC_MOPEN -- Open masks
+# IC_MCLOSE -- Close the mask interface
+# IC_MGET -- Get lines of mask pixels for all the images
+# IC_MGET1 -- Get a line of mask pixels for the specified image
+
+
+# IC_MOPEN -- Open masks.
+# Parse and interpret the mask selection parameters.
+
+procedure ic_mopen (in, out, nimages)
+
+pointer in[nimages] #I Input images
+pointer out[3] #I Output images
+int nimages #I Number of images
+
+int i, npix, npms, clgwrd()
+real clgetr()
+pointer sp, fname, title, pm, pm_open()
+bool invert, pm_empty()
+errchk calloc, pm_open, pm_loadf
+
+include "icmask.com"
+include "icombine.com"
+
+begin
+ call smark (sp)
+ call salloc (fname, SZ_FNAME, TY_CHAR)
+ call salloc (title, SZ_FNAME, TY_CHAR)
+
+ # Determine the mask parameters and allocate memory.
+ # The mask buffers are initialize to all excluded so that
+ # output points outside the input data are always excluded
+ # and don't need to be set on a line-by-line basis.
+
+ mtype = clgwrd ("masktype", Memc[title], SZ_FNAME, MASKTYPES)
+ mvalue = clgetr ("maskvalue")
+ npix = IM_LEN(out[1],1)
+ call calloc (pms, nimages, TY_POINTER)
+ call calloc (bufs, nimages, TY_POINTER)
+ do i = 1, nimages {
+ call malloc (Memi[bufs+i-1], npix, TY_INT)
+ call amovki (1, Memi[Memi[bufs+i-1]], npix)
+ }
+
+ # Check for special cases. The BOOLEAN type is used when only
+ # zero and nonzero are significant; i.e. the actual mask values are
+ # not important. The invert flag is used to indicate that
+ # empty masks are all bad rather the all good.
+
+ if (mtype == 0)
+ mtype = M_NONE
+ if (mtype == M_BADBITS && mvalue == 0)
+ mtype = M_NONE
+ if (mvalue == 0 && (mtype == M_GOODVAL || mtype == M_GOODBITS))
+ mtype = M_BOOLEAN
+ if ((mtype == M_BADVAL && mvalue == 0) ||
+ (mtype == M_GOODVAL && mvalue != 0) ||
+ (mtype == M_GOODBITS && mvalue == 0))
+ invert = true
+ else
+ invert = false
+
+ # If mask images are to be used, get the mask name from the image
+ # header and open it saving the descriptor in the pms array.
+ # Empty masks (all good) are treated as if there was no mask image.
+
+ npms = 0
+ do i = 1, nimages {
+ if (mtype != M_NONE) {
+ ifnoerr (call imgstr (in[i], "BPM", Memc[fname], SZ_FNAME)) {
+ pm = pm_open (NULL)
+ call pm_loadf (pm, Memc[fname], Memc[title], SZ_FNAME)
+ call pm_seti (pm, P_REFIM, in[i])
+ if (pm_empty (pm) && !invert)
+ call pm_close (pm)
+ else {
+ if (project) {
+ npms = nimages
+ call amovki (pm, Memi[pms], nimages)
+ } else {
+ npms = npms + 1
+ Memi[pms+i-1] = pm
+ }
+ }
+ if (project)
+ break
+ }
+ }
+ }
+
+ # If no mask images are found and the mask parameters imply that
+ # good values are 0 then use the special case of no masks.
+
+ if (npms == 0) {
+ if (!invert)
+ mtype = M_NONE
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_MCLOSE -- Close the mask interface.
+
+procedure ic_mclose (nimages)
+
+int nimages # Number of images
+
+int i
+include "icmask.com"
+include "icombine.com"
+
+begin
+ do i = 1, nimages
+ call mfree (Memi[bufs+i-1], TY_INT)
+ do i = 1, nimages {
+ if (Memi[pms+i-1] != NULL)
+ call pm_close (Memi[pms+i-1])
+ if (project)
+ break
+ }
+ call mfree (pms, TY_POINTER)
+ call mfree (bufs, TY_POINTER)
+end
+
+
+# IC_MGET -- Get lines of mask pixels in the output coordinate system.
+# This converts the mask format to an array where zero is good and nonzero
+# is bad. This has special cases for optimization.
+
+procedure ic_mget (in, out, offsets, v1, v2, m, lflag, nimages)
+
+pointer in[nimages] # Input image pointers
+pointer out[3] # Output image pointer
+int offsets[nimages,ARB] # Offsets to output image
+long v1[IM_MAXDIM] # Data vector desired in output image
+long v2[IM_MAXDIM] # Data vector in input image
+pointer m[nimages] # Pointer to mask pointers
+int lflag[nimages] # Line flags
+int nimages # Number of images
+
+int i, j, ndim, nout, npix
+pointer buf, pm
+bool pm_linenotempty()
+errchk pm_glpi
+
+include "icmask.com"
+include "icombine.com"
+
+begin
+ # Determine if masks are needed at all. Note that the threshold
+ # is applied by simulating mask values so the mask pointers have to
+ # be set.
+
+ if (mtype == M_NONE && aligned && !dothresh) {
+ dflag = D_ALL
+ return
+ }
+
+ # Set the mask pointers and line flags and apply offsets if needed.
+
+ ndim = IM_NDIM(out[1])
+ nout = IM_LEN(out[1],1)
+ do i = 1, nimages {
+ npix = IM_LEN(in[i],1)
+ j = offsets[i,1]
+ m[i] = Memi[bufs+i-1]
+ buf = Memi[bufs+i-1] + j
+ pm = Memi[pms+i-1]
+ if (npix == nout)
+ lflag[i] = D_ALL
+ else
+ lflag[i] = D_MIX
+
+ v2[1] = v1[1]
+ do j = 2, ndim {
+ v2[j] = v1[j] - offsets[i,j]
+ if (v2[j] < 1 || v2[j] > IM_LEN(in[i],j)) {
+ lflag[i] = D_NONE
+ break
+ }
+ }
+ if (project)
+ v2[ndim+1] = i
+
+ if (lflag[i] == D_NONE)
+ next
+
+ if (pm == NULL) {
+ call aclri (Memi[buf], npix)
+ next
+ }
+
+ # Do mask I/O and convert to appropriate values in order of
+ # expected usage.
+
+ if (pm_linenotempty (pm, v2)) {
+ call pm_glpi (pm, v2, Memi[buf], 32, npix, 0)
+
+ if (mtype == M_BOOLEAN)
+ ;
+ else if (mtype == M_BADBITS)
+ call aandki (Memi[buf], mvalue, Memi[buf], npix)
+ else if (mtype == M_BADVAL)
+ call abeqki (Memi[buf], mvalue, Memi[buf], npix)
+ else if (mtype == M_GOODBITS) {
+ call aandki (Memi[buf], mvalue, Memi[buf], npix)
+ call abeqki (Memi[buf], 0, Memi[buf], npix)
+ } else if (mtype == M_GOODVAL)
+ call abneki (Memi[buf], mvalue, Memi[buf], npix)
+
+ lflag[i] = D_NONE
+ do j = 1, npix
+ if (Memi[buf+j-1] == 0) {
+ lflag[i] = D_MIX
+ break
+ }
+ } else {
+ if (mtype == M_BOOLEAN || mtype == M_BADBITS) {
+ call aclri (Memi[buf], npix)
+ } else if ((mtype == M_BADVAL && mvalue != 0) ||
+ (mtype == M_GOODVAL && mvalue == 0)) {
+ call aclri (Memi[buf], npix)
+ } else {
+ call amovki (1, Memi[buf], npix)
+ lflag[i] = D_NONE
+ }
+ }
+ }
+
+ # Set overall data flag
+ dflag = lflag[1]
+ do i = 2, nimages {
+ if (lflag[i] != dflag) {
+ dflag = D_MIX
+ break
+ }
+ }
+end
+
+
+# IC_MGET1 -- Get line of mask pixels from a specified image.
+# This is used by the IC_STAT procedure. This procedure converts the
+# stored mask format to an array where zero is good and nonzero is bad.
+# The data vector and returned mask array are in the input image pixel system.
+
+procedure ic_mget1 (in, image, offset, v, m)
+
+pointer in # Input image pointer
+int image # Image index
+int offset # Column offset
+long v[IM_MAXDIM] # Data vector desired
+pointer m # Pointer to mask
+
+int i, npix
+pointer buf, pm
+bool pm_linenotempty()
+errchk pm_glpi
+
+include "icmask.com"
+include "icombine.com"
+
+begin
+ dflag = D_ALL
+ if (mtype == M_NONE)
+ return
+
+ npix = IM_LEN(in,1)
+ m = Memi[bufs+image-1] + offset
+ pm = Memi[pms+image-1]
+ if (pm == NULL)
+ return
+
+ # Do mask I/O and convert to appropriate values in order of
+ # expected usage.
+
+ buf = m
+ if (pm_linenotempty (pm, v)) {
+ call pm_glpi (pm, v, Memi[buf], 32, npix, 0)
+
+ if (mtype == M_BOOLEAN)
+ ;
+ else if (mtype == M_BADBITS)
+ call aandki (Memi[buf], mvalue, Memi[buf], npix)
+ else if (mtype == M_BADVAL)
+ call abeqki (Memi[buf], mvalue, Memi[buf], npix)
+ else if (mtype == M_GOODBITS) {
+ call aandki (Memi[buf], mvalue, Memi[buf], npix)
+ call abeqki (Memi[buf], 0, Memi[buf], npix)
+ } else if (mtype == M_GOODVAL)
+ call abneki (Memi[buf], mvalue, Memi[buf], npix)
+
+ dflag = D_NONE
+ do i = 1, npix
+ if (Memi[buf+i-1] == 0) {
+ dflag = D_MIX
+ break
+ }
+ } else {
+ if (mtype == M_BOOLEAN || mtype == M_BADBITS) {
+ ;
+ } else if ((mtype == M_BADVAL && mvalue != 0) ||
+ (mtype == M_GOODVAL && mvalue == 0)) {
+ ;
+ } else
+ dflag = D_NONE
+ }
+end
diff --git a/pkg/obsolete/imcombine/icmedian.gx b/pkg/obsolete/imcombine/icmedian.gx
new file mode 100644
index 00000000..b70f4302
--- /dev/null
+++ b/pkg/obsolete/imcombine/icmedian.gx
@@ -0,0 +1,180 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include "../icombine.h"
+
+$for (sird)
+# IC_MEDIAN -- Median of lines
+
+procedure ic_median$t (d, n, npts, doblank, median)
+
+pointer d[ARB] # Input data line pointers
+int n[npts] # Number of good pixels
+int npts # Number of output points per line
+int doblank # Set blank values?
+$if (datatype == sil)
+real median[npts] # Median
+$else
+PIXEL median[npts] # Median
+$endif
+
+int i, j1, j2, j3, k, n1
+bool even
+$if (datatype == silx)
+real val1, val2, val3
+$else
+PIXEL val1, val2, val3
+$endif
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_NONE) {
+ if (doblank == YES) {
+ do i = 1, npts
+ median[i]= blank
+ }
+ return
+ }
+
+ # Check for previous sorting
+ if (mclip) {
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ even = (mod (n1, 2) == 0)
+ j1 = n1 / 2 + 1
+ j2 = n1 / 2
+ do i = 1, npts {
+ k = i - 1
+ if (even) {
+ val1 = Mem$t[d[j1]+k]
+ val2 = Mem$t[d[j2]+k]
+ median[i] = (val1 + val2) / 2.
+ } else
+ median[i] = Mem$t[d[j1]+k]
+ }
+ } else {
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (n1 > 0) {
+ j1 = n1 / 2 + 1
+ if (mod (n1, 2) == 0) {
+ j2 = n1 / 2
+ val1 = Mem$t[d[j1]+k]
+ val2 = Mem$t[d[j2]+k]
+ median[i] = (val1 + val2) / 2.
+ } else
+ median[i] = Mem$t[d[j1]+k]
+ } else if (doblank == YES)
+ median[i] = blank
+ }
+ }
+ return
+ }
+
+ # Repeatedly exchange the extreme values until there are three
+ # or fewer pixels.
+
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ while (n1 > 3) {
+ j1 = 1
+ j2 = 1
+ $if (datatype == x)
+ val1 = abs (Mem$t[d[j1]+k])
+ $else
+ val1 = Mem$t[d[j1]+k]
+ $endif
+ val2 = val1
+ do j3 = 2, n1 {
+ $if (datatype == x)
+ val3 = abs (Mem$t[d[j3]+k])
+ $else
+ val3 = Mem$t[d[j3]+k]
+ $endif
+ if (val3 > val1) {
+ j1 = j3
+ val1 = val3
+ } else if (val3 < val2) {
+ j2 = j3
+ val2 = val3
+ }
+ }
+ j3 = n1 - 1
+ if (j1 < j3 && j2 < j3) {
+ Mem$t[d[j1]+k] = val3
+ Mem$t[d[j2]+k] = Mem$t[d[j3]+k]
+ Mem$t[d[j3]+k] = val1
+ Mem$t[d[n1]+k] = val2
+ } else if (j1 < j3) {
+ if (j2 == j3) {
+ Mem$t[d[j1]+k] = val3
+ Mem$t[d[n1]+k] = val1
+ } else {
+ Mem$t[d[j1]+k] = Mem$t[d[j3]+k]
+ Mem$t[d[j3]+k] = val1
+ }
+ } else if (j2 < j3) {
+ if (j1 == j3) {
+ Mem$t[d[j2]+k] = val3
+ Mem$t[d[n1]+k] = val2
+ } else {
+ Mem$t[d[j2]+k] = Mem$t[d[j3]+k]
+ Mem$t[d[j3]+k] = val2
+ }
+ }
+ n1 = n1 - 2
+ }
+
+ if (n1 == 3) {
+ $if (datatype == x)
+ val1 = abs (Mem$t[d[1]+k])
+ val2 = abs (Mem$t[d[2]+k])
+ val3 = abs (Mem$t[d[3]+k])
+ if (val1 < val2) {
+ if (val2 < val3) # abc
+ median[i] = Mem$t[d[2]+k]
+ else if (val1 < val3) # acb
+ median[i] = Mem$t[d[3]+k]
+ else # cab
+ median[i] = Mem$t[d[1]+k]
+ } else {
+ if (val2 > val3) # cba
+ median[i] = Mem$t[d[2]+k]
+ else if (val1 > val3) # bca
+ median[i] = Mem$t[d[3]+k]
+ else # bac
+ median[i] = Mem$t[d[1]+k]
+ }
+ $else
+ val1 = Mem$t[d[1]+k]
+ val2 = Mem$t[d[2]+k]
+ val3 = Mem$t[d[3]+k]
+ if (val1 < val2) {
+ if (val2 < val3) # abc
+ median[i] = val2
+ else if (val1 < val3) # acb
+ median[i] = val3
+ else # cab
+ median[i] = val1
+ } else {
+ if (val2 > val3) # cba
+ median[i] = val2
+ else if (val1 > val3) # bca
+ median[i] = val3
+ else # bac
+ median[i] = val1
+ }
+ $endif
+ } else if (n1 == 2) {
+ val1 = Mem$t[d[1]+k]
+ val2 = Mem$t[d[2]+k]
+ median[i] = (val1 + val2) / 2
+ } else if (n1 == 1)
+ median[i] = Mem$t[d[1]+k]
+ else if (doblank == YES)
+ median[i] = blank
+ }
+end
+$endfor
diff --git a/pkg/obsolete/imcombine/icmm.gx b/pkg/obsolete/imcombine/icmm.gx
new file mode 100644
index 00000000..10236b92
--- /dev/null
+++ b/pkg/obsolete/imcombine/icmm.gx
@@ -0,0 +1,181 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include "../icombine.h"
+
+$for (sird)
+# IC_MM -- Reject a specified number of high and low pixels
+
+procedure ic_mm$t (d, m, n, npts)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image ID pointers
+int n[npts] # Number of good pixels
+int npts # Number of output points per line
+
+int n1, ncombine, npairs, nlow, nhigh, np
+int i, i1, j, jmax, jmin
+pointer k, kmax, kmin
+PIXEL d1, d2, dmin, dmax
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_NONE)
+ return
+
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ nlow = flow * n1 + 0.001
+ nhigh = fhigh * n1 + 0.001
+ ncombine = n1 - nlow - nhigh
+ npairs = min (nlow, nhigh)
+ nlow = nlow - npairs
+ nhigh = nhigh - npairs
+ }
+
+ do i = 1, npts {
+ i1 = i - 1
+ n1 = n[i]
+ if (dflag == D_MIX) {
+ nlow = flow * n1 + 0.001
+ nhigh = fhigh * n1 + 0.001
+ ncombine = max (ncombine, n1 - nlow - nhigh)
+ npairs = min (nlow, nhigh)
+ nlow = nlow - npairs
+ nhigh = nhigh - npairs
+ }
+
+ # Reject the npairs low and high points.
+ do np = 1, npairs {
+ k = d[1] + i1
+ $if (datatype == x)
+ d1 = abs (Mem$t[k])
+ $else
+ d1 = Mem$t[k]
+ $endif
+ dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k
+ do j = 2, n1 {
+ d2 = d1
+ k = d[j] + i1
+ $if (datatype == x)
+ d1 = abs (Mem$t[k])
+ $else
+ d1 = Mem$t[k]
+ $endif
+ if (d1 > dmax) {
+ dmax = d1; jmax = j; kmax = k
+ } else if (d1 < dmin) {
+ dmin = d1; jmin = j; kmin = k
+ }
+ }
+ j = n1 - 1
+ if (keepids) {
+ if (jmax < j) {
+ if (jmin != j) {
+ Mem$t[kmax] = d2
+ Memi[m[jmax]+i1] = Memi[m[j]+i1]
+ } else {
+ Mem$t[kmax] = d1
+ Memi[m[jmax]+i1] = Memi[m[n1]+i1]
+ }
+ }
+ if (jmin < j) {
+ if (jmax != n1) {
+ Mem$t[kmin] = d1
+ Memi[m[jmin]+i1] = Memi[m[n1]+i1]
+ } else {
+ Mem$t[kmin] = d2
+ Memi[m[jmin]+i1] = Memi[m[j]+i1]
+ }
+ }
+ } else {
+ if (jmax < j) {
+ if (jmin != j)
+ Mem$t[kmax] = d2
+ else
+ Mem$t[kmax] = d1
+ }
+ if (jmin < j) {
+ if (jmax != n1)
+ Mem$t[kmin] = d1
+ else
+ Mem$t[kmin] = d2
+ }
+ }
+ n1 = n1 - 2
+ }
+
+ # Reject the excess low points.
+ do np = 1, nlow {
+ k = d[1] + i1
+ $if (datatype == x)
+ d1 = abs (Mem$t[k])
+ $else
+ d1 = Mem$t[k]
+ $endif
+ dmin = d1; jmin = 1; kmin = k
+ do j = 2, n1 {
+ k = d[j] + i1
+ $if (datatype == x)
+ d1 = abs (Mem$t[k])
+ $else
+ d1 = Mem$t[k]
+ $endif
+ if (d1 < dmin) {
+ dmin = d1; jmin = j; kmin = k
+ }
+ }
+ if (keepids) {
+ if (jmin < n1) {
+ Mem$t[kmin] = d1
+ k = Memi[m[jmin]+i1]
+ Memi[m[jmin]+i1] = Memi[m[n1]+i1]
+ Memi[m[n1]+i1] = k
+ }
+ } else {
+ if (jmin < n1)
+ Mem$t[kmin] = d1
+ }
+ n1 = n1 - 1
+ }
+
+ # Reject the excess high points.
+ do np = 1, nhigh {
+ k = d[1] + i1
+ $if (datatype == x)
+ d1 = abs (Mem$t[k])
+ $else
+ d1 = Mem$t[k]
+ $endif
+ dmax = d1; jmax = 1; kmax = k
+ do j = 2, n1 {
+ k = d[j] + i1
+ $if (datatype == x)
+ d1 = abs (Mem$t[k])
+ $else
+ d1 = Mem$t[k]
+ $endif
+ if (d1 > dmax) {
+ dmax = d1; jmax = j; kmax = k
+ }
+ }
+ if (keepids) {
+ if (jmax < n1) {
+ Mem$t[kmax] = d1
+ k = Memi[m[jmax]+i1]
+ Memi[m[jmax]+i1] = Memi[m[n1]+i1]
+ Memi[m[n1]+i1] = k
+ }
+ } else {
+ if (jmax < n1)
+ Mem$t[kmax] = d1
+ }
+ n1 = n1 - 1
+ }
+ n[i] = n1
+ }
+
+ if (dflag == D_ALL && npairs + nlow + nhigh > 0)
+ dflag = D_MIX
+end
+$endfor
diff --git a/pkg/obsolete/imcombine/icombine.com b/pkg/obsolete/imcombine/icombine.com
new file mode 100644
index 00000000..f0d3b467
--- /dev/null
+++ b/pkg/obsolete/imcombine/icombine.com
@@ -0,0 +1,38 @@
+# ICOMBINE Common
+
+int combine # Combine algorithm
+int reject # Rejection algorithm
+bool project # Combine across the highest dimension?
+real blank # Blank value
+pointer rdnoise # CCD read noise
+pointer gain # CCD gain
+pointer snoise # CCD sensitivity noise
+real lthresh # Low threshold
+real hthresh # High threshold
+int nkeep # Minimum to keep
+real lsigma # Low sigma cutoff
+real hsigma # High sigma cutoff
+real pclip # Number or fraction of pixels from median
+real flow # Fraction of low pixels to reject
+real fhigh # Fraction of high pixels to reject
+real grow # Grow radius
+bool mclip # Use median in sigma clipping?
+real sigscale # Sigma scaling tolerance
+int logfd # Log file descriptor
+
+# These flags allow special conditions to be optimized.
+
+int dflag # Data flag (D_ALL, D_NONE, D_MIX)
+bool aligned # Are the images aligned?
+bool doscale # Do the images have to be scaled?
+bool doscale1 # Do the sigma calculations have to be scaled?
+bool dothresh # Check pixels outside specified thresholds?
+bool dowts # Does the final average have to be weighted?
+bool keepids # Keep track of the image indices?
+bool docombine # Call the combine procedure?
+bool sort # Sort data?
+
+common /imccom/ combine, reject, blank, rdnoise, gain, snoise, lsigma, hsigma,
+ lthresh, hthresh, nkeep, pclip, flow, fhigh, grow, logfd,
+ dflag, sigscale, project, mclip, aligned, doscale, doscale1,
+ dothresh, dowts, keepids, docombine, sort
diff --git a/pkg/obsolete/imcombine/icombine.gx b/pkg/obsolete/imcombine/icombine.gx
new file mode 100644
index 00000000..9cb4cb24
--- /dev/null
+++ b/pkg/obsolete/imcombine/icombine.gx
@@ -0,0 +1,580 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include <imset.h>
+include <pmset.h>
+include <error.h>
+include <syserr.h>
+include <mach.h>
+include "../icombine.h"
+
+
+# ICOMBINE -- Combine images
+#
+# The memory and open file descriptor limits are checked and an attempt
+# to recover is made either by setting the image pixel files to be
+# closed after I/O or by notifying the calling program that memory
+# ran out and the IMIO buffer size should be reduced. After the checks
+# a procedure for the selected combine option is called.
+# Because there may be several failure modes when reaching the file
+# limits we first assume an error is due to the file limit, except for
+# out of memory, and close some pixel files. If the error then repeats
+# on accessing the pixels the error is passed back.
+
+$for (sird)
+procedure icombine$t (in, out, offsets, nimages, bufsize)
+
+pointer in[nimages] # Input images
+pointer out[4] # Output images
+int offsets[nimages,ARB] # Input image offsets
+int nimages # Number of input images
+int bufsize # IMIO buffer size
+
+char str[1]
+int i, j, npts, fd, stropen(), errcode(), imstati()
+pointer sp, d, id, n, m, lflag, scales, zeros, wts, dbuf
+pointer buf, imgl1$t(), impl1i()
+errchk stropen, imgl1$t, impl1i
+$if (datatype == sil)
+pointer impl1r()
+errchk impl1r
+$else
+pointer impl1$t()
+errchk impl1$t
+$endif
+
+include "../icombine.com"
+
+begin
+ npts = IM_LEN(out[1],1)
+
+ # Allocate memory.
+ call smark (sp)
+ call salloc (dbuf, nimages, TY_POINTER)
+ call salloc (d, nimages, TY_POINTER)
+ call salloc (id, nimages, TY_POINTER)
+ call salloc (n, npts, TY_INT)
+ call salloc (m, nimages, TY_POINTER)
+ call salloc (lflag, nimages, TY_INT)
+ call salloc (scales, nimages, TY_REAL)
+ call salloc (zeros, nimages, TY_REAL)
+ call salloc (wts, nimages, TY_REAL)
+ call amovki (D_ALL, Memi[lflag], nimages)
+
+ # If not aligned or growing create data buffers of output length
+ # otherwise use the IMIO buffers.
+
+ if (!aligned || grow >= 1.) {
+ do i = 1, nimages
+ call salloc (Memi[dbuf+i-1], npts, TY_PIXEL)
+ } else
+ call amovki (NULL, Memi[dbuf], nimages)
+
+ if (project) {
+ call imseti (in[1], IM_NBUFS, nimages)
+ call imseti (in[1], IM_BUFSIZE, bufsize)
+ do i = 1, 3 {
+ if (out[i] != NULL)
+ call imseti (out[i], IM_BUFSIZE, bufsize)
+ }
+ } else {
+ # Reserve FD for string operations.
+ fd = stropen (str, 1, NEW_FILE)
+
+ # Do I/O to the images.
+ do i = 1, 3 {
+ if (out[i] != NULL)
+ call imseti (out[i], IM_BUFSIZE, bufsize)
+ }
+ $if (datatype == sil)
+ buf = impl1r (out[1])
+ call aclrr (Memr[buf], npts)
+ if (out[3] != NULL) {
+ buf = impl1r (out[3])
+ call aclrr (Memr[buf], npts)
+ }
+ $else
+ buf = impl1$t (out[1])
+ call aclr$t (Mem$t[buf], npts)
+ if (out[3] != NULL) {
+ buf = impl1$t (out[3])
+ call aclr$t (Mem$t[buf], npts)
+ }
+ $endif
+ if (out[2] != NULL) {
+ buf = impl1i (out[2])
+ call aclri (Memi[buf], npts)
+ }
+
+ do i = 1, nimages {
+ call imseti (in[i], IM_BUFSIZE, bufsize)
+ iferr (buf = imgl1$t (in[i])) {
+ switch (errcode()) {
+ case SYS_MFULL:
+ call sfree (sp)
+ call strclose (fd)
+ call erract (EA_ERROR)
+ case SYS_FTOOMANYFILES, SYS_IKIOPIX:
+ if (imstati (in[i], IM_CLOSEFD) == YES) {
+ call sfree (sp)
+ call strclose (fd)
+ call erract (EA_ERROR)
+ }
+ do j = i-2, nimages
+ call imseti (in[j], IM_CLOSEFD, YES)
+ buf = imgl1$t (in[i])
+ default:
+ call sfree (sp)
+ call strclose (fd)
+ call erract (EA_ERROR)
+ }
+ }
+ }
+
+ call strclose (fd)
+ }
+
+ call ic_combine$t (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n],
+ Memi[m], Memi[lflag], offsets, Memr[scales], Memr[zeros],
+ Memr[wts], nimages, npts)
+end
+
+
+# IC_COMBINE -- Combine images.
+
+procedure ic_combine$t (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, wts, nimages, npts)
+
+pointer in[nimages] # Input images
+pointer out[4] # Output image
+pointer dbuf[nimages] # Data buffers for nonaligned images
+pointer d[nimages] # Data pointers
+pointer id[nimages] # Image index ID pointers
+int n[npts] # Number of good pixels
+pointer m[nimages] # Mask pointers
+int lflag[nimages] # Line flags
+int offsets[nimages,ARB] # Input image offsets
+real scales[nimages] # Scale factors
+real zeros[nimages] # Zero offset factors
+real wts[nimages] # Combining weights
+int nimages # Number of input images
+int npts # Number of points per output line
+
+int i, ext, ctor(), ic_qsort(), errcode()
+real r, imgetr()
+pointer sp, fname, imname, v1, v2, v3, work
+pointer outdata, buf, nm, pms
+pointer immap(), impnli()
+$if (datatype == sil)
+pointer impnlr(), imgnlr()
+$else
+pointer impnl$t(), imgnl$t
+$endif
+errchk immap, ic_scale, imgetr, ic_grow, ic_grow$t, ic_rmasks
+extern ic_qsort
+
+include "../icombine.com"
+data ext/0/
+
+begin
+ call smark (sp)
+ call salloc (fname, SZ_FNAME, TY_CHAR)
+ call salloc (imname, SZ_FNAME, TY_CHAR)
+ call salloc (v1, IM_MAXDIM, TY_LONG)
+ call salloc (v2, IM_MAXDIM, TY_LONG)
+ call salloc (v3, IM_MAXDIM, TY_LONG)
+ call amovkl (long(1), Meml[v1], IM_MAXDIM)
+ call amovkl (long(1), Meml[v2], IM_MAXDIM)
+ call amovkl (long(1), Meml[v3], IM_MAXDIM)
+
+ call ic_scale (in, out, offsets, scales, zeros, wts, nimages)
+
+ # Set combine parameters
+ switch (combine) {
+ case AVERAGE:
+ if (dowts)
+ keepids = true
+ else
+ keepids = false
+ case MEDIAN:
+ dowts = false
+ keepids = false
+ }
+ docombine = true
+
+ # Set rejection algorithm specific parameters
+ switch (reject) {
+ case CCDCLIP, CRREJECT:
+ call salloc (nm, 3*nimages, TY_REAL)
+ i = 1
+ if (ctor (Memc[rdnoise], i, r) > 0) {
+ do i = 1, nimages
+ Memr[nm+3*(i-1)] = r
+ } else {
+ do i = 1, nimages
+ Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise])
+ }
+ i = 1
+ if (ctor (Memc[gain], i, r) > 0) {
+ do i = 1, nimages {
+ Memr[nm+3*(i-1)+1] = r
+ Memr[nm+3*(i-1)] =
+ max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL)
+ }
+ } else {
+ do i = 1, nimages {
+ r = imgetr (in[i], Memc[gain])
+ Memr[nm+3*(i-1)+1] = r
+ Memr[nm+3*(i-1)] =
+ max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL)
+ }
+ }
+ i = 1
+ if (ctor (Memc[snoise], i, r) > 0) {
+ do i = 1, nimages
+ Memr[nm+3*(i-1)+2] = r
+ } else {
+ do i = 1, nimages {
+ r = imgetr (in[i], Memc[snoise])
+ Memr[nm+3*(i-1)+2] = r
+ }
+ }
+ if (!keepids) {
+ if (doscale1)
+ keepids = true
+ else {
+ do i = 2, nimages {
+ if (Memr[nm+3*(i-1)] != Memr[nm] ||
+ Memr[nm+3*(i-1)+1] != Memr[nm+1] ||
+ Memr[nm+3*(i-1)+2] != Memr[nm+2]) {
+ keepids = true
+ break
+ }
+ }
+ }
+ }
+ if (reject == CRREJECT)
+ lsigma = MAX_REAL
+ case MINMAX:
+ mclip = false
+ case PCLIP:
+ mclip = true
+ case AVSIGCLIP, SIGCLIP:
+ if (doscale1)
+ keepids = true
+ case NONE:
+ mclip = false
+ }
+
+ if (out[4] != NULL)
+ keepids = true
+
+ if (grow >= 1.) {
+ keepids = true
+ call salloc (work, npts * nimages, TY_INT)
+ }
+ pms = NULL
+
+ if (keepids) {
+ do i = 1, nimages
+ call salloc (id[i], npts, TY_INT)
+ }
+
+ $if (datatype == sil)
+ while (impnlr (out[1], outdata, Meml[v1]) != EOF) {
+ call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, nimages, npts, Meml[v2], Meml[v3])
+
+ switch (reject) {
+ case CCDCLIP, CRREJECT:
+ if (mclip)
+ call ic_mccdclip$t (d, id, n, scales, zeros, Memr[nm],
+ nimages, npts, Memr[outdata])
+ else
+ call ic_accdclip$t (d, id, n, scales, zeros, Memr[nm],
+ nimages, npts, Memr[outdata])
+ case MINMAX:
+ call ic_mm$t (d, id, n, npts)
+ case PCLIP:
+ call ic_pclip$t (d, id, n, nimages, npts, Memr[outdata])
+ case SIGCLIP:
+ if (mclip)
+ call ic_msigclip$t (d, id, n, scales, zeros, nimages, npts,
+ Memr[outdata])
+ else
+ call ic_asigclip$t (d, id, n, scales, zeros, nimages, npts,
+ Memr[outdata])
+ case AVSIGCLIP:
+ if (mclip)
+ call ic_mavsigclip$t (d, id, n, scales, zeros, nimages,
+ npts, Memr[outdata])
+ else
+ call ic_aavsigclip$t (d, id, n, scales, zeros, nimages,
+ npts, Memr[outdata])
+ }
+
+ if (pms == NULL || nkeep > 0) {
+ if (docombine) {
+ switch (combine) {
+ case AVERAGE:
+ call ic_average$t (d, id, n, wts, npts, YES,
+ Memr[outdata])
+ case MEDIAN:
+ call ic_median$t (d, n, npts, YES, Memr[outdata])
+ }
+ }
+ }
+
+ if (grow >= 1.)
+ call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts,
+ pms)
+
+ if (pms == NULL) {
+ if (out[2] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnli (out[2], buf, Meml[v1])
+ call amovki (nimages, Memi[buf], npts)
+ call asubi (Memi[buf], n, Memi[buf], npts)
+ }
+
+ if (out[3] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnlr (out[3], buf, Meml[v1])
+ call ic_sigma$t (d, id, n, wts, npts, Memr[outdata],
+ Memr[buf])
+ }
+
+ if (out[4] != NULL)
+ call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts)
+ }
+
+ call amovl (Meml[v1], Meml[v2], IM_MAXDIM)
+ }
+ $else
+ while (impnl$t (out[1], outdata, Meml[v1]) != EOF) {
+ call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, nimages, npts, Meml[v2], Meml[v3])
+
+ switch (reject) {
+ case CCDCLIP, CRREJECT:
+ if (mclip)
+ call ic_mccdclip$t (d, id, n, scales, zeros, Memr[nm],
+ nimages, npts, Mem$t[outdata])
+ else
+ call ic_accdclip$t (d, id, n, scales, zeros, Memr[nm],
+ nimages, npts, Mem$t[outdata])
+ case MINMAX:
+ call ic_mm$t (d, id, n, npts)
+ case PCLIP:
+ call ic_pclip$t (d, id, n, nimages, npts, Mem$t[outdata])
+ case SIGCLIP:
+ if (mclip)
+ call ic_msigclip$t (d, id, n, scales, zeros, nimages, npts,
+ Mem$t[outdata])
+ else
+ call ic_asigclip$t (d, id, n, scales, zeros, nimages, npts,
+ Mem$t[outdata])
+ case AVSIGCLIP:
+ if (mclip)
+ call ic_mavsigclip$t (d, id, n, scales, zeros, nimages,
+ npts, Mem$t[outdata])
+ else
+ call ic_aavsigclip$t (d, id, n, scales, zeros, nimages,
+ npts, Mem$t[outdata])
+ }
+
+ if (pms == NULL || nkeep > 0) {
+ if (docombine) {
+ switch (combine) {
+ case AVERAGE:
+ call ic_average$t (d, id, n, wts, npts, YES,
+ Mem$t[outdata])
+ case MEDIAN:
+ call ic_median$t (d, n, npts, YES, Mem$t[outdata])
+ }
+ }
+ }
+
+ if (grow >= 1.)
+ call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts,
+ pms)
+
+ if (pms == NULL) {
+ if (out[2] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnli (out[2], buf, Meml[v1])
+ call amovki (nimages, Memi[buf], npts)
+ call asubi (Memi[buf], n, Memi[buf], npts)
+ }
+
+ if (out[3] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnl$t (out[3], buf, Meml[v1])
+ call ic_sigma$t (d, id, n, wts, npts, Mem$t[outdata],
+ Mem$t[buf])
+ }
+
+ if (out[4] != NULL)
+ call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts)
+ }
+
+ call amovl (Meml[v1], Meml[v2], IM_MAXDIM)
+ }
+ $endif
+
+ if (pms != NULL) {
+ if (nkeep > 0) {
+ call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME)
+ call imunmap (out[1])
+ iferr (buf = immap (Memc[fname], READ_WRITE, 0)) {
+ switch (errcode()) {
+ case SYS_FXFOPNOEXTNV:
+ call imgcluster (Memc[fname], Memc[fname], SZ_FNAME)
+ ext = ext + 1
+ call sprintf (Memc[imname], SZ_FNAME, "%s[%d]")
+ call pargstr (Memc[fname])
+ call pargi (ext)
+ iferr (buf = immap (Memc[imname], READ_WRITE, 0)) {
+ buf = NULL
+ ext = 0
+ }
+ repeat {
+ call sprintf (Memc[imname], SZ_FNAME, "%s[%d]")
+ call pargstr (Memc[fname])
+ call pargi (ext+1)
+ iferr (outdata = immap (Memc[imname],READ_WRITE,0))
+ break
+ if (buf != NULL)
+ call imunmap (buf)
+ buf = outdata
+ ext = ext + 1
+ }
+ default:
+ call erract (EA_ERROR)
+ }
+ }
+ out[1] = buf
+ }
+
+ call amovkl (long(1), Meml[v1], IM_MAXDIM)
+ call amovkl (long(1), Meml[v2], IM_MAXDIM)
+ call amovkl (long(1), Meml[v3], IM_MAXDIM)
+ $if (datatype == sil)
+ while (impnlr (out[1], outdata, Meml[v1]) != EOF) {
+ call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, nimages, npts, Meml[v2], Meml[v3])
+
+ call ic_grow$t (Meml[v2], d, id, n, Memi[work], nimages, npts,
+ pms)
+
+ if (nkeep > 0) {
+ do i = 1, npts {
+ if (n[i] < nkeep) {
+ Meml[v1+1] = Meml[v1+1] - 1
+ if (imgnlr (out[1], buf, Meml[v1]) == EOF)
+ ;
+ call amovr (Memr[buf], Memr[outdata], npts)
+ break
+ }
+ }
+ }
+
+ switch (combine) {
+ case AVERAGE:
+ call ic_average$t (d, id, n, wts, npts, NO, Memr[outdata])
+ case MEDIAN:
+ call ic_median$t (d, n, npts, NO, Memr[outdata])
+ }
+
+ if (out[2] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnli (out[2], buf, Meml[v1])
+ call amovki (nimages, Memi[buf], npts)
+ call asubi (Memi[buf], n, Memi[buf], npts)
+ }
+
+ if (out[3] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnlr (out[3], buf, Meml[v1])
+ call ic_sigma$t (d, id, n, wts, npts, Memr[outdata],
+ Memr[buf])
+ }
+
+ if (out[4] != NULL)
+ call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts)
+
+ call amovl (Meml[v1], Meml[v2], IM_MAXDIM)
+ }
+ $else
+ while (impnl$t (out[1], outdata, Meml[v1]) != EOF) {
+ call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets,
+ scales, zeros, nimages, npts, Meml[v2], Meml[v3])
+
+ call ic_grow$t (Meml[v2], d, id, n, Memi[work], nimages, npts,
+ pms)
+
+ if (nkeep > 0) {
+ do i = 1, npts {
+ if (n[i] < nkeep) {
+ Meml[v1+1] = Meml[v1+1] - 1
+ if (imgnl$t (out[1], buf, Meml[v1]) == EOF)
+ ;
+ call amov$t (Mem$t[buf], Mem$t[outdata], npts)
+ break
+ }
+ }
+ }
+
+ switch (combine) {
+ case AVERAGE:
+ call ic_average$t (d, id, n, wts, npts, NO, Mem$t[outdata])
+ case MEDIAN:
+ call ic_median$t (d, n, npts, NO, Mem$t[outdata])
+ }
+
+ if (out[2] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnli (out[2], buf, Meml[v1])
+ call amovki (nimages, Memi[buf], npts)
+ call asubi (Memi[buf], n, Memi[buf], npts)
+ }
+
+ if (out[3] != NULL) {
+ call amovl (Meml[v2], Meml[v1], IM_MAXDIM)
+ i = impnl$t (out[3], buf, Meml[v1])
+ call ic_sigma$t (d, id, n, wts, npts, Mem$t[outdata],
+ Mem$t[buf])
+ }
+
+ if (out[4] != NULL)
+ call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts)
+
+ call amovl (Meml[v1], Meml[v2], IM_MAXDIM)
+ }
+ $endif
+
+ do i = 1, nimages
+ call pm_close (Memi[pms+i-1])
+ call mfree (pms, TY_POINTER)
+ }
+
+ call sfree (sp)
+end
+$endfor
+
+
+# IC_QSORT -- Compare line numbers for GQSORT.
+
+int procedure ic_qsort (arg, i1, i2)
+
+pointer arg
+int i1, i2
+
+begin
+ if (Mems[arg+i1-1] < Mems[arg+i2-1])
+ return (-1)
+ else if (Mems[arg+i1-1] > Mems[arg+i2-1])
+ return (1)
+ else
+ return (0)
+end
diff --git a/pkg/obsolete/imcombine/icombine.h b/pkg/obsolete/imcombine/icombine.h
new file mode 100644
index 00000000..13b77117
--- /dev/null
+++ b/pkg/obsolete/imcombine/icombine.h
@@ -0,0 +1,52 @@
+# ICOMBINE Definitions
+
+# Memory management parameters;
+define DEFBUFSIZE 65536 # default IMIO buffer size
+define FUDGE 0.8 # fudge factor
+
+# Rejection options:
+define REJECT "|none|ccdclip|crreject|minmax|pclip|sigclip|avsigclip|"
+define NONE 1 # No rejection algorithm
+define CCDCLIP 2 # CCD noise function clipping
+define CRREJECT 3 # CCD noise function clipping
+define MINMAX 4 # Minmax rejection
+define PCLIP 5 # Percentile clip
+define SIGCLIP 6 # Sigma clip
+define AVSIGCLIP 7 # Sigma clip with average poisson sigma
+
+# Combine options:
+define COMBINE "|average|median|"
+define AVERAGE 1
+define MEDIAN 2
+
+# Scaling options:
+define STYPES "|none|mode|median|mean|exposure|"
+define ZTYPES "|none|mode|median|mean|"
+define WTYPES "|none|mode|median|mean|exposure|"
+define S_NONE 1
+define S_MODE 2
+define S_MEDIAN 3
+define S_MEAN 4
+define S_EXPOSURE 5
+define S_FILE 6
+define S_KEYWORD 7
+define S_SECTION "|input|output|overlap|"
+define S_INPUT 1
+define S_OUTPUT 2
+define S_OVERLAP 3
+
+# Mask options
+define MASKTYPES "|none|goodvalue|badvalue|goodbits|badbits|"
+define M_NONE 1 # Don't use mask images
+define M_GOODVAL 2 # Value selecting good pixels
+define M_BADVAL 3 # Value selecting bad pixels
+define M_GOODBITS 4 # Bits selecting good pixels
+define M_BADBITS 5 # Bits selecting bad pixels
+define M_BOOLEAN -1 # Ignore mask values
+
+# Data flag
+define D_ALL 0 # All pixels are good
+define D_NONE 1 # All pixels are bad or rejected
+define D_MIX 2 # Mixture of good and bad pixels
+
+define TOL 0.001 # Tolerance for equal residuals
diff --git a/pkg/obsolete/imcombine/icpclip.gx b/pkg/obsolete/imcombine/icpclip.gx
new file mode 100644
index 00000000..f0c76369
--- /dev/null
+++ b/pkg/obsolete/imcombine/icpclip.gx
@@ -0,0 +1,233 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include "../icombine.h"
+
+define MINCLIP 3 # Minimum number for clipping
+
+$for (sird)
+# IC_PCLIP -- Percentile clip
+#
+# 1) Find the median
+# 2) Find the pixel which is the specified order index away
+# 3) Use the data value difference as a sigma and apply clipping
+# 4) Since the median is known return it so it does not have to be recomputed
+
+procedure ic_pclip$t (d, m, n, nimages, npts, median)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image id pointers
+int n[npts] # Number of good pixels
+int nimages # Number of input images
+int npts # Number of output points per line
+$if (datatype == sil)
+real median[npts] # Median
+$else
+PIXEL median[npts] # Median
+$endif
+
+int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep
+bool even, fp_equalr()
+real sigma, r, s, t
+pointer sp, resid, mp1, mp2
+$if (datatype == sil)
+real med
+$else
+PIXEL med
+$endif
+
+include "../icombine.com"
+
+begin
+ # There must be at least MINCLIP and more than nkeep pixels.
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+
+ # Set sign of pclip parameter
+ if (pclip < 0)
+ t = -1.
+ else
+ t = 1.
+
+ # If there are no rejected pixels compute certain parameters once.
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ n2 = 1 + n1 / 2
+ even = (mod (n1, 2) == 0)
+ if (pclip < 0.) {
+ if (even)
+ n3 = max (1, nint (n2 - 1 + pclip))
+ else
+ n3 = max (1, nint (n2 + pclip))
+ } else
+ n3 = min (n1, nint (n2 + pclip))
+ nin = n1
+ }
+
+ # Now apply clipping.
+ do i = 1, npts {
+ # Compute median.
+ if (dflag == D_MIX) {
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ if (n1 == 0) {
+ if (combine == MEDIAN)
+ median[i] = blank
+ next
+ }
+ n2 = 1 + n1 / 2
+ even = (mod (n1, 2) == 0)
+ if (pclip < 0) {
+ if (even)
+ n3 = max (1, nint (n2 - 1 + pclip))
+ else
+ n3 = max (1, nint (n2 + pclip))
+ } else
+ n3 = min (n1, nint (n2 + pclip))
+ }
+
+ j = i - 1
+ if (even) {
+ med = Mem$t[d[n2-1]+j]
+ med = (med + Mem$t[d[n2]+j]) / 2.
+ } else
+ med = Mem$t[d[n2]+j]
+
+ if (n1 < max (MINCLIP, maxkeep+1)) {
+ if (combine == MEDIAN)
+ median[i] = med
+ next
+ }
+
+ # Define sigma for clipping
+ sigma = t * (Mem$t[d[n3]+j] - med)
+ if (fp_equalr (sigma, 0.)) {
+ if (combine == MEDIAN)
+ median[i] = med
+ next
+ }
+
+ # Reject pixels and save residuals.
+ # Check if any pixels are clipped.
+ # If so recompute the median and reset the number of good pixels.
+ # Only reorder if needed.
+
+ for (nl=1; nl<=n1; nl=nl+1) {
+ r = (med - Mem$t[d[nl]+j]) / sigma
+ if (r < lsigma)
+ break
+ Memr[resid+nl] = r
+ }
+ for (nh=n1; nh>=1; nh=nh-1) {
+ r = (Mem$t[d[nh]+j] - med) / sigma
+ if (r < hsigma)
+ break
+ Memr[resid+nh] = r
+ }
+ n4 = nh - nl + 1
+
+ # If too many pixels are rejected add some back in.
+ # All pixels with the same residual are added.
+ while (n4 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n4 = nh - nl + 1
+ }
+
+ # If any pixels are rejected recompute the median.
+ if (nl > 1 || nh < n1) {
+ n5 = nl + n4 / 2
+ if (mod (n4, 2) == 0) {
+ med = Mem$t[d[n5-1]+j]
+ med = (med + Mem$t[d[n5]+j]) / 2.
+ } else
+ med = Mem$t[d[n5]+j]
+ n[i] = n4
+ }
+ if (combine == MEDIAN)
+ median[i] = med
+
+ # Reorder if pixels only if necessary.
+ if (nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ k = max (nl, n4 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Mem$t[d[l]+j] = Mem$t[d[k]+j]
+ if (grow >= 1.) {
+ mp1 = m[l] + j
+ mp2 = m[k] + j
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+j] = Memi[m[k]+j]
+ k = k + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Mem$t[d[l]+j] = Mem$t[d[k]+j]
+ k = k + 1
+ }
+ }
+ }
+ }
+
+ # Check if data flag needs to be reset for rejected pixels.
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag whether the median has been computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+$endfor
diff --git a/pkg/obsolete/imcombine/icrmasks.x b/pkg/obsolete/imcombine/icrmasks.x
new file mode 100644
index 00000000..8b9a0c3d
--- /dev/null
+++ b/pkg/obsolete/imcombine/icrmasks.x
@@ -0,0 +1,41 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+
+
+# IC_RMASKS -- Set pixels for rejection mask.
+
+procedure ic_rmasks (pm, v, id, nimages, n, npts)
+
+pointer pm #I Pixel mask
+long v[ARB] #I Output vector (input)
+pointer id[nimages] #I Image id pointers
+int nimages #I Number of images
+int n[npts] #I Number of good pixels
+int npts #I Number of output points per line
+
+int i, j, k, ndim, impnls()
+long v1[IM_MAXDIM]
+pointer buf
+
+begin
+ ndim = IM_NDIM(pm)
+ do k = 1, nimages {
+ call amovl (v, v1, ndim-1)
+ v1[ndim] = k
+ i = impnls (pm, buf, v1)
+ do j = 1, npts {
+ if (n[j] == nimages)
+ Mems[buf+j-1] = 0
+ else {
+ Mems[buf+j-1] = 1
+ do i = 1, n[j] {
+ if (Memi[id[i]+j-1] == k) {
+ Mems[buf+j-1] = 0
+ break
+ }
+ }
+ }
+ }
+ }
+end
diff --git a/pkg/obsolete/imcombine/icscale.x b/pkg/obsolete/imcombine/icscale.x
new file mode 100644
index 00000000..5f4194e6
--- /dev/null
+++ b/pkg/obsolete/imcombine/icscale.x
@@ -0,0 +1,358 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include <imset.h>
+include <error.h>
+include "icombine.h"
+
+# IC_SCALE -- Get the scale factors for the images.
+# 1. This procedure does CLIO to determine the type of scaling desired.
+# 2. The output header parameters for exposure time and NCOMBINE are set.
+
+procedure ic_scale (in, out, offsets, scales, zeros, wts, nimages)
+
+pointer in[nimages] # Input images
+pointer out[3] # Output images
+int offsets[nimages,ARB] # Image offsets
+real scales[nimages] # Scale factors
+real zeros[nimages] # Zero or sky levels
+real wts[nimages] # Weights
+int nimages # Number of images
+
+int stype, ztype, wtype
+int i, j, k, l, nout
+real mode, median, mean, exposure, zmean
+pointer sp, ncombine, exptime, modes, medians, means, expname
+pointer section, str, sname, zname, wname, imref
+bool domode, domedian, domean, dozero, snorm, znorm, wflag
+
+int imgeti(), strdic(), ic_gscale()
+real imgetr(), asumr(), asumi()
+errchk ic_gscale, ic_statr
+
+include "icombine.com"
+
+begin
+ call smark (sp)
+ call salloc (ncombine, nimages, TY_INT)
+ call salloc (exptime, nimages, TY_REAL)
+ call salloc (modes, nimages, TY_REAL)
+ call salloc (medians, nimages, TY_REAL)
+ call salloc (means, nimages, TY_REAL)
+ call salloc (expname, SZ_FNAME, TY_CHAR)
+ call salloc (section, SZ_FNAME, TY_CHAR)
+ call salloc (str, SZ_LINE, TY_CHAR)
+ call salloc (sname, SZ_FNAME, TY_CHAR)
+ call salloc (zname, SZ_FNAME, TY_CHAR)
+ call salloc (wname, SZ_FNAME, TY_CHAR)
+
+ # Set the defaults.
+ call amovki (1, Memi[ncombine], nimages)
+ call amovkr (0., Memr[exptime], nimages)
+ call amovkr (INDEF, Memr[modes], nimages)
+ call amovkr (INDEF, Memr[medians], nimages)
+ call amovkr (INDEF, Memr[means], nimages)
+ call amovkr (1., scales, nimages)
+ call amovkr (0., zeros, nimages)
+ call amovkr (1., wts, nimages)
+
+ # Get the number of images previously combined and the exposure times.
+ # The default combine number is 1 and the default exposure is 0.
+
+ call clgstr ("expname", Memc[expname], SZ_FNAME)
+ do i = 1, nimages {
+ iferr (Memi[ncombine+i-1] = imgeti (in[i], "ncombine"))
+ Memi[ncombine+i-1] = 1
+ if (Memc[expname] != EOS) {
+ iferr (Memr[exptime+i-1] = imgetr (in[i], Memc[expname]))
+ Memr[exptime+i-1] = 0.
+ }
+ if (project) {
+ call amovki (Memi[ncombine], Memi[ncombine], nimages)
+ call amovkr (Memr[exptime], Memr[exptime], nimages)
+ break
+ }
+ }
+
+ # Set scaling factors.
+
+ stype = ic_gscale ("scale", Memc[sname], STYPES, in, Memr[exptime],
+ scales, nimages)
+ ztype = ic_gscale ("zero", Memc[zname], ZTYPES, in, Memr[exptime],
+ zeros, nimages)
+ wtype = ic_gscale ("weight", Memc[wname], WTYPES, in, Memr[exptime],
+ wts, nimages)
+
+ # Get image statistics only if needed.
+ domode = ((stype==S_MODE)||(ztype==S_MODE)||(wtype==S_MODE))
+ domedian = ((stype==S_MEDIAN)||(ztype==S_MEDIAN)||(wtype==S_MEDIAN))
+ domean = ((stype==S_MEAN)||(ztype==S_MEAN)||(wtype==S_MEAN))
+ if (domode || domedian || domean) {
+ Memc[section] = EOS
+ Memc[str] = EOS
+ call clgstr ("statsec", Memc[section], SZ_FNAME)
+ call sscan (Memc[section])
+ call gargwrd (Memc[section], SZ_FNAME)
+ call gargwrd (Memc[str], SZ_LINE)
+
+ i = strdic (Memc[section], Memc[section], SZ_FNAME, S_SECTION)
+ switch (i) {
+ case S_INPUT:
+ call strcpy (Memc[str], Memc[section], SZ_FNAME)
+ imref = NULL
+ case S_OUTPUT:
+ call strcpy (Memc[str], Memc[section], SZ_FNAME)
+ imref = out[1]
+ case S_OVERLAP:
+ call strcpy ("[", Memc[section], SZ_FNAME)
+ do i = 1, IM_NDIM(out[1]) {
+ k = offsets[1,i] + 1
+ l = offsets[1,i] + IM_LEN(in[1],i)
+ do j = 2, nimages {
+ k = max (k, offsets[j,i]+1)
+ l = min (l, offsets[j,i]+IM_LEN(in[j],i))
+ }
+ if (i < IM_NDIM(out[1]))
+ call sprintf (Memc[str], SZ_LINE, "%d:%d,")
+ else
+ call sprintf (Memc[str], SZ_LINE, "%d:%d]")
+ call pargi (k)
+ call pargi (l)
+ call strcat (Memc[str], Memc[section], SZ_FNAME)
+ }
+ imref = out[1]
+ default:
+ imref = NULL
+ }
+
+ do i = 1, nimages {
+ if (imref != out[1])
+ imref = in[i]
+ call ic_statr (in[i], imref, Memc[section], offsets,
+ i, nimages, domode, domedian, domean, mode, median, mean)
+ if (domode) {
+ Memr[modes+i-1] = mode
+ if (stype == S_MODE)
+ scales[i] = mode
+ if (ztype == S_MODE)
+ zeros[i] = mode
+ if (wtype == S_MODE)
+ wts[i] = mode
+ }
+ if (domedian) {
+ Memr[medians+i-1] = median
+ if (stype == S_MEDIAN)
+ scales[i] = median
+ if (ztype == S_MEDIAN)
+ zeros[i] = median
+ if (wtype == S_MEDIAN)
+ wts[i] = median
+ }
+ if (domean) {
+ Memr[means+i-1] = mean
+ if (stype == S_MEAN)
+ scales[i] = mean
+ if (ztype == S_MEAN)
+ zeros[i] = mean
+ if (wtype == S_MEAN)
+ wts[i] = mean
+ }
+ }
+ }
+
+ do i = 1, nimages
+ if (scales[i] <= 0.) {
+ call eprintf ("WARNING: Negative scale factors")
+ call eprintf (" -- ignoring scaling\n")
+ call amovkr (1., scales, nimages)
+ break
+ }
+
+ # Convert to relative factors if needed.
+ snorm = (stype == S_FILE || stype == S_KEYWORD)
+ znorm = (ztype == S_FILE || ztype == S_KEYWORD)
+ wflag = (wtype == S_FILE || wtype == S_KEYWORD)
+ if (snorm)
+ call arcpr (1., scales, scales, nimages)
+ else {
+ mean = asumr (scales, nimages) / nimages
+ call adivkr (scales, mean, scales, nimages)
+ }
+ call adivr (zeros, scales, zeros, nimages)
+ zmean = asumr (zeros, nimages) / nimages
+
+ if (wtype != S_NONE) {
+ do i = 1, nimages {
+ if (wts[i] <= 0.) {
+ call eprintf ("WARNING: Negative weights")
+ call eprintf (" -- using only NCOMBINE weights\n")
+ do j = 1, nimages
+ wts[j] = Memi[ncombine+j-1]
+ break
+ }
+ if (ztype == S_NONE || znorm || wflag)
+ wts[i] = Memi[ncombine+i-1] * wts[i]
+ else {
+ if (zeros[i] <= 0.) {
+ call eprintf ("WARNING: Negative zero offsets")
+ call eprintf (" -- ignoring zero weight adjustments\n")
+ do j = 1, nimages
+ wts[j] = Memi[ncombine+j-1] * wts[j]
+ break
+ }
+ wts[i] = Memi[ncombine+i-1] * wts[i] * zmean / zeros[i]
+ }
+ }
+ }
+
+ if (znorm)
+ call anegr (zeros, zeros, nimages)
+ else {
+ # Because of finite arithmetic it is possible for the zero offsets
+ # to be nonzero even when they are all equal. Just for the sake of
+ # a nice log set the zero offsets in this case.
+
+ call asubkr (zeros, zmean, zeros, nimages)
+ for (i=2; (i<=nimages)&&(zeros[i]==zeros[1]); i=i+1)
+ ;
+ if (i > nimages)
+ call aclrr (zeros, nimages)
+ }
+ mean = asumr (wts, nimages)
+ call adivkr (wts, mean, wts, nimages)
+
+ # Set flags for scaling, zero offsets, sigma scaling, weights.
+ # Sigma scaling may be suppressed if the scales or zeros are
+ # different by a specified tolerance.
+
+ doscale = false
+ dozero = false
+ doscale1 = false
+ dowts = false
+ do i = 2, nimages {
+ if (snorm || scales[i] != scales[1])
+ doscale = true
+ if (znorm || zeros[i] != zeros[1])
+ dozero = true
+ if (wts[i] != wts[1])
+ dowts = true
+ }
+ if (doscale && sigscale != 0.) {
+ do i = 1, nimages {
+ if (abs (scales[i] - 1) > sigscale) {
+ doscale1 = true
+ break
+ }
+ }
+ if (!doscale1 && zmean > 0) {
+ do i = 1, nimages {
+ if (abs (zeros[i] / zmean) > sigscale) {
+ doscale1 = true
+ break
+ }
+ }
+ }
+ }
+
+ # Set the output header parameters.
+ nout = asumi (Memi[ncombine], nimages)
+ call imaddi (out[1], "ncombine", nout)
+ if (Memc[expname] != EOS) {
+ exposure = 0.
+ do i = 1, nimages
+ exposure = exposure + wts[i] * Memr[exptime+i-1] / scales[i]
+ call imaddr (out[1], Memc[expname], exposure)
+ } else
+ exposure = INDEF
+ if (out[2] != NULL) {
+ call imstats (out[2], IM_IMAGENAME, Memc[str], SZ_FNAME)
+ call imastr (out[1], "BPM", Memc[str])
+ }
+ ifnoerr (mode = imgetr (out[1], "CCDMEAN"))
+ call imdelf (out[1], "CCDMEAN")
+
+ # Start the log here since much of the info is only available here.
+ call ic_log (in, out, Memi[ncombine], Memr[exptime], Memc[sname],
+ Memc[zname], Memc[wname], Memr[modes], Memr[medians], Memr[means],
+ scales, zeros, wts, offsets, nimages, dozero, nout,
+ Memc[expname], exposure)
+
+ doscale = (doscale || dozero)
+
+ call sfree (sp)
+end
+
+
+# IC_GSCALE -- Get scale values as directed by CL parameter
+# The values can be one of those in the dictionary, from a file specified
+# with a @ prefix, or from an image header keyword specified by a ! prefix.
+
+int procedure ic_gscale (param, name, dic, in, exptime, values, nimages)
+
+char param[ARB] #I CL parameter name
+char name[SZ_FNAME] #O Parameter value
+char dic[ARB] #I Dictionary string
+pointer in[nimages] #I IMIO pointers
+real exptime[nimages] #I Exposure times
+real values[nimages] #O Values
+int nimages #I Number of images
+
+int type #O Type of value
+
+int fd, i, nowhite(), open(), fscan(), nscan(), strdic()
+real rval, imgetr()
+pointer errstr
+errchk open, imgetr()
+
+include "icombine.com"
+
+begin
+ call clgstr (param, name, SZ_FNAME)
+ if (nowhite (name, name, SZ_FNAME) == 0)
+ type = S_NONE
+ else if (name[1] == '@') {
+ type = S_FILE
+ fd = open (name[2], READ_ONLY, TEXT_FILE)
+ i = 0
+ while (fscan (fd) != EOF) {
+ call gargr (rval)
+ if (nscan() != 1)
+ next
+ if (i == nimages) {
+ call eprintf (
+ "Warning: Ignoring additional %s values in %s\n")
+ call pargstr (param)
+ call pargstr (name[2])
+ break
+ }
+ i = i + 1
+ values[i] = rval
+ }
+ call close (fd)
+ if (i < nimages) {
+ call salloc (errstr, SZ_LINE, TY_CHAR)
+ call sprintf (errstr, SZ_FNAME, "Insufficient %s values in %s")
+ call pargstr (param)
+ call pargstr (name[2])
+ call error (1, errstr)
+ }
+ } else if (name[1] == '!') {
+ type = S_KEYWORD
+ do i = 1, nimages {
+ values[i] = imgetr (in[i], name[2])
+ if (project) {
+ call amovkr (values, values, nimages)
+ break
+ }
+ }
+ } else {
+ type = strdic (name, name, SZ_FNAME, dic)
+ if (type == 0)
+ call error (1, "Unknown scale, zero, or weight type")
+ if (type==S_EXPOSURE)
+ do i = 1, nimages
+ values[i] = max (0.001, exptime[i])
+ }
+
+ return (type)
+end
diff --git a/pkg/obsolete/imcombine/icsclip.gx b/pkg/obsolete/imcombine/icsclip.gx
new file mode 100644
index 00000000..1b1c5de9
--- /dev/null
+++ b/pkg/obsolete/imcombine/icsclip.gx
@@ -0,0 +1,504 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include "../icombine.h"
+
+define MINCLIP 3 # Mininum number of images for algorithm
+
+$for (sird)
+# IC_ASIGCLIP -- Reject pixels using sigma clipping about the average
+# The initial average rejects the high and low pixels. A correction for
+# different scalings of the images may be made. Weights are not used.
+
+procedure ic_asigclip$t (d, m, n, scales, zeros, nimages, npts, average)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+$if (datatype == sil)
+real average[npts] # Average
+$else
+PIXEL average[npts] # Average
+$endif
+
+int i, j, k, l, jj, n1, n2, nin, nk, maxkeep
+$if (datatype == sil)
+real d1, low, high, sum, a, s, r, one
+data one /1.0/
+$else
+PIXEL d1, low, high, sum, a, s, r, one
+data one /1$f/
+$endif
+pointer sp, resid, w, wp, dp1, dp2, mp1, mp2
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ # Flag whether returned average needs to be recomputed.
+ if (dowts || combine != AVERAGE)
+ docombine = true
+ else
+ docombine = false
+
+ # Save the residuals and the sigma scaling corrections if needed.
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+ if (doscale1)
+ call salloc (w, nimages, TY_REAL)
+
+ # Do sigma clipping.
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+
+ # If there are not enough pixels simply compute the average.
+ if (n1 < max (3, maxkeep)) {
+ if (!docombine) {
+ if (n1 == 0)
+ average[i] = blank
+ else {
+ sum = Mem$t[d[1]+k]
+ do j = 2, n1
+ sum = sum + Mem$t[d[j]+k]
+ average[i] = sum / n1
+ }
+ }
+ next
+ }
+
+ # Compute average with the high and low rejected.
+ low = Mem$t[d[1]+k]
+ high = Mem$t[d[2]+k]
+ if (low > high) {
+ d1 = low
+ low = high
+ high = d1
+ }
+ sum = 0.
+ do j = 3, n1 {
+ d1 = Mem$t[d[j]+k]
+ if (d1 < low) {
+ sum = sum + low
+ low = d1
+ } else if (d1 > high) {
+ sum = sum + high
+ high = d1
+ } else
+ sum = sum + d1
+ }
+ a = sum / (n1 - 2)
+ sum = sum + low + high
+
+ # Iteratively reject pixels and compute the final average if needed.
+ # Compact the data and keep track of the image IDs if needed.
+
+ repeat {
+ n2 = n1
+ if (doscale1) {
+ # Compute sigma corrected for scaling.
+ s = 0.
+ wp = w - 1
+ do j = 1, n1 {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ wp = wp + 1
+
+ d1 = Mem$t[dp1]
+ l = Memi[mp1]
+ r = sqrt (max (one, (a + zeros[l]) / scales[l]))
+ s = s + ((d1 - a) / r) ** 2
+ Memr[wp] = r
+ }
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels. Save the residuals and data values.
+ wp = w - 1
+ if (s > 0.) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ wp = wp + 1
+
+ d1 = Mem$t[dp1]
+ r = (d1 - a) / (s * Memr[wp])
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs (r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Mem$t[dp1] = Mem$t[dp2]
+ Mem$t[dp2] = d1
+ Memr[wp] = Memr[w+n1-1]
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ } else {
+ # Compute the sigma without scale correction.
+ s = 0.
+ do j = 1, n1
+ s = s + (Mem$t[d[j]+k] - a) ** 2
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels. Save the residuals and data values.
+ if (s > 0.) {
+ for (j=1; j<=n1; j=j+1) {
+ dp1 = d[j] + k
+ d1 = Mem$t[dp1]
+ r = (d1 - a) / s
+ if (r < -lsigma || r > hsigma) {
+ Memr[resid+n1] = abs (r)
+ if (j < n1) {
+ dp2 = d[n1] + k
+ Mem$t[dp1] = Mem$t[dp2]
+ Mem$t[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[n1] + k
+ l = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = l
+ }
+ j = j - 1
+ }
+ sum = sum - d1
+ n1 = n1 - 1
+ }
+ }
+ }
+ }
+
+ # Recompute the average.
+ if (n1 > 1)
+ a = sum / n1
+ } until (n1 == n2 || n1 <= max (2, maxkeep))
+
+ # If too many pixels are rejected add some back.
+ # All pixels with equal residuals are added back.
+ if (n1 < maxkeep) {
+ nk = maxkeep
+ if (doscale1) {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ mp1 = m[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Mem$t[dp1]
+ Mem$t[dp1] = Mem$t[dp2]
+ Mem$t[dp2] = d1
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ sum = sum + Mem$t[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ } else {
+ for (j=n1+1; j<=nk; j=j+1) {
+ dp1 = d[j] + k
+ r = Memr[resid+j]
+ jj = 0
+ do l = j+1, n2 {
+ s = Memr[resid+l]
+ if (s < r + TOL) {
+ if (s > r - TOL)
+ jj = jj + 1
+ else {
+ jj = 0
+ Memr[resid+l] = r
+ r = s
+ dp2 = d[l] + k
+ d1 = Mem$t[dp1]
+ Mem$t[dp1] = Mem$t[dp2]
+ Mem$t[dp2] = d1
+ if (keepids) {
+ mp1 = m[j] + k
+ mp2 = m[l] + k
+ s = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = s
+ }
+ }
+ }
+ }
+ sum = sum + Mem$t[dp1]
+ n1 = n1 + 1
+ nk = max (nk, j+jj)
+ }
+ }
+
+ # Recompute the average.
+ if (n1 > 1)
+ a = sum / n1
+ }
+
+ # Save the average if needed.
+ n[i] = n1
+ if (!docombine) {
+ if (n1 > 0)
+ average[i] = a
+ else
+ average[i] = blank
+ }
+ }
+
+ # Check if the data flag has to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ call sfree (sp)
+end
+
+
+# IC_MSIGCLIP -- Reject pixels using sigma clipping about the median
+
+procedure ic_msigclip$t (d, m, n, scales, zeros, nimages, npts, median)
+
+pointer d[nimages] # Data pointers
+pointer m[nimages] # Image id pointers
+int n[npts] # Number of good pixels
+real scales[nimages] # Scales
+real zeros[nimages] # Zeros
+int nimages # Number of images
+int npts # Number of output points per line
+$if (datatype == sil)
+real median[npts] # Median
+$else
+PIXEL median[npts] # Median
+$endif
+
+int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep
+real r, s
+pointer sp, resid, w, mp1, mp2
+$if (datatype == sil)
+real med, one
+data one /1.0/
+$else
+PIXEL med, one
+data one /1$f/
+$endif
+
+include "../icombine.com"
+
+begin
+ # If there are insufficient pixels go on to the combining
+ if (nkeep < 0)
+ maxkeep = max (0, nimages + nkeep)
+ else
+ maxkeep = min (nimages, nkeep)
+ if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) {
+ docombine = true
+ return
+ }
+
+ # Save the residuals and sigma scaling corrections if needed.
+ call smark (sp)
+ call salloc (resid, nimages+1, TY_REAL)
+ if (doscale1)
+ call salloc (w, nimages, TY_REAL)
+
+ # Compute median and sigma and iteratively clip.
+ nin = n[1]
+ do i = 1, npts {
+ k = i - 1
+ n1 = n[i]
+ if (nkeep < 0)
+ maxkeep = max (0, n1 + nkeep)
+ else
+ maxkeep = min (n1, nkeep)
+ nl = 1
+ nh = n1
+
+ repeat {
+ n2 = n1
+ n3 = nl + n1 / 2
+
+ if (n1 == 0)
+ med = blank
+ else if (mod (n1, 2) == 0)
+ med = (Mem$t[d[n3-1]+k] + Mem$t[d[n3]+k]) / 2.
+ else
+ med = Mem$t[d[n3]+k]
+
+ if (n1 >= max (MINCLIP, maxkeep+1)) {
+ if (doscale1) {
+ # Compute the sigma with scaling correction.
+ s = 0.
+ do j = nl, nh {
+ l = Memi[m[j]+k]
+ r = sqrt (max (one, (med + zeros[l]) / scales[l]))
+ s = s + ((Mem$t[d[j]+k] - med) / r) ** 2
+ Memr[w+j-1] = r
+ }
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels and save the residuals.
+ if (s > 0.) {
+ for (; nl <= n2; nl = nl + 1) {
+ r = (med - Mem$t[d[nl]+k]) / (s * Memr[w+nl-1])
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ r = (Mem$t[d[nh]+k] - med) / (s * Memr[w+nh-1])
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+ } else {
+ # Compute the sigma without scaling correction.
+ s = 0.
+ do j = nl, nh
+ s = s + (Mem$t[d[j]+k] - med) ** 2
+ s = sqrt (s / (n1 - 1))
+
+ # Reject pixels and save the residuals.
+ if (s > 0.) {
+ for (; nl <= n2; nl = nl + 1) {
+ r = (med - Mem$t[d[nl]+k]) / s
+ if (r <= lsigma)
+ break
+ Memr[resid+nl] = r
+ n1 = n1 - 1
+ }
+ for (; nh >= nl; nh = nh - 1) {
+ r = (Mem$t[d[nh]+k] - med) / s
+ if (r <= hsigma)
+ break
+ Memr[resid+nh] = r
+ n1 = n1 - 1
+ }
+ }
+ }
+ }
+ } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1))
+
+ # If too many pixels are rejected add some back.
+ # All pixels with equal residuals are added back.
+ while (n1 < maxkeep) {
+ if (nl == 1)
+ nh = nh + 1
+ else if (nh == n[i])
+ nl = nl - 1
+ else {
+ r = Memr[resid+nl-1]
+ s = Memr[resid+nh+1]
+ if (r < s) {
+ nl = nl - 1
+ r = r + TOL
+ if (s <= r)
+ nh = nh + 1
+ if (nl > 1) {
+ if (Memr[resid+nl-1] <= r)
+ nl = nl - 1
+ }
+ } else {
+ nh = nh + 1
+ s = s + TOL
+ if (r <= s)
+ nl = nl - 1
+ if (nh < n2) {
+ if (Memr[resid+nh+1] <= s)
+ nh = nh + 1
+ }
+ }
+ }
+ n1 = nh - nl + 1
+ }
+
+ # Only set median and reorder if needed
+ n[i] = n1
+ if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) {
+ j = max (nl, n1 + 1)
+ if (keepids) {
+ do l = 1, min (n1, nl-1) {
+ Mem$t[d[l]+k] = Mem$t[d[j]+k]
+ if (grow >= 1.) {
+ mp1 = m[l] + k
+ mp2 = m[j] + k
+ id = Memi[mp1]
+ Memi[mp1] = Memi[mp2]
+ Memi[mp2] = id
+ } else
+ Memi[m[l]+k] = Memi[m[j]+k]
+ j = j + 1
+ }
+ } else {
+ do l = 1, min (n1, nl - 1) {
+ Mem$t[d[l]+k] = Mem$t[d[j]+k]
+ j = j + 1
+ }
+ }
+ }
+
+ if (combine == MEDIAN)
+ median[i] = med
+ }
+
+ # Check if data flag needs to be reset for rejected pixels
+ if (dflag == D_ALL) {
+ do i = 1, npts {
+ if (n[i] != nin) {
+ dflag = D_MIX
+ break
+ }
+ }
+ }
+
+ # Flag that the median has been computed.
+ if (combine == MEDIAN)
+ docombine = false
+ else
+ docombine = true
+
+ call sfree (sp)
+end
+$endfor
diff --git a/pkg/obsolete/imcombine/icsection.x b/pkg/obsolete/imcombine/icsection.x
new file mode 100644
index 00000000..746c1f51
--- /dev/null
+++ b/pkg/obsolete/imcombine/icsection.x
@@ -0,0 +1,94 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <ctype.h>
+
+# IC_SECTION -- Parse an image section into its elements.
+# 1. The default values must be set by the caller.
+# 2. A null image section is OK.
+# 3. The first nonwhitespace character must be '['.
+# 4. The last interpreted character must be ']'.
+#
+# This procedure should be replaced with an IMIO procedure at some
+# point.
+
+procedure ic_section (section, x1, x2, xs, ndim)
+
+char section[ARB] # Image section
+int x1[ndim] # Starting pixel
+int x2[ndim] # Ending pixel
+int xs[ndim] # Step
+int ndim # Number of dimensions
+
+int i, ip, a, b, c, temp, ctoi()
+define error_ 99
+
+begin
+ # Decode the section string.
+ ip = 1
+ while (IS_WHITE(section[ip]))
+ ip = ip + 1
+ if (section[ip] == '[')
+ ip = ip + 1
+ else if (section[ip] == EOS)
+ return
+ else
+ goto error_
+
+ do i = 1, ndim {
+ while (IS_WHITE(section[ip]))
+ ip = ip + 1
+ if (section[ip] == ']')
+ break
+
+ # Default values
+ a = x1[i]
+ b = x2[i]
+ c = xs[i]
+
+ # Get a:b:c. Allow notation such as "-*:c"
+ # (or even "-:c") where the step is obviously negative.
+
+ if (ctoi (section, ip, temp) > 0) { # a
+ a = temp
+ if (section[ip] == ':') {
+ ip = ip + 1
+ if (ctoi (section, ip, b) == 0) # a:b
+ goto error_
+ } else
+ b = a
+ } else if (section[ip] == '-') { # -*
+ temp = a
+ a = b
+ b = temp
+ ip = ip + 1
+ if (section[ip] == '*')
+ ip = ip + 1
+ } else if (section[ip] == '*') # *
+ ip = ip + 1
+ if (section[ip] == ':') { # ..:step
+ ip = ip + 1
+ if (ctoi (section, ip, c) == 0)
+ goto error_
+ else if (c == 0)
+ goto error_
+ }
+ if (a > b && c > 0)
+ c = -c
+
+ x1[i] = a
+ x2[i] = b
+ xs[i] = c
+
+ while (IS_WHITE(section[ip]))
+ ip = ip + 1
+ if (section[ip] == ',')
+ ip = ip + 1
+ }
+
+ if (section[ip] != ']')
+ goto error_
+
+ return
+error_
+ call error (0, "Error in image section specification")
+end
diff --git a/pkg/obsolete/imcombine/icsetout.x b/pkg/obsolete/imcombine/icsetout.x
new file mode 100644
index 00000000..cdb69b43
--- /dev/null
+++ b/pkg/obsolete/imcombine/icsetout.x
@@ -0,0 +1,273 @@
+include <imhdr.h>
+include <imset.h>
+include <mwset.h>
+
+define OFFTYPES "|none|wcs|world|physical|grid|"
+define FILE 0
+define NONE 1
+define WCS 2
+define WORLD 3
+define PHYSICAL 4
+define GRID 5
+
+# IC_SETOUT -- Set output image size and offsets of input images.
+
+procedure ic_setout (in, out, offsets, nimages)
+
+pointer in[nimages] # Input images
+pointer out[3] # Output images
+int offsets[nimages,ARB] # Offsets
+int nimages # Number of images
+
+int i, j, indim, outdim, mwdim, a, b, amin, bmax, fd, offtype
+real val
+bool reloff, flip, streq(), fp_equald()
+pointer sp, str, fname
+pointer pref, lref, wref, cd, ltm, coord, shift, axno, axval, section
+pointer mw, ct, mw_openim(), mw_sctran(), immap()
+int open(), fscan(), nscan(), mw_stati(), strlen(), strdic()
+errchk mw_openim, mw_sctran, mw_ctrand, open, immap
+
+include "icombine.com"
+define newscan_ 10
+
+begin
+ call smark (sp)
+ call salloc (str, SZ_FNAME, TY_CHAR)
+ call salloc (fname, SZ_FNAME, TY_CHAR)
+ call salloc (lref, IM_MAXDIM, TY_DOUBLE)
+ call salloc (wref, IM_MAXDIM, TY_DOUBLE)
+ call salloc (cd, IM_MAXDIM*IM_MAXDIM, TY_DOUBLE)
+ call salloc (coord, IM_MAXDIM, TY_DOUBLE)
+ call salloc (shift, IM_MAXDIM, TY_REAL)
+ call salloc (axno, IM_MAXDIM, TY_INT)
+ call salloc (axval, IM_MAXDIM, TY_INT)
+
+ # Check and set the image dimensionality.
+ indim = IM_NDIM(in[1])
+ outdim = IM_NDIM(out[1])
+ if (project) {
+ outdim = indim - 1
+ IM_NDIM(out[1]) = outdim
+ } else {
+ do i = 1, nimages
+ if (IM_NDIM(in[i]) != outdim) {
+ call sfree (sp)
+ call error (1, "Image dimensions are not the same")
+ }
+ }
+
+ # Set the reference point to that of the first image.
+ mw = mw_openim (in[1])
+ mwdim = mw_stati (mw, MW_NPHYSDIM)
+ call mw_gwtermd (mw, Memd[lref], Memd[wref], Memd[cd], mwdim)
+ if (project)
+ Memd[lref+outdim] = 1
+
+ # Parse the user offset string. If "none" then there are no offsets.
+ # If "world" or "wcs" then set the offsets based on the world WCS.
+ # If "physical" then set the offsets based on the physical WCS.
+ # If "grid" then set the offsets based on the input grid parameters.
+ # If a file scan it.
+
+ call clgstr ("offsets", Memc[fname], SZ_FNAME)
+ call sscan (Memc[fname])
+ call gargwrd (Memc[fname], SZ_FNAME)
+ if (nscan() == 0)
+ offtype = NONE
+ else {
+ offtype = strdic (Memc[fname], Memc[str], SZ_FNAME, OFFTYPES)
+ if (offtype > 0 && !streq (Memc[fname], Memc[str]))
+ offtype = 0
+ }
+ if (offtype == 0)
+ offtype = FILE
+
+ switch (offtype) {
+ case NONE:
+ call aclri (offsets, outdim*nimages)
+ reloff = true
+ case WORLD, WCS:
+ do j = 1, outdim
+ offsets[1,j] = 0
+ if (project) {
+ ct = mw_sctran (mw, "world", "logical", 0)
+ do i = 2, nimages {
+ Memd[wref+outdim] = i
+ call mw_ctrand (ct, Memd[wref], Memd[coord], indim)
+ do j = 1, outdim
+ offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1])
+ }
+ call mw_ctfree (ct)
+ call mw_close (mw)
+ } else {
+ do i = 2, nimages {
+ call mw_close (mw)
+ mw = mw_openim (in[i])
+ ct = mw_sctran (mw, "world", "logical", 0)
+ call mw_ctrand (ct, Memd[wref], Memd[coord], indim)
+ do j = 1, outdim
+ offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1])
+ call mw_ctfree (ct)
+ }
+ }
+ reloff = true
+ case PHYSICAL:
+ call salloc (pref, IM_MAXDIM, TY_DOUBLE)
+ call salloc (ltm, IM_MAXDIM*IM_MAXDIM, TY_DOUBLE)
+ call salloc (section, SZ_FNAME, TY_CHAR)
+
+ call mw_gltermd (mw, Memd[ltm], Memd[coord], indim)
+ do i = 2, nimages {
+ call mw_close (mw)
+ mw = mw_openim (in[i])
+ call mw_gltermd (mw, Memd[cd], Memd[coord], indim)
+ call strcpy ("[", Memc[section], SZ_FNAME)
+ flip = false
+ do j = 0, indim*indim-1, indim+1 {
+ if (Memd[ltm+j] * Memd[cd+j] >= 0.)
+ call strcat ("*,", Memc[section], SZ_FNAME)
+ else {
+ call strcat ("-*,", Memc[section], SZ_FNAME)
+ flip = true
+ }
+ }
+ Memc[section+strlen(Memc[section])-1] = ']'
+ if (flip) {
+ call imstats (in[i], IM_IMAGENAME, Memc[fname], SZ_FNAME)
+ call strcat (Memc[section], Memc[fname], SZ_FNAME)
+ call imunmap (in[i])
+ in[i] = immap (Memc[fname], READ_ONLY, TY_CHAR)
+ call mw_close (mw)
+ mw = mw_openim (in[i])
+ call mw_gltermd (mw, Memd[cd], Memd[coord], indim)
+ do j = 0, indim*indim-1
+ if (!fp_equald (Memd[ltm+j], Memd[cd+j]))
+ call error (1,
+ "Cannot match physical coordinates")
+ }
+ }
+
+ call mw_close (mw)
+ mw = mw_openim (in[1])
+ ct = mw_sctran (mw, "logical", "physical", 0)
+ call mw_ctrand (ct, Memd[lref], Memd[pref], indim)
+ call mw_ctfree (ct)
+ do j = 1, outdim
+ offsets[1,j] = 0
+ if (project) {
+ ct = mw_sctran (mw, "physical", "logical", 0)
+ do i = 2, nimages {
+ Memd[pref+outdim] = i
+ call mw_ctrand (ct, Memd[pref], Memd[coord], indim)
+ do j = 1, outdim
+ offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1])
+ }
+ call mw_ctfree (ct)
+ call mw_close (mw)
+ } else {
+ do i = 2, nimages {
+ call mw_close (mw)
+ mw = mw_openim (in[i])
+ ct = mw_sctran (mw, "physical", "logical", 0)
+ call mw_ctrand (ct, Memd[pref], Memd[coord], indim)
+ do j = 1, outdim
+ offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1])
+ call mw_ctfree (ct)
+ }
+ }
+ reloff = true
+ case GRID:
+ amin = 1
+ do j = 1, outdim {
+ call gargi (a)
+ call gargi (b)
+ if (nscan() < 1+2*j)
+ break
+ do i = 1, nimages
+ offsets[i,j] = mod ((i-1)/amin, a) * b
+ amin = amin * a
+ }
+ reloff = true
+ case FILE:
+ reloff = true
+ fd = open (Memc[fname], READ_ONLY, TEXT_FILE)
+ do i = 1, nimages {
+newscan_ if (fscan (fd) == EOF)
+ call error (1, "IMCOMBINE: Offset list too short")
+ call gargwrd (Memc[fname], SZ_FNAME)
+ if (Memc[fname] == '#') {
+ call gargwrd (Memc[fname], SZ_FNAME)
+ call strlwr (Memc[fname])
+ if (streq (Memc[fname], "absolute"))
+ reloff = false
+ else if (streq (Memc[fname], "relative"))
+ reloff = true
+ goto newscan_
+ }
+ call reset_scan ()
+ do j = 1, outdim {
+ call gargr (val)
+ offsets[i,j] = nint (val)
+ }
+ if (nscan() < outdim)
+ call error (1, "IMCOMBINE: Error in offset list")
+ }
+ call close (fd)
+ }
+
+ # Set the output image size and the aligned flag
+ aligned = true
+ do j = 1, outdim {
+ a = offsets[1,j]
+ b = IM_LEN(in[1],j) + a
+ amin = a
+ bmax = b
+ do i = 2, nimages {
+ a = offsets[i,j]
+ b = IM_LEN(in[i],j) + a
+ if (a != amin || b != bmax || !reloff)
+ aligned = false
+ amin = min (a, amin)
+ bmax = max (b, bmax)
+ }
+ IM_LEN(out[1],j) = bmax
+ if (reloff || amin < 0) {
+ do i = 1, nimages
+ offsets[i,j] = offsets[i,j] - amin
+ IM_LEN(out[1],j) = IM_LEN(out[1],j) - amin
+ }
+ }
+
+ # Update the WCS.
+ if (project || !aligned || !reloff) {
+ call mw_close (mw)
+ mw = mw_openim (out[1])
+ if (!aligned || !reloff) {
+ call mw_gltermd (mw, Memd[cd], Memd[lref], indim)
+ do i = 1, indim
+ Memd[lref+i-1] = Memd[lref+i-1] + offsets[1,i]
+ call mw_sltermd (mw, Memd[cd], Memd[lref], indim)
+ }
+ if (project) {
+ # Apply dimensional reduction.
+ i = mw_stati (mw, MW_NPHYSDIM)
+ call mw_gaxmap (mw, Memi[axno], Memi[axval], i)
+ do j = 0, i-1 {
+ if (Memi[axno+j] <= outdim) {
+ next
+ } else if (Memi[axno+j] > outdim+1) {
+ Memi[axno+j] = Memi[axno+j] - 1
+ } else {
+ Memi[axno+j] = 0
+ Memi[axval+j] = 0
+ }
+ }
+ call mw_saxmap (mw, Memi[axno], Memi[axval], i)
+ }
+ call mw_saveim (mw, out)
+ }
+ call mw_close (mw)
+
+ call sfree (sp)
+end
diff --git a/pkg/obsolete/imcombine/icsigma.gx b/pkg/obsolete/imcombine/icsigma.gx
new file mode 100644
index 00000000..81e536c4
--- /dev/null
+++ b/pkg/obsolete/imcombine/icsigma.gx
@@ -0,0 +1,115 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include "../icombine.h"
+
+$for (sird)
+# IC_SIGMA -- Compute the sigma image line.
+# The estimated sigma includes a correction for the finite population.
+# Weights are used if desired.
+
+procedure ic_sigma$t (d, m, n, wts, npts, average, sigma)
+
+pointer d[ARB] # Data pointers
+pointer m[ARB] # Image ID pointers
+int n[npts] # Number of points
+real wts[ARB] # Weights
+int npts # Number of output points per line
+$if (datatype == sil)
+real average[npts] # Average
+real sigma[npts] # Sigma line (returned)
+$else
+PIXEL average[npts] # Average
+PIXEL sigma[npts] # Sigma line (returned)
+$endif
+
+int i, j, k, n1
+real wt, sigcor, sumwt
+$if (datatype == sil)
+real a, sum
+$else
+PIXEL a, sum
+$endif
+
+include "../icombine.com"
+
+begin
+ if (dflag == D_ALL) {
+ n1 = n[1]
+ if (dowts) {
+ if (n1 > 1)
+ sigcor = real (n1) / real (n1 - 1)
+ else
+ sigcor = 1.
+ do i = 1, npts {
+ k = i - 1
+ a = average[i]
+ wt = wts[Memi[m[1]+k]]
+ sum = (Mem$t[d[1]+k] - a) ** 2 * wt
+ do j = 2, n1 {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + (Mem$t[d[j]+k] - a) ** 2 * wt
+ }
+ sigma[i] = sqrt (sum * sigcor)
+ }
+ } else {
+ if (n1 > 1)
+ sigcor = 1. / real (n1 - 1)
+ else
+ sigcor = 1.
+ do i = 1, npts {
+ k = i - 1
+ a = average[i]
+ sum = (Mem$t[d[1]+k] - a) ** 2
+ do j = 2, n1
+ sum = sum + (Mem$t[d[j]+k] - a) ** 2
+ sigma[i] = sqrt (sum * sigcor)
+ }
+ }
+ } else if (dflag == D_NONE) {
+ do i = 1, npts
+ sigma[i] = blank
+ } else {
+ if (dowts) {
+ do i = 1, npts {
+ n1 = n[i]
+ if (n1 > 0) {
+ k = i - 1
+ if (n1 > 1)
+ sigcor = real (n1) / real (n1 -1)
+ else
+ sigcor = 1
+ a = average[i]
+ wt = wts[Memi[m[1]+k]]
+ sum = (Mem$t[d[1]+k] - a) ** 2 * wt
+ sumwt = wt
+ do j = 2, n1 {
+ wt = wts[Memi[m[j]+k]]
+ sum = sum + (Mem$t[d[j]+k] - a) ** 2 * wt
+ sumwt = sumwt + wt
+ }
+ sigma[i] = sqrt (sum / sumwt * sigcor)
+ } else
+ sigma[i] = blank
+ }
+ } else {
+ do i = 1, npts {
+ n1 = n[i]
+ if (n1 > 0) {
+ k = i - 1
+ if (n1 > 1)
+ sigcor = 1. / real (n1 - 1)
+ else
+ sigcor = 1.
+ a = average[i]
+ sum = (Mem$t[d[1]+k] - a) ** 2
+ do j = 2, n1
+ sum = sum + (Mem$t[d[j]+k] - a) ** 2
+ sigma[i] = sqrt (sum * sigcor)
+ } else
+ sigma[i] = blank
+ }
+ }
+ }
+end
+$endfor
diff --git a/pkg/obsolete/imcombine/icsort.gx b/pkg/obsolete/imcombine/icsort.gx
new file mode 100644
index 00000000..e124da15
--- /dev/null
+++ b/pkg/obsolete/imcombine/icsort.gx
@@ -0,0 +1,386 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+define LOGPTR 32 # log2(maxpts) (4e9)
+
+$for (sird)
+# IC_SORT -- Quicksort. This is based on the VOPS asrt except that
+# the input is an array of pointers to image lines and the sort is done
+# across the image lines at each point along the lines. The number of
+# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3
+# pixels per point are treated specially.
+
+procedure ic_sort$t (a, b, nvecs, npts)
+
+pointer a[ARB] # pointer to input vectors
+PIXEL b[ARB] # work array
+int nvecs[npts] # number of vectors
+int npts # number of points in vectors
+
+PIXEL pivot, temp, temp3
+int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR]
+define swap {temp=$1;$1=$2;$2=temp}
+define copy_ 10
+
+begin
+ do l = 0, npts-1 {
+ npix = nvecs[l+1]
+ if (npix <= 1)
+ next
+
+ do i = 1, npix
+ b[i] = Mem$t[a[i]+l]
+
+ # Special cases
+ $if (datatype == x)
+ if (npix <= 3) {
+ pivot = b[1]
+ temp = b[2]
+ if (npix == 2) {
+ if (abs (temp) < abs (pivot)) {
+ b[1] = temp
+ b[2] = pivot
+ } else
+ next
+ } else {
+ temp3 = b[3]
+ if (abs (temp) < abs (pivot)) { # bac|bca|cba
+ if (abs (temp) < abs (temp3)) { # bac|bca
+ b[1] = temp
+ if (abs (pivot) < abs (temp3)) # bac
+ b[2] = pivot
+ else { # bca
+ b[2] = temp3
+ b[3] = pivot
+ }
+ } else { # cba
+ b[1] = temp3
+ b[3] = pivot
+ }
+ } else if (abs (temp3) < abs (temp)) { # acb|cab
+ b[3] = temp
+ if (abs (pivot) < abs (temp3)) # acb
+ b[2] = temp3
+ else { # cab
+ b[1] = temp3
+ b[2] = pivot
+ }
+ } else
+ next
+ }
+ goto copy_
+ }
+ $else
+ if (npix <= 3) {
+ pivot = b[1]
+ temp = b[2]
+ if (npix == 2) {
+ if (temp < pivot) {
+ b[1] = temp
+ b[2] = pivot
+ } else
+ next
+ } else {
+ temp3 = b[3]
+ if (temp < pivot) { # bac|bca|cba
+ if (temp < temp3) { # bac|bca
+ b[1] = temp
+ if (pivot < temp3) # bac
+ b[2] = pivot
+ else { # bca
+ b[2] = temp3
+ b[3] = pivot
+ }
+ } else { # cba
+ b[1] = temp3
+ b[3] = pivot
+ }
+ } else if (temp3 < temp) { # acb|cab
+ b[3] = temp
+ if (pivot < temp3) # acb
+ b[2] = temp3
+ else { # cab
+ b[1] = temp3
+ b[2] = pivot
+ }
+ } else
+ next
+ }
+ goto copy_
+ }
+ $endif
+
+ # General case
+ do i = 1, npix
+ b[i] = Mem$t[a[i]+l]
+
+ lv[1] = 1
+ uv[1] = npix
+ p = 1
+
+ while (p > 0) {
+ if (lv[p] >= uv[p]) # only one elem in this subset
+ p = p - 1 # pop stack
+ else {
+ # Dummy do loop to trigger the Fortran optimizer.
+ do p = p, ARB {
+ i = lv[p] - 1
+ j = uv[p]
+
+ # Select as the pivot the element at the center of the
+ # array, to avoid quadratic behavior on an already
+ # sorted array.
+
+ k = (lv[p] + uv[p]) / 2
+ swap (b[j], b[k])
+ pivot = b[j] # pivot line
+
+ while (i < j) {
+ $if (datatype == x)
+ for (i=i+1; abs(b[i]) < abs(pivot); i=i+1)
+ $else
+ for (i=i+1; b[i] < pivot; i=i+1)
+ $endif
+ ;
+ for (j=j-1; j > i; j=j-1)
+ $if (datatype == x)
+ if (abs(b[j]) <= abs(pivot))
+ $else
+ if (b[j] <= pivot)
+ $endif
+ break
+ if (i < j) # out of order pair
+ swap (b[i], b[j]) # interchange elements
+ }
+
+ j = uv[p] # move pivot to position i
+ swap (b[i], b[j]) # interchange elements
+
+ if (i-lv[p] < uv[p] - i) { # stack so shorter done first
+ lv[p+1] = lv[p]
+ uv[p+1] = i - 1
+ lv[p] = i + 1
+ } else {
+ lv[p+1] = i + 1
+ uv[p+1] = uv[p]
+ uv[p] = i - 1
+ }
+
+ break
+ }
+ p = p + 1 # push onto stack
+ }
+ }
+
+copy_
+ do i = 1, npix
+ Mem$t[a[i]+l] = b[i]
+ }
+end
+
+
+# IC_2SORT -- Quicksort. This is based on the VOPS asrt except that
+# the input is an array of pointers to image lines and the sort is done
+# across the image lines at each point along the lines. The number of
+# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3
+# pixels per point are treated specially. A second integer set of
+# vectors is sorted.
+
+procedure ic_2sort$t (a, b, c, d, nvecs, npts)
+
+pointer a[ARB] # pointer to input vectors
+PIXEL b[ARB] # work array
+pointer c[ARB] # pointer to associated integer vectors
+int d[ARB] # work array
+int nvecs[npts] # number of vectors
+int npts # number of points in vectors
+
+PIXEL pivot, temp, temp3
+int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp
+define swap {temp=$1;$1=$2;$2=temp}
+define iswap {itemp=$1;$1=$2;$2=itemp}
+define copy_ 10
+
+begin
+ do l = 0, npts-1 {
+ npix = nvecs[l+1]
+ if (npix <= 1)
+ next
+
+ do i = 1, npix {
+ b[i] = Mem$t[a[i]+l]
+ d[i] = Memi[c[i]+l]
+ }
+
+ # Special cases
+ $if (datatype == x)
+ if (npix <= 3) {
+ pivot = b[1]
+ temp = b[2]
+ if (npix == 2) {
+ if (abs (temp) < abs (pivot)) {
+ b[1] = temp
+ b[2] = pivot
+ iswap (d[1], d[2])
+ } else
+ next
+ } else {
+ temp3 = b[3]
+ if (abs (temp) < abs (pivot)) { # bac|bca|cba
+ if (abs (temp) < abs (temp3)) { # bac|bca
+ b[1] = temp
+ if (abs (pivot) < abs (temp3)) { # bac
+ b[2] = pivot
+ iswap (d[1], d[2])
+ } else { # bca
+ b[2] = temp3
+ b[3] = pivot
+ itemp = d[2]
+ d[2] = d[3]
+ d[3] = d[1]
+ d[1] = itemp
+ }
+ } else { # cba
+ b[1] = temp3
+ b[3] = pivot
+ iswap (d[1], d[3])
+ }
+ } else if (abs (temp3) < abs (temp)) { # acb|cab
+ b[3] = temp
+ if (abs (pivot) < abs (temp3)) { # acb
+ b[2] = temp3
+ iswap (d[2], d[3])
+ } else { # cab
+ b[1] = temp3
+ b[2] = pivot
+ itemp = d[2]
+ d[2] = d[1]
+ d[1] = d[3]
+ d[3] = itemp
+ }
+ } else
+ next
+ }
+ goto copy_
+ }
+ $else
+ if (npix <= 3) {
+ pivot = b[1]
+ temp = b[2]
+ if (npix == 2) {
+ if (temp < pivot) {
+ b[1] = temp
+ b[2] = pivot
+ iswap (d[1], d[2])
+ } else
+ next
+ } else {
+ temp3 = b[3]
+ if (temp < pivot) { # bac|bca|cba
+ if (temp < temp3) { # bac|bca
+ b[1] = temp
+ if (pivot < temp3) { # bac
+ b[2] = pivot
+ iswap (d[1], d[2])
+ } else { # bca
+ b[2] = temp3
+ b[3] = pivot
+ itemp = d[2]
+ d[2] = d[3]
+ d[3] = d[1]
+ d[1] = itemp
+ }
+ } else { # cba
+ b[1] = temp3
+ b[3] = pivot
+ iswap (d[1], d[3])
+ }
+ } else if (temp3 < temp) { # acb|cab
+ b[3] = temp
+ if (pivot < temp3) { # acb
+ b[2] = temp3
+ iswap (d[2], d[3])
+ } else { # cab
+ b[1] = temp3
+ b[2] = pivot
+ itemp = d[2]
+ d[2] = d[1]
+ d[1] = d[3]
+ d[3] = itemp
+ }
+ } else
+ next
+ }
+ goto copy_
+ }
+ $endif
+
+ # General case
+ lv[1] = 1
+ uv[1] = npix
+ p = 1
+
+ while (p > 0) {
+ if (lv[p] >= uv[p]) # only one elem in this subset
+ p = p - 1 # pop stack
+ else {
+ # Dummy do loop to trigger the Fortran optimizer.
+ do p = p, ARB {
+ i = lv[p] - 1
+ j = uv[p]
+
+ # Select as the pivot the element at the center of the
+ # array, to avoid quadratic behavior on an already
+ # sorted array.
+
+ k = (lv[p] + uv[p]) / 2
+ swap (b[j], b[k]); swap (d[j], d[k])
+ pivot = b[j] # pivot line
+
+ while (i < j) {
+ $if (datatype == x)
+ for (i=i+1; abs(b[i]) < abs(pivot); i=i+1)
+ $else
+ for (i=i+1; b[i] < pivot; i=i+1)
+ $endif
+ ;
+ for (j=j-1; j > i; j=j-1)
+ $if (datatype == x)
+ if (abs(b[j]) <= abs(pivot))
+ $else
+ if (b[j] <= pivot)
+ $endif
+ break
+ if (i < j) { # out of order pair
+ swap (b[i], b[j]) # interchange elements
+ swap (d[i], d[j])
+ }
+ }
+
+ j = uv[p] # move pivot to position i
+ swap (b[i], b[j]) # interchange elements
+ swap (d[i], d[j])
+
+ if (i-lv[p] < uv[p] - i) { # stack so shorter done first
+ lv[p+1] = lv[p]
+ uv[p+1] = i - 1
+ lv[p] = i + 1
+ } else {
+ lv[p+1] = i + 1
+ uv[p+1] = uv[p]
+ uv[p] = i - 1
+ }
+
+ break
+ }
+ p = p + 1 # push onto stack
+ }
+ }
+
+copy_
+ do i = 1, npix {
+ Mem$t[a[i]+l] = b[i]
+ Memi[c[i]+l] = d[i]
+ }
+ }
+end
+$endfor
diff --git a/pkg/obsolete/imcombine/icstat.gx b/pkg/obsolete/imcombine/icstat.gx
new file mode 100644
index 00000000..f2b65089
--- /dev/null
+++ b/pkg/obsolete/imcombine/icstat.gx
@@ -0,0 +1,237 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include "../icombine.h"
+
+define NMAX 10000 # Maximum number of pixels to sample
+
+$for (sird)
+# IC_STAT -- Compute image statistics within specified section.
+# The image section is relative to a reference image which may be
+# different than the input image and may have an offset. Only a
+# subsample of pixels is used. Masked and thresholded pixels are
+# ignored. Only the desired statistics are computed to increase
+# efficiency.
+
+procedure ic_stat$t (im, imref, section, offsets, image, nimages,
+ domode, domedian, domean, mode, median, mean)
+
+pointer im # Data image
+pointer imref # Reference image for image section
+char section[ARB] # Image section
+int offsets[nimages,ARB] # Image section offset from data to reference
+int image # Image index (for mask I/O)
+int nimages # Number of images in offsets.
+bool domode, domedian, domean # Statistics to compute
+real mode, median, mean # Statistics
+
+int i, j, ndim, n, nv
+real a
+pointer sp, v1, v2, dv, va, vb
+pointer data, mask, dp, lp, mp, imgnl$t()
+PIXEL ic_mode$t()
+$if (datatype == irs)
+real asum$t()
+$endif
+$if (datatype == dl)
+double asum$t()
+$endif
+$if (datatype == x)
+complex asum$t()
+$endif
+
+
+include "../icombine.com"
+
+begin
+ call smark (sp)
+ call salloc (v1, IM_MAXDIM, TY_LONG)
+ call salloc (v2, IM_MAXDIM, TY_LONG)
+ call salloc (dv, IM_MAXDIM, TY_LONG)
+ call salloc (va, IM_MAXDIM, TY_LONG)
+ call salloc (vb, IM_MAXDIM, TY_LONG)
+
+ # Determine the image section parameters. This must be in terms of
+ # the data image pixel coordinates though the section may be specified
+ # in terms of the reference image coordinates. Limit the number of
+ # pixels in each dimension to a maximum.
+
+ ndim = IM_NDIM(im)
+ if (project)
+ ndim = ndim - 1
+ call amovki (1, Memi[v1], IM_MAXDIM)
+ call amovki (1, Memi[va], IM_MAXDIM)
+ call amovki (1, Memi[dv], IM_MAXDIM)
+ call amovi (IM_LEN(imref,1), Memi[vb], ndim)
+ call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim)
+ if (im != imref)
+ do i = 1, ndim {
+ Memi[va+i-1] = Memi[va+i-1] - offsets[image,i]
+ Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i]
+ }
+
+ do j = 1, 10 {
+ n = 1
+ do i = 0, ndim-1 {
+ Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i]))
+ Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i]))
+ Memi[dv+i] = j
+ nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1)
+ Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i]
+ n = n * nv
+ }
+ if (n < NMAX)
+ break
+ }
+
+ call amovl (Memi[v1], Memi[va], IM_MAXDIM)
+ Memi[va] = 1
+ if (project)
+ Memi[va+ndim] = image
+ call amovl (Memi[va], Memi[vb], IM_MAXDIM)
+
+ # Accumulate the pixel values within the section. Masked pixels and
+ # thresholded pixels are ignored.
+
+ call salloc (data, n, TY_PIXEL)
+ dp = data
+ while (imgnl$t (im, lp, Memi[vb]) != EOF) {
+ call ic_mget1 (im, image, offsets[image,1], Memi[va], mask)
+ lp = lp + Memi[v1] - 1
+ if (dflag == D_ALL) {
+ if (dothresh) {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ a = Mem$t[lp]
+ if (a >= lthresh && a <= hthresh) {
+ Mem$t[dp] = a
+ dp = dp + 1
+ }
+ lp = lp + Memi[dv]
+ }
+ } else {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ Mem$t[dp] = Mem$t[lp]
+ dp = dp + 1
+ lp = lp + Memi[dv]
+ }
+ }
+ } else if (dflag == D_MIX) {
+ mp = mask + Memi[v1] - 1
+ if (dothresh) {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ if (Memi[mp] == 0) {
+ a = Mem$t[lp]
+ if (a >= lthresh && a <= hthresh) {
+ Mem$t[dp] = a
+ dp = dp + 1
+ }
+ }
+ mp = mp + Memi[dv]
+ lp = lp + Memi[dv]
+ }
+ } else {
+ do i = Memi[v1], Memi[v2], Memi[dv] {
+ if (Memi[mp] == 0) {
+ Mem$t[dp] = Mem$t[lp]
+ dp = dp + 1
+ }
+ mp = mp + Memi[dv]
+ lp = lp + Memi[dv]
+ }
+ }
+ }
+ for (i=2; i<=ndim; i=i+1) {
+ Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1]
+ if (Memi[va+i-1] <= Memi[v2+i-1])
+ break
+ Memi[va+i-1] = Memi[v1+i-1]
+ }
+ if (i > ndim)
+ break
+ call amovl (Memi[va], Memi[vb], IM_MAXDIM)
+ }
+
+ n = dp - data
+ if (n < 1) {
+ call sfree (sp)
+ call error (1, "Image section contains no pixels")
+ }
+
+ # Compute only statistics needed.
+ if (domode || domedian) {
+ call asrt$t (Mem$t[data], Mem$t[data], n)
+ mode = ic_mode$t (Mem$t[data], n)
+ median = Mem$t[data+n/2-1]
+ }
+ if (domean)
+ mean = asum$t (Mem$t[data], n) / n
+
+ call sfree (sp)
+end
+
+
+define NMIN 10 # Minimum number of pixels for mode calculation
+define ZRANGE 0.8 # Fraction of pixels about median to use
+define ZSTEP 0.01 # Step size for search for mode
+define ZBIN 0.1 # Bin size for mode.
+
+# IC_MODE -- Compute mode of an array. The mode is found by binning
+# with a bin size based on the data range over a fraction of the
+# pixels about the median and a bin step which may be smaller than the
+# bin size. If there are too few points the median is returned.
+# The input array must be sorted.
+
+PIXEL procedure ic_mode$t (a, n)
+
+PIXEL a[n] # Data array
+int n # Number of points
+
+int i, j, k, nmax
+real z1, z2, zstep, zbin
+PIXEL mode
+bool fp_equalr()
+
+begin
+ if (n < NMIN)
+ return (a[n/2])
+
+ # Compute the mode. The array must be sorted. Consider a
+ # range of values about the median point. Use a bin size which
+ # is ZBIN of the range. Step the bin limits in ZSTEP fraction of
+ # the bin size.
+
+ i = 1 + n * (1. - ZRANGE) / 2.
+ j = 1 + n * (1. + ZRANGE) / 2.
+ z1 = a[i]
+ z2 = a[j]
+ if (fp_equalr (z1, z2)) {
+ mode = z1
+ return (mode)
+ }
+
+ zstep = ZSTEP * (z2 - z1)
+ zbin = ZBIN * (z2 - z1)
+ $if (datatype == sil)
+ zstep = max (1., zstep)
+ zbin = max (1., zbin)
+ $endif
+
+ z1 = z1 - zstep
+ k = i
+ nmax = 0
+ repeat {
+ z1 = z1 + zstep
+ z2 = z1 + zbin
+ for (; i < j && a[i] < z1; i=i+1)
+ ;
+ for (; k < j && a[k] < z2; k=k+1)
+ ;
+ if (k - i > nmax) {
+ nmax = k - i
+ mode = a[(i+k)/2]
+ }
+ } until (k >= j)
+
+ return (mode)
+end
+$endfor
diff --git a/pkg/obsolete/imcombine/mkpkg b/pkg/obsolete/imcombine/mkpkg
new file mode 100644
index 00000000..4b6c120b
--- /dev/null
+++ b/pkg/obsolete/imcombine/mkpkg
@@ -0,0 +1,54 @@
+# Make the IMCOMBINE Task.
+
+$checkout libpkg.a ../
+$update libpkg.a
+$checkin libpkg.a ../
+$exit
+
+generic:
+ $set GEN = "$$generic -k"
+
+ $ifolder (generic/icaclip.x, icaclip.gx)
+ $(GEN) icaclip.gx -o generic/icaclip.x $endif
+ $ifolder (generic/icaverage.x, icaverage.gx)
+ $(GEN) icaverage.gx -o generic/icaverage.x $endif
+ $ifolder (generic/iccclip.x, iccclip.gx)
+ $(GEN) iccclip.gx -o generic/iccclip.x $endif
+ $ifolder (generic/icgdata.x, icgdata.gx)
+ $(GEN) icgdata.gx -o generic/icgdata.x $endif
+ $ifolder (generic/icgrow.x, icgrow.gx)
+ $(GEN) icgrow.gx -o generic/icgrow.x $endif
+ $ifolder (generic/icmedian.x, icmedian.gx)
+ $(GEN) icmedian.gx -o generic/icmedian.x $endif
+ $ifolder (generic/icmm.x, icmm.gx)
+ $(GEN) icmm.gx -o generic/icmm.x $endif
+ $ifolder (generic/icombine.x, icombine.gx)
+ $(GEN) icombine.gx -o generic/icombine.x $endif
+ $ifolder (generic/icpclip.x, icpclip.gx)
+ $(GEN) icpclip.gx -o generic/icpclip.x $endif
+ $ifolder (generic/icsclip.x, icsclip.gx)
+ $(GEN) icsclip.gx -o generic/icsclip.x $endif
+ $ifolder (generic/icsigma.x, icsigma.gx)
+ $(GEN) icsigma.gx -o generic/icsigma.x $endif
+ $ifolder (generic/icsort.x, icsort.gx)
+ $(GEN) icsort.gx -o generic/icsort.x $endif
+ $ifolder (generic/icstat.x, icstat.gx)
+ $(GEN) icstat.gx -o generic/icstat.x $endif
+ ;
+
+libpkg.a:
+ $ifeq (USE_GENERIC, yes) $call generic $endif
+
+ @generic
+
+ icimstack.x <error.h> <imhdr.h>
+ iclog.x icmask.com icombine.com icombine.h <imhdr.h> <imset.h>\
+ <mach.h>
+ icmask.x icmask.com icombine.com icombine.h <imhdr.h> <pmset.h>
+ icrmasks.x <imhdr.h>
+ icscale.x icombine.com icombine.h <error.h> <imhdr.h> <imset.h>
+ icsection.x <ctype.h>
+ icsetout.x icombine.com <imhdr.h> <mwset.h> <imset.h>
+ t_imcombine.x icombine.com icombine.h <error.h> <imhdr.h> <mach.h> \
+ <syserr.h> <pmset.h>
+ ;
diff --git a/pkg/obsolete/imcombine/t_imcombine.x b/pkg/obsolete/imcombine/t_imcombine.x
new file mode 100644
index 00000000..5b2e5026
--- /dev/null
+++ b/pkg/obsolete/imcombine/t_imcombine.x
@@ -0,0 +1,501 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include <error.h>
+include <syserr.h>
+include <mach.h>
+include <pmset.h>
+include "icombine.h"
+
+
+# T_IMCOMBINE - This task combines a list of images into an output image
+# and an optional sigma image. There are many combining options from
+# which to choose.
+
+procedure t_imcombine ()
+
+pointer sp, input, output, rmask, sigma, plfile, logfile
+int ilist, olist, rlist, slist, plist, n
+
+bool clgetb()
+real clgetr()
+int clgwrd(), clgeti(), imtopenp(), imtgetim(), imtlen()
+
+include "icombine.com"
+
+begin
+ call smark (sp)
+ call salloc (input, SZ_FNAME, TY_CHAR)
+ call salloc (output, SZ_FNAME, TY_CHAR)
+ call salloc (rmask, SZ_FNAME, TY_CHAR)
+ call salloc (plfile, SZ_FNAME, TY_CHAR)
+ call salloc (sigma, SZ_FNAME, TY_CHAR)
+ call salloc (gain, SZ_FNAME, TY_CHAR)
+ call salloc (rdnoise, SZ_FNAME, TY_CHAR)
+ call salloc (snoise, SZ_FNAME, TY_CHAR)
+ call salloc (logfile, SZ_FNAME, TY_CHAR)
+
+ # Get task parameters. Some additional parameters are obtained later.
+ ilist = imtopenp ("input")
+ olist = imtopenp ("output")
+ rlist = imtopenp ("rejmask")
+ plist = imtopenp ("plfile")
+ slist = imtopenp ("sigma")
+ call clgstr ("logfile", Memc[logfile], SZ_FNAME)
+
+ project = clgetb ("project")
+ combine = clgwrd ("combine", Memc[input], SZ_FNAME, COMBINE)
+ reject = clgwrd ("reject", Memc[input], SZ_FNAME, REJECT)
+ blank = clgetr ("blank")
+ call clgstr ("gain", Memc[gain], SZ_FNAME)
+ call clgstr ("rdnoise", Memc[rdnoise], SZ_FNAME)
+ call clgstr ("snoise", Memc[snoise], SZ_FNAME)
+ lthresh = clgetr ("lthreshold")
+ hthresh = clgetr ("hthreshold")
+ lsigma = clgetr ("lsigma")
+ hsigma = clgetr ("hsigma")
+ pclip = clgetr ("pclip")
+ flow = clgetr ("nlow")
+ fhigh = clgetr ("nhigh")
+ nkeep = clgeti ("nkeep")
+ grow = clgetr ("grow")
+ mclip = clgetb ("mclip")
+ sigscale = clgetr ("sigscale")
+
+ # Check lists.
+ n = imtlen (ilist)
+ if (n == 0)
+ call error (1, "No input images to combine")
+ if (project) {
+ if (imtlen (olist) != n)
+ call error (1, "Wrong number of images in output list")
+ if (imtlen (rlist) != 0 && imtlen (rlist) != n)
+ call error (1, "Wrong number of masks in rejection mask list")
+ if (imtlen (plist) > 0 && imtlen (plist) != n)
+ call error (1, "Wrong number of masks in output mask list")
+ if (imtlen (slist) > 0 && imtlen (slist) != n)
+ call error (1, "Wrong number of images in output sigma list")
+ } else {
+ if (imtlen (olist) != 1)
+ call error (1, "Wrong number of images in output list")
+ if (imtlen (rlist) > 1)
+ call error (1, "Wrong number of masks in rejection mask list")
+ if (imtlen (plist) > 1)
+ call error (1, "Wrong number of masks in output mask list")
+ if (imtlen (slist) > 1)
+ call error (1, "Wrong number of images in output sigma list")
+ }
+
+ # Check parameters, map INDEFs, and set threshold flag
+ if (pclip == 0. && reject == PCLIP)
+ call error (1, "Pclip parameter may not be zero")
+ if (IS_INDEFR (blank))
+ blank = 0.
+ if (IS_INDEFR (lsigma))
+ lsigma = MAX_REAL
+ if (IS_INDEFR (hsigma))
+ hsigma = MAX_REAL
+ if (IS_INDEFR (pclip))
+ pclip = -0.5
+ if (IS_INDEFR (flow))
+ flow = 0
+ if (IS_INDEFR (fhigh))
+ fhigh = 0
+ if (IS_INDEFR (grow))
+ grow = 0.
+ if (IS_INDEF (sigscale))
+ sigscale = 0.
+
+ if (IS_INDEF(lthresh) && IS_INDEF(hthresh))
+ dothresh = false
+ else {
+ dothresh = true
+ if (IS_INDEF(lthresh))
+ lthresh = -MAX_REAL
+ if (IS_INDEF(hthresh))
+ hthresh = MAX_REAL
+ }
+
+ # Loop through image lists. Note that if not projecting then
+ # the input and rejmask lists will be exhausted by IMCOMBINE.
+
+ while (imtgetim (ilist, Memc[input], SZ_FNAME) != EOF) {
+ if (imtgetim (olist, Memc[output], SZ_FNAME) == EOF) {
+ if (project) {
+ call eprintf ("IMCOMBINE: No output image for %s\n")
+ call pargstr (Memc[input])
+ next
+ } else {
+ call eprintf ("IMCOMBINE: No output image\n")
+ call pargstr (Memc[input])
+ break
+ }
+ }
+ if (imtgetim (rlist, Memc[rmask], SZ_FNAME) == EOF)
+ Memc[rmask] = EOS
+ if (imtgetim (plist, Memc[plfile], SZ_FNAME) == EOF)
+ Memc[plfile] = EOS
+ if (imtgetim (slist, Memc[sigma], SZ_FNAME) == EOF)
+ Memc[sigma] = EOS
+
+ iferr (call icombine (ilist, Memc[input], Memc[output],
+ Memc[rmask], Memc[plfile], Memc[sigma], Memc[logfile], NO))
+ call erract (EA_WARN)
+ }
+
+ call imtclose (ilist)
+ call imtclose (olist)
+ call imtclose (rlist)
+ call imtclose (plist)
+ call imtclose (slist)
+ call sfree (sp)
+end
+
+
+# IMCOMBINE -- Combine input list or image.
+# This procedure maps the images, sets the output dimensions and datatype,
+# opens the logfile, and sets IMIO parameters. It attempts to adjust
+# buffer sizes and memory requirements for maximum efficiency.
+
+procedure icombine (list, input, output, rmask, plfile, sigma,
+ logfile, stack)
+
+int list # List of input images
+char input[ARB] # Input image
+char output[ARB] # Output image
+char rmask[ARB] # Rejection mask
+char plfile[ARB] # Output pixel list file
+char sigma[ARB] # Sigma image (optional)
+char logfile[ARB] # Logfile (optional)
+int stack # Stack input images?
+
+char errstr[SZ_LINE]
+int i, j, nimages, intype, bufsize, maxsize, memory, oldsize, stack1, err
+pointer sp, in, out[4], icm, offsets, key, tmp
+
+char clgetc()
+int imtlen(), imtgetim(), imtrgetim(), getdatatype()
+int begmem(), errget(), open(), ty_max(), sizeof()
+pointer immap(), ic_pmmap()
+errchk ic_imstack, immap, ic_pmmap, ic_setout
+
+include "icombine.com"
+
+define retry_ 98
+
+begin
+ # Map the input images.
+ bufsize = 0
+ stack1 = stack
+
+retry_
+ iferr {
+ call smark (sp)
+
+ in = NULL
+ out[1] = NULL
+ out[2] = NULL
+ out[3] = NULL
+ out[4] = NULL
+ icm = NULL
+ logfd = NULL
+
+ # Stack the input images.
+ if (stack1 == YES) {
+ call mktemp ("tmp", input, SZ_FNAME)
+ call imtrew (list)
+ call ic_imstack (list, input)
+ project = true
+ }
+
+ # Open the input image(s).
+ nimages = 0
+ if (project) {
+ tmp = immap (input, READ_ONLY, 0); out[1] = tmp
+ if (IM_NDIM(out[1]) == 1)
+ call error (1, "Can't project one dimensional images")
+ nimages = IM_LEN(out[1],IM_NDIM(out[1]))
+ call salloc (in, nimages, TY_POINTER)
+ call amovki (out[1], Memi[in], nimages)
+ } else {
+ call salloc (in, imtlen(list), TY_POINTER)
+ call amovki (NULL, Memi[in], imtlen(list))
+ call imtrew (list)
+ while (imtgetim (list, input, SZ_FNAME)!=EOF) {
+ tmp = immap (input, READ_ONLY, 0)
+ Memi[in+nimages] = tmp
+ nimages = nimages + 1
+ }
+ }
+
+ # Check if there are no images.
+ if (nimages == 0)
+ call error (1, "No input images to combine")
+
+ # Convert the pclip parameter to a number of pixels rather than
+ # a fraction. This number stays constant even if pixels are
+ # rejected. The number of low and high pixel rejected, however,
+ # are converted to a fraction of the valid pixels.
+
+ if (reject == PCLIP) {
+ i = (nimages - 1) / 2.
+ if (abs (pclip) < 1.)
+ pclip = pclip * i
+ if (pclip < 0.)
+ pclip = min (-1, max (-i, int (pclip)))
+ else
+ pclip = max (1, min (i, int (pclip)))
+ }
+
+ if (reject == MINMAX) {
+ if (flow >= 1)
+ flow = flow / nimages
+ if (fhigh >= 1)
+ fhigh = fhigh / nimages
+ i = flow * nimages
+ j = fhigh * nimages
+ if (i + j == 0)
+ reject = NONE
+ else if (i + j >= nimages)
+ call error (1, "Bad minmax rejection parameters")
+ }
+
+ # Map the output image and set dimensions and offsets.
+ tmp = immap (output, NEW_COPY, Memi[in]); out[1] = tmp
+ if (stack1 == YES) {
+ call salloc (key, SZ_FNAME, TY_CHAR)
+ do i = 1, nimages {
+ call sprintf (Memc[key], SZ_FNAME, "stck%04d")
+ call pargi (i)
+ call imdelf (out[1], Memc[key])
+ }
+ }
+ call salloc (offsets, nimages*IM_NDIM(out[1]), TY_INT)
+ call ic_setout (Memi[in], out, Memi[offsets], nimages)
+
+ # Determine the highest precedence datatype and set output datatype.
+ intype = IM_PIXTYPE(Memi[in])
+ do i = 2, nimages
+ intype = ty_max (intype, IM_PIXTYPE(Memi[in+i-1]))
+ IM_PIXTYPE(out[1]) = getdatatype (clgetc ("outtype"))
+ if (IM_PIXTYPE(out[1]) == ERR)
+ IM_PIXTYPE(out[1]) = intype
+
+ # Open rejection masks
+ if (rmask[1] != EOS) {
+ tmp = ic_pmmap (rmask, NEW_COPY, out[1]); out[4] = tmp
+ IM_NDIM(out[4]) = IM_NDIM(out[4]) + 1
+ IM_LEN(out[4],IM_NDIM(out[4])) = nimages
+ if (!project) {
+ if (key == NULL)
+ call salloc (key, SZ_FNAME, TY_CHAR)
+ do i = 1, nimages {
+ j = imtrgetim (list, i, input, SZ_FNAME)
+ call sprintf (Memc[key], SZ_FNAME, "mask%04d")
+ call pargi (i)
+ call imastr (out[4], Memc[key], input)
+ }
+ }
+ } else
+ out[4] = NULL
+
+ # Open pixel list file if given.
+ if (plfile[1] != EOS) {
+ tmp = ic_pmmap (plfile, NEW_COPY, out[1]); out[2] = tmp
+ } else
+ out[2] = NULL
+
+ # Open the sigma image if given.
+ if (sigma[1] != EOS) {
+ tmp = immap (sigma, NEW_COPY, out[1]); out[3] = tmp
+ IM_PIXTYPE(out[3]) = ty_max (TY_REAL, IM_PIXTYPE(out[1]))
+ call sprintf (IM_TITLE(out[3]), SZ_IMTITLE,
+ "Combine sigma images for %s")
+ call pargstr (output)
+ } else
+ out[3] = NULL
+
+ # Open masks.
+ call ic_mopen (Memi[in], out, nimages)
+ icm = nimages
+
+ # Open the log file.
+ logfd = NULL
+ if (logfile[1] != EOS) {
+ iferr (logfd = open (logfile, APPEND, TEXT_FILE)) {
+ logfd = NULL
+ call erract (EA_WARN)
+ }
+ }
+
+ if (bufsize == 0) {
+ # Set initial IMIO buffer size based on the number of images
+ # and maximum amount of working memory available. The buffer
+ # size may be adjusted later if the task runs out of memory.
+ # The FUDGE factor is used to allow for the size of the
+ # program, memory allocator inefficiencies, and any other
+ # memory requirements besides IMIO.
+
+ bufsize = 1
+ do i = 1, IM_NDIM(out[1])
+ bufsize = bufsize * IM_LEN(out[1],i)
+ bufsize = bufsize * sizeof (intype)
+ bufsize = min (bufsize, DEFBUFSIZE)
+ memory = begmem ((nimages + 1) * bufsize, oldsize, maxsize)
+ memory = min (memory, int (FUDGE * maxsize))
+ bufsize = memory / (nimages + 1)
+ }
+
+ # Combine the images. If an out of memory error occurs close all
+ # images and files, divide the IMIO buffer size in half and try
+ # again. The integer types are not support because scaling is
+ # done on the input data vectors.
+
+ switch (ty_max (intype, IM_PIXTYPE(out[1]))) {
+ case TY_SHORT:
+ call icombines (Memi[in], out, Memi[offsets], nimages, bufsize)
+ case TY_USHORT, TY_INT, TY_LONG:
+ call icombinei (Memi[in], out, Memi[offsets], nimages, bufsize)
+ case TY_DOUBLE:
+ call icombined (Memi[in], out, Memi[offsets], nimages, bufsize)
+ case TY_COMPLEX:
+ call error (1, "Complex images not allowed")
+ default:
+ call icombiner (Memi[in], out, Memi[offsets], nimages, bufsize)
+ }
+ } then {
+ err = errget (errstr, SZ_LINE)
+ if (icm != NULL)
+ call ic_mclose (nimages)
+ if (!project) {
+ do j = 2, nimages {
+ if (Memi[in+j-1] != NULL)
+ call imunmap (Memi[in+j-1])
+ }
+ }
+ if (out[2] != NULL)
+ call imunmap (out[2])
+ if (out[3] != NULL) {
+ call imunmap (out[3])
+ call imdelete (sigma)
+ }
+ if (out[4] != NULL)
+ call imunmap (out[4])
+ if (out[1] != NULL) {
+ call imunmap (out[1])
+ call imdelete (output)
+ }
+ if (Memi[in] != NULL)
+ call imunmap (Memi[in])
+ if (logfd != NULL)
+ call close (logfd)
+
+ switch (err) {
+ case SYS_MFULL:
+ bufsize = bufsize / 2
+ call sfree (sp)
+ goto retry_
+ case SYS_FTOOMANYFILES, SYS_IKIOPEN, SYS_IKIOPIX:
+ if (!project) {
+ stack1 = YES
+ goto retry_
+ }
+ if (stack1 == YES)
+ call imdelete (input)
+ call fixmem (oldsize)
+ call sfree (sp)
+ call error (err, errstr)
+ default:
+ if (stack1 == YES)
+ call imdelete (input)
+ call fixmem (oldsize)
+ call sfree (sp)
+ call error (err, errstr)
+ }
+ }
+
+ # Unmap all the images, close the log file, and restore memory.
+ # The input images must be unmapped first to insure that there
+ # is a FD for the output images since the headers are opened to
+ # update them. However, the order of the NEW_COPY pointers must
+ # be preserved.
+
+ if (!project) {
+ do i = 2, nimages
+ if (Memi[in+i-1] != NULL)
+ call imunmap (Memi[in+i-1])
+ }
+ if (out[2] != NULL)
+ call imunmap (out[2])
+ if (out[3] != NULL)
+ call imunmap (out[3])
+ if (out[4] != NULL)
+ call imunmap (out[4])
+ if (out[1] != NULL)
+ call imunmap (out[1])
+ if (Memi[in] != NULL)
+ call imunmap (Memi[in])
+ if (stack1 == YES)
+ call imdelete (input)
+ if (logfd != NULL)
+ call close (logfd)
+ if (icm != NULL)
+ call ic_mclose (nimages)
+ call fixmem (oldsize)
+ call sfree (sp)
+end
+
+
+# TY_MAX -- Return the datatype of highest precedence.
+
+int procedure ty_max (type1, type2)
+
+int type1, type2 # Datatypes
+
+int i, j, type, order[8]
+data order/TY_SHORT,TY_USHORT,TY_INT,TY_LONG,TY_REAL,TY_DOUBLE,TY_COMPLEX,TY_REAL/
+
+begin
+ for (i=1; (i<=7) && (type1!=order[i]); i=i+1)
+ ;
+ for (j=1; (j<=7) && (type2!=order[j]); j=j+1)
+ ;
+ type = order[max(i,j)]
+
+ # Special case of mixing short and unsigned short.
+ if (type == TY_USHORT && type1 != type2)
+ type = TY_INT
+
+ return (type)
+end
+
+
+# IC_PMMAP -- Map pixel mask.
+
+pointer procedure ic_pmmap (fname, mode, refim)
+
+char fname[ARB] # Mask name
+int mode # Image mode
+pointer refim # Reference image
+pointer pm # IMIO pointer (returned)
+
+int i, fnextn()
+pointer sp, extn, immap()
+bool streq()
+
+begin
+ call smark (sp)
+ call salloc (extn, SZ_FNAME, TY_CHAR)
+
+ i = fnextn (fname, Memc[extn], SZ_FNAME)
+ if (streq (Memc[extn], "pl"))
+ pm = immap (fname, mode, refim)
+ else {
+ call strcpy (fname, Memc[extn], SZ_FNAME)
+ call strcat (".pl", Memc[extn], SZ_FNAME)
+ pm = immap (Memc[extn], mode, refim)
+ }
+
+ call sfree (sp)
+ return (pm)
+end