diff options
Diffstat (limited to 'pkg/images/immatch/src')
132 files changed, 57791 insertions, 0 deletions
diff --git a/pkg/images/immatch/src/geometry/geofunc.gx b/pkg/images/immatch/src/geometry/geofunc.gx new file mode 100644 index 00000000..3b34a207 --- /dev/null +++ b/pkg/images/immatch/src/geometry/geofunc.gx @@ -0,0 +1,250 @@ +include <math.h> +include <math/gsurfit.h> + +$for (rd) + +# GEO_DROTMAG -- Adjust the coefficients of the fit using the database file. + +procedure geo_drotmag$t (dt, rec, sx1, sy1, xmag, ymag, xrot, yrot) + +pointer dt #I pointer to the text database file +int rec #I record number +pointer sx1, sy1 #I/O pointers to the x and y linear surfaces +PIXEL xmag, ymag #I/O the x and y magnification +PIXEL xrot, yrot #I/O the x and y axis rotation + +real dtgetr() + +begin + if (IS_$INDEF$T(xmag)) + xmag = PIXEL (dtgetr (dt, rec, "xmag")) + if (IS_$INDEF$T(ymag)) + ymag = PIXEL (dtgetr (dt, rec, "ymag")) + if (IS_$INDEF$T(xrot)) + xrot = DEGTORAD (PIXEL(dtgetr (dt, rec, "xrotation"))) + else + xrot = DEGTORAD(xrot) + if (IS_$INDEF$T(yrot)) + yrot = DEGTORAD (PIXEL (dtgetr (dt, rec, "yrotation"))) + else + yrot = DEGTORAD(yrot) + call geo_rotmag$t (sx1, sy1, xmag, ymag, xrot, yrot) +end + + +# GEO_DXYSHIFT -- Adjust the fitted xy shift using the database file. + +procedure geo_dxyshift$t (dt, rec, sx1, sy1, xout, yout, xref, yref, + xshift, yshift) + +pointer dt #I pointer to the text file database +int rec #I the database record +pointer sx1, sy1 #I/O pointers to the x and y linear surfaces +PIXEL xout, yout #I the input coordinate system origin +PIXEL xref, yref #I the reference coordinate system origin +PIXEL xshift, yshift #I the origin shift in input coordinates + +$if (datatype == r) +PIXEL gsgetr(), gseval() +$else +PIXEL dgsgetd(), dgseval() +$endif + +begin +$if (datatype == r) + if (IS_$INDEF$T(xref)) + xref = (gsgetr (sx1, GSXMIN) + gsgetr (sx1, GSXMAX)) / 2.0 + if (IS_$INDEF$T(yref)) + yref = (gsgetr (sy1, GSYMIN) + gsgetr (sy1, GSYMAX)) / 2.0 + + if (IS_$INDEF$T(xout)) + xout = gseval (sx1, xref, yref) + if (IS_$INDEF$T(yout)) + yout = gseval (sy1, xref, yref) + + if (IS_$INDEF$T(xshift)) + xshift = xout - gseval (sx1, xref, yref) + if (IS_$INDEF$T(yshift)) + yshift = yout - gseval (sy1, xref, yref) +$else + if (IS_$INDEF$T(xref)) + xref = (dgsgetd (sx1, GSXMIN) + dgsgetd (sx1, GSXMAX)) / 2.0d0 + if (IS_$INDEF$T(yref)) + yref = (dgsgetd (sy1, GSYMIN) + dgsgetd (sy1, GSYMAX)) / 2.0d0 + + if (IS_$INDEF$T(xout)) + xout = dgseval (sx1, xref, yref) + if (IS_$INDEF$T(yout)) + yout = dgseval (sy1, xref, yref) + + if (IS_$INDEF$T(xshift)) + xshift = xout - dgseval (sx1, xref, yref) + if (IS_$INDEF$T(yshift)) + yshift = yout - dgseval (sy1, xref, yref) +$endif + + call geo_xyshift$t (sx1, sy1, xshift, yshift) +end + + +# GEO_ROTMAG -- Edit the coefficients of the linear surface which determine +# magnification and rotation. + +procedure geo_rotmag$t (sx1, sy1, xscale, yscale, xrotation, yrotation) + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +PIXEL xscale, yscale #I the x and y scales +PIXEL xrotation,yrotation #I the x and y axis rotation angles in radians + +PIXEL cosx, sinx, cosy, siny, xrange, yrange +int ncoeff +pointer sp, xcoeff, ycoeff +$if (datatype == r) +real gsgetr() +int gsgeti() +$else +double dgsgetd() +int dgsgeti() +$endif + +begin + # Get the current solution. + call smark (sp) +$if (datatype == r) + ncoeff = max (gsgeti (sx1, GSNSAVE), gsgeti (sy1, GSNSAVE)) +$else + ncoeff = max (dgsgeti (sx1, GSNSAVE), dgsgeti (sy1, GSNSAVE)) +$endif + call salloc (xcoeff, ncoeff, TY_PIXEL) + call salloc (ycoeff, ncoeff, TY_PIXEL) +$if (datatype == r) + call gssave (sx1, Mem$t[xcoeff]) + call gssave (sy1, Mem$t[ycoeff]) +$else + call dgssave (sx1, Mem$t[xcoeff]) + call dgssave (sy1, Mem$t[ycoeff]) +$endif + + # Define the scaling parameters. + cosx = cos (xrotation) + sinx = sin (xrotation) + cosy = cos (yrotation) + siny = sin (yrotation) + + # Calculate coefficients. + Mem$t[xcoeff+GS_SAVECOEFF+1] = xscale * cosx + Mem$t[xcoeff+GS_SAVECOEFF+2] = yscale * siny + Mem$t[ycoeff+GS_SAVECOEFF+1] = -xscale * sinx + Mem$t[ycoeff+GS_SAVECOEFF+2] = yscale * cosy + + # Normalize coefficients for-non polynomial functions. +$if (datatype == r) + if (gsgeti (sx1, GSTYPE) != GS_POLYNOMIAL) { + xrange = gsget$t (sx1, GSXMAX) - gsget$t (sx1, GSXMIN) +$else + if (dgsgeti (sx1, GSTYPE) != GS_POLYNOMIAL) { + xrange = dgsget$t (sx1, GSXMAX) - dgsget$t (sx1, GSXMIN) +$endif + Mem$t[xcoeff+GS_SAVECOEFF+1] = Mem$t[xcoeff+GS_SAVECOEFF+1] * + xrange / 2.d0 + Mem$t[xcoeff+GS_SAVECOEFF+2] = Mem$t[xcoeff+GS_SAVECOEFF+2] * + yrange / 2.d0 + } +$if (datatype == r) + if (gsgeti (sy1, GSTYPE) != GS_POLYNOMIAL) { + yrange = gsget$t (sy1, GSYMAX) - gsget$t (sy1, GSYMIN) +$else + if (dgsgeti (sy1, GSTYPE) != GS_POLYNOMIAL) { + yrange = dgsget$t (sy1, GSYMAX) - dgsget$t (sy1, GSYMIN) +$endif + Mem$t[ycoeff+GS_SAVECOEFF+1] = Mem$t[ycoeff+GS_SAVECOEFF+1] * + xrange / 2.d0 + Mem$t[ycoeff+GS_SAVECOEFF+2] = Mem$t[ycoeff+GS_SAVECOEFF+2] * + yrange / 2.d0 + } + +$if (datatype == r) + # Free the original fit. + call gsfree (sx1) + call gsfree (sy1) + + # Restore the edited fit. + call gsrestore (sx1, Mem$t[xcoeff]) + call gsrestore (sy1, Mem$t[ycoeff]) +$else + # Free the original fit. + call dgsfree (sx1) + call dgsfree (sy1) + + # Restore the edited fit. + call dgsrestore (sx1, Mem$t[xcoeff]) + call dgsrestore (sy1, Mem$t[ycoeff]) +$endif + + call sfree (sp) +end + + +# GEO_XYSHIFT -- Shift the linear part of the fit in x and y. + +procedure geo_xyshift$t (sx1, sy1, xshift, yshift) + +pointer sx1, sy1 #I pointers to linear x and y surfaces +PIXEL xshift, yshift #I the input x and y shifts + +int ncoeff +pointer sp, xcoeff, ycoeff +$if (datatype == r) +int gsgeti() +$else +int dgsgeti() +$endif + +begin + call smark (sp) + + # Allocate working space. +$if (datatype == r) + ncoeff = max (gsgeti (sx1, GSNSAVE), gsgeti (sy1, GSNSAVE)) +$else + ncoeff = max (dgsgeti (sx1, GSNSAVE), dgsgeti (sy1, GSNSAVE)) +$endif + call salloc (xcoeff, ncoeff, TY_PIXEL) + call salloc (ycoeff, ncoeff, TY_PIXEL) + + # Get coefficients. +$if (datatype == r) + call gssave (sx1, Mem$t[xcoeff]) + call gssave (sy1, Mem$t[ycoeff]) +$else + call dgssave (sx1, Mem$t[xcoeff]) + call dgssave (sy1, Mem$t[ycoeff]) +$endif + + # Shift the coefficients. + Mem$t[xcoeff+GS_SAVECOEFF] = Mem$t[xcoeff+GS_SAVECOEFF] + xshift + Mem$t[ycoeff+GS_SAVECOEFF] = Mem$t[ycoeff+GS_SAVECOEFF] + yshift + +$if (datatype == r) + # Free original fit. + call gsfree (sx1) + call gsfree (sy1) + + # Restore fit. + call gsrestore (sx1, Mem$t[xcoeff]) + call gsrestore (sy1, Mem$t[ycoeff]) +$else + # Free original fit. + call dgsfree (sx1) + call dgsfree (sy1) + + # Restore fit. + call dgsrestore (sx1, Mem$t[xcoeff]) + call dgsrestore (sy1, Mem$t[ycoeff]) +$endif + + call sfree (sp) +end + + +$endfor diff --git a/pkg/images/immatch/src/geometry/geofunc.x b/pkg/images/immatch/src/geometry/geofunc.x new file mode 100644 index 00000000..c3be8fa5 --- /dev/null +++ b/pkg/images/immatch/src/geometry/geofunc.x @@ -0,0 +1,340 @@ +include <math.h> +include <math/gsurfit.h> + + + +# GEO_DROTMAG -- Adjust the coefficients of the fit using the database file. + +procedure geo_drotmagr (dt, rec, sx1, sy1, xmag, ymag, xrot, yrot) + +pointer dt #I pointer to the text database file +int rec #I record number +pointer sx1, sy1 #I/O pointers to the x and y linear surfaces +real xmag, ymag #I/O the x and y magnification +real xrot, yrot #I/O the x and y axis rotation + +real dtgetr() + +begin + if (IS_INDEFR(xmag)) + xmag = real (dtgetr (dt, rec, "xmag")) + if (IS_INDEFR(ymag)) + ymag = real (dtgetr (dt, rec, "ymag")) + if (IS_INDEFR(xrot)) + xrot = DEGTORAD (real(dtgetr (dt, rec, "xrotation"))) + else + xrot = DEGTORAD(xrot) + if (IS_INDEFR(yrot)) + yrot = DEGTORAD (real (dtgetr (dt, rec, "yrotation"))) + else + yrot = DEGTORAD(yrot) + call geo_rotmagr (sx1, sy1, xmag, ymag, xrot, yrot) +end + + +# GEO_DXYSHIFT -- Adjust the fitted xy shift using the database file. + +procedure geo_dxyshiftr (dt, rec, sx1, sy1, xout, yout, xref, yref, + xshift, yshift) + +pointer dt #I pointer to the text file database +int rec #I the database record +pointer sx1, sy1 #I/O pointers to the x and y linear surfaces +real xout, yout #I the input coordinate system origin +real xref, yref #I the reference coordinate system origin +real xshift, yshift #I the origin shift in input coordinates + +real gsgetr(), gseval() + +begin + if (IS_INDEFR(xref)) + xref = (gsgetr (sx1, GSXMIN) + gsgetr (sx1, GSXMAX)) / 2.0 + if (IS_INDEFR(yref)) + yref = (gsgetr (sy1, GSYMIN) + gsgetr (sy1, GSYMAX)) / 2.0 + + if (IS_INDEFR(xout)) + xout = gseval (sx1, xref, yref) + if (IS_INDEFR(yout)) + yout = gseval (sy1, xref, yref) + + if (IS_INDEFR(xshift)) + xshift = xout - gseval (sx1, xref, yref) + if (IS_INDEFR(yshift)) + yshift = yout - gseval (sy1, xref, yref) + + call geo_xyshiftr (sx1, sy1, xshift, yshift) +end + + +# GEO_ROTMAG -- Edit the coefficients of the linear surface which determine +# magnification and rotation. + +procedure geo_rotmagr (sx1, sy1, xscale, yscale, xrotation, yrotation) + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +real xscale, yscale #I the x and y scales +real xrotation,yrotation #I the x and y axis rotation angles in radians + +real cosx, sinx, cosy, siny, xrange, yrange +int ncoeff +pointer sp, xcoeff, ycoeff +real gsgetr() +int gsgeti() + +begin + # Get the current solution. + call smark (sp) + ncoeff = max (gsgeti (sx1, GSNSAVE), gsgeti (sy1, GSNSAVE)) + call salloc (xcoeff, ncoeff, TY_REAL) + call salloc (ycoeff, ncoeff, TY_REAL) + call gssave (sx1, Memr[xcoeff]) + call gssave (sy1, Memr[ycoeff]) + + # Define the scaling parameters. + cosx = cos (xrotation) + sinx = sin (xrotation) + cosy = cos (yrotation) + siny = sin (yrotation) + + # Calculate coefficients. + Memr[xcoeff+GS_SAVECOEFF+1] = xscale * cosx + Memr[xcoeff+GS_SAVECOEFF+2] = yscale * siny + Memr[ycoeff+GS_SAVECOEFF+1] = -xscale * sinx + Memr[ycoeff+GS_SAVECOEFF+2] = yscale * cosy + + # Normalize coefficients for-non polynomial functions. + if (gsgeti (sx1, GSTYPE) != GS_POLYNOMIAL) { + xrange = gsgetr (sx1, GSXMAX) - gsgetr (sx1, GSXMIN) + Memr[xcoeff+GS_SAVECOEFF+1] = Memr[xcoeff+GS_SAVECOEFF+1] * + xrange / 2.d0 + Memr[xcoeff+GS_SAVECOEFF+2] = Memr[xcoeff+GS_SAVECOEFF+2] * + yrange / 2.d0 + } + if (gsgeti (sy1, GSTYPE) != GS_POLYNOMIAL) { + yrange = gsgetr (sy1, GSYMAX) - gsgetr (sy1, GSYMIN) + Memr[ycoeff+GS_SAVECOEFF+1] = Memr[ycoeff+GS_SAVECOEFF+1] * + xrange / 2.d0 + Memr[ycoeff+GS_SAVECOEFF+2] = Memr[ycoeff+GS_SAVECOEFF+2] * + yrange / 2.d0 + } + + # Free the original fit. + call gsfree (sx1) + call gsfree (sy1) + + # Restore the edited fit. + call gsrestore (sx1, Memr[xcoeff]) + call gsrestore (sy1, Memr[ycoeff]) + + call sfree (sp) +end + + +# GEO_XYSHIFT -- Shift the linear part of the fit in x and y. + +procedure geo_xyshiftr (sx1, sy1, xshift, yshift) + +pointer sx1, sy1 #I pointers to linear x and y surfaces +real xshift, yshift #I the input x and y shifts + +int ncoeff +pointer sp, xcoeff, ycoeff +int gsgeti() + +begin + call smark (sp) + + # Allocate working space. + ncoeff = max (gsgeti (sx1, GSNSAVE), gsgeti (sy1, GSNSAVE)) + call salloc (xcoeff, ncoeff, TY_REAL) + call salloc (ycoeff, ncoeff, TY_REAL) + + # Get coefficients. + call gssave (sx1, Memr[xcoeff]) + call gssave (sy1, Memr[ycoeff]) + + # Shift the coefficients. + Memr[xcoeff+GS_SAVECOEFF] = Memr[xcoeff+GS_SAVECOEFF] + xshift + Memr[ycoeff+GS_SAVECOEFF] = Memr[ycoeff+GS_SAVECOEFF] + yshift + + # Free original fit. + call gsfree (sx1) + call gsfree (sy1) + + # Restore fit. + call gsrestore (sx1, Memr[xcoeff]) + call gsrestore (sy1, Memr[ycoeff]) + + call sfree (sp) +end + + + + +# GEO_DROTMAG -- Adjust the coefficients of the fit using the database file. + +procedure geo_drotmagd (dt, rec, sx1, sy1, xmag, ymag, xrot, yrot) + +pointer dt #I pointer to the text database file +int rec #I record number +pointer sx1, sy1 #I/O pointers to the x and y linear surfaces +double xmag, ymag #I/O the x and y magnification +double xrot, yrot #I/O the x and y axis rotation + +real dtgetr() + +begin + if (IS_INDEFD(xmag)) + xmag = double (dtgetr (dt, rec, "xmag")) + if (IS_INDEFD(ymag)) + ymag = double (dtgetr (dt, rec, "ymag")) + if (IS_INDEFD(xrot)) + xrot = DEGTORAD (double(dtgetr (dt, rec, "xrotation"))) + else + xrot = DEGTORAD(xrot) + if (IS_INDEFD(yrot)) + yrot = DEGTORAD (double (dtgetr (dt, rec, "yrotation"))) + else + yrot = DEGTORAD(yrot) + call geo_rotmagd (sx1, sy1, xmag, ymag, xrot, yrot) +end + + +# GEO_DXYSHIFT -- Adjust the fitted xy shift using the database file. + +procedure geo_dxyshiftd (dt, rec, sx1, sy1, xout, yout, xref, yref, + xshift, yshift) + +pointer dt #I pointer to the text file database +int rec #I the database record +pointer sx1, sy1 #I/O pointers to the x and y linear surfaces +double xout, yout #I the input coordinate system origin +double xref, yref #I the reference coordinate system origin +double xshift, yshift #I the origin shift in input coordinates + +double dgsgetd(), dgseval() + +begin + if (IS_INDEFD(xref)) + xref = (dgsgetd (sx1, GSXMIN) + dgsgetd (sx1, GSXMAX)) / 2.0d0 + if (IS_INDEFD(yref)) + yref = (dgsgetd (sy1, GSYMIN) + dgsgetd (sy1, GSYMAX)) / 2.0d0 + + if (IS_INDEFD(xout)) + xout = dgseval (sx1, xref, yref) + if (IS_INDEFD(yout)) + yout = dgseval (sy1, xref, yref) + + if (IS_INDEFD(xshift)) + xshift = xout - dgseval (sx1, xref, yref) + if (IS_INDEFD(yshift)) + yshift = yout - dgseval (sy1, xref, yref) + + call geo_xyshiftd (sx1, sy1, xshift, yshift) +end + + +# GEO_ROTMAG -- Edit the coefficients of the linear surface which determine +# magnification and rotation. + +procedure geo_rotmagd (sx1, sy1, xscale, yscale, xrotation, yrotation) + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +double xscale, yscale #I the x and y scales +double xrotation,yrotation #I the x and y axis rotation angles in radians + +double cosx, sinx, cosy, siny, xrange, yrange +int ncoeff +pointer sp, xcoeff, ycoeff +double dgsgetd() +int dgsgeti() + +begin + # Get the current solution. + call smark (sp) + ncoeff = max (dgsgeti (sx1, GSNSAVE), dgsgeti (sy1, GSNSAVE)) + call salloc (xcoeff, ncoeff, TY_DOUBLE) + call salloc (ycoeff, ncoeff, TY_DOUBLE) + call dgssave (sx1, Memd[xcoeff]) + call dgssave (sy1, Memd[ycoeff]) + + # Define the scaling parameters. + cosx = cos (xrotation) + sinx = sin (xrotation) + cosy = cos (yrotation) + siny = sin (yrotation) + + # Calculate coefficients. + Memd[xcoeff+GS_SAVECOEFF+1] = xscale * cosx + Memd[xcoeff+GS_SAVECOEFF+2] = yscale * siny + Memd[ycoeff+GS_SAVECOEFF+1] = -xscale * sinx + Memd[ycoeff+GS_SAVECOEFF+2] = yscale * cosy + + # Normalize coefficients for-non polynomial functions. + if (dgsgeti (sx1, GSTYPE) != GS_POLYNOMIAL) { + xrange = dgsgetd (sx1, GSXMAX) - dgsgetd (sx1, GSXMIN) + Memd[xcoeff+GS_SAVECOEFF+1] = Memd[xcoeff+GS_SAVECOEFF+1] * + xrange / 2.d0 + Memd[xcoeff+GS_SAVECOEFF+2] = Memd[xcoeff+GS_SAVECOEFF+2] * + yrange / 2.d0 + } + if (dgsgeti (sy1, GSTYPE) != GS_POLYNOMIAL) { + yrange = dgsgetd (sy1, GSYMAX) - dgsgetd (sy1, GSYMIN) + Memd[ycoeff+GS_SAVECOEFF+1] = Memd[ycoeff+GS_SAVECOEFF+1] * + xrange / 2.d0 + Memd[ycoeff+GS_SAVECOEFF+2] = Memd[ycoeff+GS_SAVECOEFF+2] * + yrange / 2.d0 + } + + # Free the original fit. + call dgsfree (sx1) + call dgsfree (sy1) + + # Restore the edited fit. + call dgsrestore (sx1, Memd[xcoeff]) + call dgsrestore (sy1, Memd[ycoeff]) + + call sfree (sp) +end + + +# GEO_XYSHIFT -- Shift the linear part of the fit in x and y. + +procedure geo_xyshiftd (sx1, sy1, xshift, yshift) + +pointer sx1, sy1 #I pointers to linear x and y surfaces +double xshift, yshift #I the input x and y shifts + +int ncoeff +pointer sp, xcoeff, ycoeff +int dgsgeti() + +begin + call smark (sp) + + # Allocate working space. + ncoeff = max (dgsgeti (sx1, GSNSAVE), dgsgeti (sy1, GSNSAVE)) + call salloc (xcoeff, ncoeff, TY_DOUBLE) + call salloc (ycoeff, ncoeff, TY_DOUBLE) + + # Get coefficients. + call dgssave (sx1, Memd[xcoeff]) + call dgssave (sy1, Memd[ycoeff]) + + # Shift the coefficients. + Memd[xcoeff+GS_SAVECOEFF] = Memd[xcoeff+GS_SAVECOEFF] + xshift + Memd[ycoeff+GS_SAVECOEFF] = Memd[ycoeff+GS_SAVECOEFF] + yshift + + # Free original fit. + call dgsfree (sx1) + call dgsfree (sy1) + + # Restore fit. + call dgsrestore (sx1, Memd[xcoeff]) + call dgsrestore (sy1, Memd[ycoeff]) + + call sfree (sp) +end + + + diff --git a/pkg/images/immatch/src/geometry/geotimtran.x b/pkg/images/immatch/src/geometry/geotimtran.x new file mode 100644 index 00000000..f84a794d --- /dev/null +++ b/pkg/images/immatch/src/geometry/geotimtran.x @@ -0,0 +1,543 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <mach.h> +include <math/gsurfit.h> +include <math/iminterp.h> +include "geotran.h" + +# GEO_IMTRAN -- Correct an entire image for geometric distortion using the +# transformed coordinates and image interpolation. + +procedure geo_imtran (input, output, geo, sx1, sy1, sx2, sy2) + +pointer input #I pointer to input image +pointer output #I pointer to output image +pointer geo #I pointer to geotran structure +pointer sx1, sy1 #I pointers to linear surface descriptors +pointer sx2, sy2 #I pointer to higher order surface descriptors + +int nincr +pointer sp, xref, yref, msi +real shift +real gsgetr() + +begin + # Initialize the interpolant and compute the out-of-bounds pixel + # margin required. + if (IM_NDIM(input) == 1) { + call asitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), + GT_NSINC(geo), nincr, shift) + call asisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), + nincr, shift, 0.0) + } else { + call msitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), + GT_NSINC(geo), nincr, shift) + call msisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), + nincr, nincr, shift, shift, 0.0) + } + call geo_margset (sx1, sy1, sx2, sy2, GT_XMIN(geo), GT_XMAX(geo), + GT_NCOLS(geo), GT_YMIN(geo), GT_YMAX(geo), GT_NLINES(geo), + GT_INTERPOLANT(geo), GT_NSINC(geo), GT_NXYMARGIN(geo)) + + # Allocate working space. + call smark (sp) + call salloc (xref, GT_NCOLS(geo), TY_REAL) + call salloc (yref, GT_NLINES(geo), TY_REAL) + + # Calculate the reference coordinates of the input image pixels. + call geo_ref (geo, Memr[xref], 1, GT_NCOLS(geo), GT_NCOLS(geo), + Memr[yref], 1, GT_NLINES(geo), GT_NLINES(geo), gsgetr (sx1, + GSXMIN), gsgetr (sx1, GSXMAX), gsgetr (sx1, GSYMIN), gsgetr (sx1, + GSYMAX), GT_ONE) + + # Configure the out-of-bounds pixel references for the input image. + call geo_imset (input, geo, sx1, sy1, sx2, sy2, Memr[xref], + GT_NCOLS(geo), Memr[yref], GT_NLINES(geo)) + + # Interpolate. + call geo_gsvector (input, output, geo, msi, Memr[xref], 1, + GT_NCOLS(geo), Memr[yref], 1, GT_NLINES(geo), sx1, sy1, sx2, sy2) + + # Clean up. + if (IM_NDIM(input) == 1) + call asifree (msi) + else + call msifree (msi) + call sfree (sp) +end + + +# GEO_SIMTRAN -- Correct an entire image for geometric distortion using +# nterpolated coordinate surfaces to speed up computation of the transformed +# coordinates and image interpolation. + +procedure geo_simtran (input, output, geo, sx1, sy1, sx2, sy2) + +pointer input #I pointer to input image +pointer output #I pointer to output image +pointer geo #I pointer to geotran structure +pointer sx1, sy1 #I pointer to linear surface descriptors +pointer sx2, sy2 #I pointer to higher order surface descriptors + +int nxsample, nysample, nincr +pointer sp, xsample, ysample, xinterp, yinterp +pointer xmsi, ymsi, jmsi, msi, xbuf, ybuf, jbuf +real shift +real gsgetr() + +begin + # Allocate working space and intialize the interpolant. + call smark (sp) + call salloc (xsample, GT_NCOLS(geo), TY_REAL) + call salloc (ysample, GT_NLINES(geo), TY_REAL) + call salloc (xinterp, GT_NCOLS(geo), TY_REAL) + call salloc (yinterp, GT_NLINES(geo), TY_REAL) + + # Set up sampling size. + if (GT_NCOLS(geo) == 1) + nxsample = 1 + else + nxsample = GT_NCOLS(geo) / GT_XSAMPLE(geo) + if (GT_NLINES(geo) == 1) + nysample = 1 + else + nysample = GT_NLINES(geo) / GT_YSAMPLE(geo) + + # Initialize interpolants. + if (IM_NDIM(input) == 1) { + call asiinit (xmsi, II_LINEAR) + call asiinit (ymsi, II_LINEAR) + call asitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), + GT_NSINC(geo), nincr, shift) + call asisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), + nincr, shift, 0.0) + if (GT_FLUXCONSERVE(geo) == YES) + call asiinit (jmsi, II_LINEAR) + } else { + call msiinit (xmsi, II_BILINEAR) + call msiinit (ymsi, II_BILINEAR) + call msitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), + GT_NSINC(geo), nincr, shift) + call msisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), + nincr, nincr, shift, shift, 0.0) + if (GT_FLUXCONSERVE(geo) == YES) + call msiinit (jmsi, II_BILINEAR) + } + call geo_margset (sx1, sy1, sx2, sy2, GT_XMIN(geo), GT_XMAX(geo), + GT_NCOLS(geo), GT_YMIN(geo), GT_YMAX(geo), GT_NLINES(geo), + GT_INTERPOLANT(geo), GT_NSINC(geo), GT_NXYMARGIN(geo)) + + # Setup input image boundary extension parameters. + call geo_ref (geo, Memr[xsample], 1, GT_NCOLS(geo), GT_NCOLS(geo), + Memr[ysample], 1, GT_NLINES(geo), GT_NLINES(geo), gsgetr (sx1, + GSXMIN), gsgetr (sx1, GSXMAX), gsgetr (sx1, GSYMIN), gsgetr (sx1, + GSYMAX), GT_ONE) + call geo_imset (input, geo, sx1, sy1, sx2, sy2, Memr[xsample], + GT_NCOLS(geo), Memr[ysample], GT_NLINES(geo)) + + # Calculate the sampled reference coordinates and the interpolated + # reference coordinates. + call geo_ref (geo, Memr[xsample], 1, nxsample, nxsample, Memr[ysample], + 1, nysample, nysample, gsgetr (sx1, GSXMIN), gsgetr (sx1, GSXMAX), + gsgetr (sx1, GSYMIN), gsgetr (sx1, GSYMAX), GT_ONE) + call geo_sample (geo, Memr[xinterp], 1, GT_NCOLS(geo), nxsample, + Memr[yinterp], 1, GT_NLINES(geo), nysample, GT_ONE) + + # Initialize the buffers + xbuf = NULL + ybuf = NULL + jbuf = NULL + + # Set up interpolants + call geo_xbuffer (sx1, sx2, xmsi, Memr[xsample], Memr[ysample], 1, + nxsample, 1, nysample, xbuf) + call geo_ybuffer (sy1, sy2, ymsi, Memr[xsample], Memr[ysample], 1, + nxsample, 1, nysample, ybuf) + if (GT_FLUXCONSERVE(geo) == YES && (sx2 != NULL || sy2 != NULL)) { + if (IM_NDIM(input) == 1) + call geo_jbuffer (sx1, NULL, sx2, NULL, jmsi, Memr[xsample], + Memr[ysample], 1, nxsample, 1, nysample, jbuf) + else + call geo_jbuffer (sx1, sy1, sx2, sy2, jmsi, Memr[xsample], + Memr[ysample], 1, nxsample, 1, nysample, jbuf) + } + + # Transform the image. + call geo_msivector (input, output, geo, xmsi, ymsi, jmsi, msi, + sx1, sy1, sx2, sy2, Memr[xinterp], 1, GT_NCOLS(geo), nxsample, + Memr[yinterp], 1, GT_NLINES(geo), nysample, 1, 1) + + # Free space. + if (IM_NDIM(input) == 1) { + call asifree (xmsi) + call asifree (ymsi) + call asifree (msi) + if (GT_FLUXCONSERVE(geo) == YES) + call asifree (jmsi) + } else { + call msifree (xmsi) + call msifree (ymsi) + call msifree (msi) + if (GT_FLUXCONSERVE(geo) == YES) + call msifree (jmsi) + } + call mfree (xbuf, TY_REAL) + call mfree (ybuf, TY_REAL) + if (jbuf != NULL) + call mfree (jbuf, TY_REAL) + call sfree (sp) +end + + +## GEO_IMSIVECTOR -- Evaluate the output image using interpolated surface +## coordinates. +# +#procedure geo_imsivector (in, out, geo, xmsi, ymsi, jmsi, msi, sx1, sy1, sx2, +# sy2, xref, yref, ncols, nlines) +# +#pointer in #I pointer to input image +#pointer out #I pointer to output image +#pointer geo #I pointer to geotran structure +#pointer xmsi, ymsi #I pointer to the interpolation xy surfaces +#pointer jmsi #I pointer to Jacobian surface +#pointer msi #I pointer to interpolation surface +#pointer sx1, sy1 #I linear surface descriptors +#pointer sx2, sy2 #I distortion surface pointers +#real xref[ARB] #I x reference coordinates +#real yref[ARB] #I y reference coordinates +#int ncols, nlines #I number of columns and rows +# +#int j +#pointer sp, x, y, xin, yin, xout, yout, inbuf, outbuf +#real factor +#pointer imgs1r(), imgs2r(), imps1r(), imps2r() +#real geo_jfactor() +# +#begin +# # Allocate working space. +# call smark (sp) +# call salloc (x, ncols, TY_REAL) +# call salloc (y, ncols, TY_REAL) +# call salloc (xin, ncols, TY_REAL) +# call salloc (yin, ncols, TY_REAL) +# call salloc (xout, ncols, TY_REAL) +# call salloc (yout, ncols, TY_REAL) +# +# # Fit the interpolant +# if (IM_NDIM(in) == 1) +# inbuf = imgs1r (in, 1, int (IM_LEN(in,1))) +# else +# inbuf = imgs2r (in, 1, int (IM_LEN(in,1)), 1, int (IM_LEN(in,2))) +# if (inbuf == EOF) +# call error (0, "Error reading image") +# if (IM_NDIM(in) == 1) +# call asifit (msi, Memr[inbuf], int (IM_LEN(in,1))) +# else +# call msifit (msi, Memr[inbuf], int (IM_LEN(in,1)), +# int (IM_LEN(in,2)), int (IM_LEN(in,1))) +# +# # Compute the output bufferr. +# do j = 1, nlines { +# +# # Compute coordinates. +# call amovkr (yref[j], Memr[y], ncols) +# if (IM_NDIM(in) == 1) { +# call asivector (xmsi, xref, Memr[xin], ncols) +# call asivector (ymsi, xref, Memr[yin], ncols) +# } else { +# call msivector (xmsi, xref, Memr[y], Memr[xin], ncols) +# call msivector (ymsi, xref, Memr[y], Memr[yin], ncols) +# } +# +# # Correct for out-of-bounds pixels. +# call geo_btran (in, geo, Memr[xin], Memr[yin], Memr[xout], +# Memr[yout], ncols) +# +# # Write to output image. +# if (IM_NDIM(in) == 1) +# outbuf = imps1r (out, 1, ncols) +# else +# outbuf = imps2r (out, 1, ncols, j, j) +# if (outbuf == EOF) +# call error (0, "Error writing output image") +# if (IM_NDIM(in) == 1) +# call asivector (msi, Memr[xout], Memr[outbuf], ncols) +# else +# call msivector (msi, Memr[xout], Memr[yout], Memr[outbuf], +# ncols) +# +# # Perform constant boundary extension. +# if (GT_BOUNDARY(geo) == BT_CONSTANT) +# call geo_bconstant (in, geo, Memr[xin], Memr[yin], +# Memr[outbuf], Memr[outbuf], ncols) +# +# # Preserve flux in image. +# if (GT_FLUXCONSERVE(geo) == YES) { +# factor = GT_XSCALE(geo) * GT_YSCALE(geo) +# if (GT_GEOMODE(geo) == GT_LINEAR || (sx2 == NULL && sy2 == +# NULL)) { +# if (IM_NDIM(in) == 1) +# call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, +# NULL), Memr[outbuf], ncols) +# else +# call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, +# sy1), Memr[outbuf], ncols) +# } else { +# if (IM_NDIM(in) == 1) +# call geo_msiflux (jmsi, xref, yref, Memr[outbuf], +# 1, ncols, 0, 1, 1) +# else +# call geo_msiflux (jmsi, xref, yref, Memr[outbuf], +# 1, ncols, j, 1, 1) +# call amulkr (Memr[outbuf], factor, Memr[outbuf], ncols) +# } +# } +# } +# +# call sfree (sp) +#end + + +## GEO_IGSVECTOR -- Evaluate the output image using fitted coordinates. +# +#procedure geo_igsvector (input, output, geo, msi, xref, yref, ncols, nlines, +# sx1, sy1, sx2, sy2) +# +#pointer input #I pointer to input image +#pointer output #I pointer to output image +#pointer geo #I pointer to geotran structure +#pointer msi #I pointer to interpolant +#real xref[ARB] #I x reference array +#real yref[ARB] #I y reference array +#int ncols, nlines #I number of columns and lines +#pointer sx1, sy1 #I pointer to linear surface +#pointer sx2, sy2 #I pointer to distortion surface +# +#int j +#pointer sp, y, xin, yin, xout, yout, temp, inbuf, outbuf +#real factor +#pointer imgs1r(), imgs2r(), imps1r(), imps2r() +#real geo_jfactor() +# +#begin +# # Allocate working space. +# call smark (sp) +# call salloc (y, ncols, TY_REAL) +# call salloc (xin, ncols, TY_REAL) +# call salloc (yin, ncols, TY_REAL) +# call salloc (xout, ncols, TY_REAL) +# call salloc (yout, ncols, TY_REAL) +# call salloc (temp, ncols, TY_REAL) +# +# # Fill image buffer. +# if (IM_NDIM(input) == 1) +# inbuf = imgs1r (input, 1, int (IM_LEN(input,1))) +# else +# inbuf = imgs2r (input, 1, int (IM_LEN(input,1)), 1, +# int (IM_LEN(input,2))) +# if (inbuf == EOF) +# call error (0, "Error reading image") +# +# # Fit the interpolant. +# if (IM_NDIM(input) == 1) +# call asifit (msi, Memr[inbuf], int (IM_LEN(input,1))) +# else +# call msifit (msi, Memr[inbuf], int (IM_LEN(input,1)), +# int (IM_LEN(input,2)), int (IM_LEN(input,1))) +# +# # Calculate the x and y input image coordinates. +# do j = 1, nlines { +# +# # Get output image buffer. +# if (IM_NDIM(input) == 1) +# outbuf = imps1r (output, 1, ncols) +# else +# outbuf = imps2r (output, 1, ncols, j, j) +# if (output == EOF) +# call error (0, "Error writing output image") +# +# # Fit x coords. +# call amovkr (yref[j], Memr[y], ncols) +# call gsvector (sx1, xref, Memr[y], Memr[xin], ncols) +# if (sx2 != NULL) { +# call gsvector (sx2, xref, Memr[y], Memr[temp], ncols) +# call aaddr (Memr[xin], Memr[temp], Memr[xin], ncols) +# } +# +# # Fit y coords. +# call gsvector (sy1, xref, Memr[y], Memr[yin], ncols) +# if (sy2 != NULL) { +# call gsvector (sy2, xref, Memr[y], Memr[temp], ncols) +# call aaddr (Memr[yin], Memr[temp], Memr[yin], ncols) +# } +# +# # Compute of of bounds pixels. +# call geo_btran (input, geo, Memr[xin], Memr[yin], Memr[xout], +# Memr[yout], ncols) +# +# # Interpolate in input image. +# if (IM_NDIM(input) == 1) +# call asivector (msi, Memr[xout], Memr[outbuf], ncols) +# else +# call msivector (msi, Memr[xout], Memr[yout], Memr[outbuf], +# ncols) +# +# # Correct for constant boundary extension. +# if (GT_BOUNDARY(geo) == BT_CONSTANT) +# call geo_bconstant (input, geo, Memr[xin], Memr[yin], +# Memr[outbuf], Memr[outbuf], ncols) +# +# # Preserve flux in image. +# if (GT_FLUXCONSERVE(geo) == YES) { +# factor = GT_XSCALE(geo) * GT_YSCALE(geo) +# if (GT_GEOMODE(geo) == GT_LINEAR || (sx2 == NULL && sy2 == +# NULL)) { +# if (IM_NDIM(input) == 1) +# call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, +# NULL), Memr[outbuf], ncols) +# else +# call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, +# sy1), Memr[outbuf], ncols) +# } else { +# if (IM_NDIM(input) == 1) +# call geo_gsflux (xref, yref, Memr[outbuf], 1, ncols, j, +# sx1, NULL, sx2, NULL) +# else +# call geo_gsflux (xref, yref, Memr[outbuf], 1, ncols, j, +# sx1, sy1, sx2, sy2) +# call amulkr (Memr[outbuf], factor, Memr[outbuf], ncols) +# } +# } +# } +# +# call sfree (sp) +#end + + +## GEO_BTRAN -- Map out-of-bounds pixel into the input image. +# +#procedure geo_btran (input, geo, xin, yin, xout, yout, ncols) +# +#pointer input #I pointer to the input image +#pointer geo #I pointer to geotran strcuture +#real xin[ARB] #I x input coords +#real yin[ARB] #I y input coords +#real xout[ARB] #O x output coords +#real yout[ARB] #O y output coords +#int ncols #I number of columns +# +#int i +#real xmax, ymax, xtemp, ytemp +# +#begin +# xmax = IM_LEN(input,1) +# if (IM_NDIM(input) == 1) +# ymax = 1.0 +# else +# ymax = IM_LEN(input,2) +# +# switch (GT_BOUNDARY(geo)) { +# case BT_CONSTANT, BT_NEAREST: +# do i = 1, ncols { +# if (xin[i] < 1.0) +# xout[i] = 1.0 +# else if (xin[i] > xmax) +# xout[i] = xmax +# else +# xout[i] = xin[i] +# if (yin[i] < 1.0) +# yout[i] = 1.0 +# else if (yin[i] > ymax) +# yout[i] = ymax +# else +# yout[i] = yin[i] +# } +# case BT_REFLECT: +# do i = 1, ncols { +# if (xin[i] < 1.0) +# xout[i] = 1.0 + (1.0 - xin[i]) +# else if (xin[i] > xmax) +# xout[i] = xmax - (xin[i] - xmax) +# else +# xout[i] = xin[i] +# if (yin[i] < 1.0) +# yout[i] = 1.0 + (1.0 - yin[i]) +# else if (yin[i] > ymax) +# yout[i] = ymax - (yin[i] - ymax) +# else +# yout[i] = yin[i] +# } +# case BT_WRAP: +# do i = 1, ncols { +# xtemp = xin[i] +# ytemp = yin[i] +# +# if (xtemp < 1.0) { +# while (xtemp < 1.0) +# xtemp = xtemp + xmax +# if (xtemp < 1.0) +# xtemp = xmax - xtemp +# else if (xtemp > xmax) +# xtemp = 2.0 + xmax - xtemp +# } else if (xtemp > xmax) { +# while (xtemp > xmax) +# xtemp = xtemp - xmax +# if (xtemp < 1.0) +# xtemp = xmax - xtemp +# else if (xtemp > xmax) +# xtemp = 2.0 + xmax - xtemp +# } +# xout[i] = xtemp +# +# if (ytemp < 1.0) { +# while (ytemp < 1.0) +# ytemp = ytemp + ymax +# if (ytemp < 1.0) +# ytemp = ymax - ytemp +# else if (ytemp > ymax) +# ytemp = 2.0 + ymax - ytemp +# } else if (ytemp > ymax) { +# while (ytemp > ymax) +# ytemp = ytemp - ymax +# if (ytemp < 1.0) +# ytemp = ymax - ytemp +# else if (ytemp > ymax) +# ytemp = 2.0 + ymax - ytemp +# } +# yout[i] = ytemp +# } +# } +#end + + +## GEO_BCONSTANT -- Map constant out-of-bounds pixels into the input image. +# +#procedure geo_bconstant (input, geo, xin, yin, inbuf, outbuf, ncols) +# +#pointer input #I pointer to the input image +#pointer geo #I pointer to geotran structure +#real xin[ARB] #I x input coords +#real yin[ARB] #I y input coords +#real inbuf[ARB] #I input buffer +#real outbuf[ARB] #O output buffer +#int ncols #I number of columns +# +#int i +#real xmax, ymax, constant +# +#begin +# xmax = IM_LEN(input,1) +# if (IM_NDIM(input) == 1) +# ymax = 1.0 +# else +# ymax = IM_LEN(input,2) +# constant = GT_CONSTANT(geo) +# do i = 1, ncols { +# if (xin[i] < 1.0 || xin[i] > xmax || yin[i] < 1.0 || yin[i] > ymax) +# outbuf[i] = constant +# else +# outbuf[i] = inbuf[i] +# } +#end diff --git a/pkg/images/immatch/src/geometry/geotran.h b/pkg/images/immatch/src/geometry/geotran.h new file mode 100644 index 00000000..d2fa6b55 --- /dev/null +++ b/pkg/images/immatch/src/geometry/geotran.h @@ -0,0 +1,52 @@ +# GEOTRAN Structure + +define LEN_GEOSTRUCT (30 + SZ_FNAME) + +# output picture formatting parameters + +define GT_NCOLS Memi[$1] # number of output columns +define GT_NLINES Memi[$1+1] # number of output lines +define GT_XMIN Memr[P2R($1+2)] # x minimum +define GT_XMAX Memr[P2R($1+3)] # x maximum +define GT_YMIN Memr[P2R($1+4)] # y minimun +define GT_YMAX Memr[P2R($1+5)] # y maximum +define GT_XSCALE Memr[P2R($1+6)] # x scale +define GT_YSCALE Memr[P2R($1+7)] # y scale + +# transformation parameters + +define GT_GEOMODE Memi[$1+8] # Type of transformation +define GT_XIN Memr[P2R($1+9)] # x input pixel +define GT_YIN Memr[P2R($1+10)] # y input pixel +define GT_XOUT Memr[P2R($1+11)] # x output pixel +define GT_YOUT Memr[P2R($1+12)] # y output pixel +define GT_XSHIFT Memr[P2R($1+13)] # x shift +define GT_YSHIFT Memr[P2R($1+14)] # y shift +define GT_XMAG Memr[P2R($1+15)] # input image x scale +define GT_YMAG Memr[P2R($1+16)] # input image y scale +define GT_XROTATION Memr[P2R($1+17)] # rotation angle +define GT_YROTATION Memr[P2R($1+18)] # scale angle + +# interpolation parameters +define GT_XSAMPLE Memr[P2R($1+19)] # x surface subsampling +define GT_YSAMPLE Memr[P2R($1+20)] # y surface subsampling +define GT_INTERPOLANT Memi[$1+21] # image interpolant +define GT_NSINC Memi[$1+22] # sinc width half-width +define GT_NXYMARGIN Memi[$1+23] # the interpolation margin +define GT_BOUNDARY Memi[$1+24] # boundary extension +define GT_CONSTANT Memr[P2R($1+25)] # constant boundary extension +define GT_FLUXCONSERVE Memi[$1+26] # conserve total flux +define GT_INTERPSTR Memc[P2C($1+27)] # interpolation string + +# GEOTRAN MODES + +define GT_NONE 1 # parameters defined by user +define GT_LINEAR 2 # use linear transformation +define GT_DISTORT 3 # distortion transformation only +define GT_GEOMETRIC 4 # use full transformation + +# GEOTRAN COORDINATE MODES + +define GT_ONE 1 +define GT_TWO 2 +define GT_FOUR 3 diff --git a/pkg/images/immatch/src/geometry/geotran.x b/pkg/images/immatch/src/geometry/geotran.x new file mode 100644 index 00000000..ee689d26 --- /dev/null +++ b/pkg/images/immatch/src/geometry/geotran.x @@ -0,0 +1,1752 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <mach.h> +include <math/gsurfit.h> +include <math/iminterp.h> +include "geotran.h" + +define NMARGIN 3 # number of boundary pixels +define NMARGIN_SPLINE3 16 # number of spline boundary pixels + +# GEO_TRAN -- Correct an image for geometric distortion block by block using +# fitted coordinates and image interpolation. + +procedure geo_tran (input, output, geo, sx1, sy1, sx2, sy2, nxblock, nyblock) + +pointer input #I pointer to input image +pointer output #I pointer to output image +pointer geo #I pointer to geotran structure +pointer sx1, sy1 #I pointers to linear surfaces +pointer sx2, sy2 #I pointers to higher order surfaces +int nxblock, nyblock #I working block size + +int l1, l2, c1, c2, nincr +pointer sp, xref, yref, msi +real shift +real gsgetr() + +begin + # Initialize the interpolant. + if (IM_NDIM(input) == 1) { + call asitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), GT_NSINC(geo), + nincr, shift) + call asisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), nincr, + shift, 0.0) + } else { + call msitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), + GT_NSINC(geo), nincr, shift) + call msisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), nincr, + nincr, shift, shift, 0.0) + } + call geo_margset (sx1, sy1, sx2, sy2, GT_XMIN(geo), GT_XMAX(geo), + GT_NCOLS(geo), GT_YMIN(geo), GT_YMAX(geo), GT_NLINES(geo), + GT_INTERPOLANT(geo), GT_NSINC(geo), GT_NXYMARGIN(geo)) + + # Allocate working space. + call smark (sp) + call salloc (xref, GT_NCOLS(geo), TY_REAL) + call salloc (yref, GT_NLINES(geo), TY_REAL) + + # Compute the reference coordinates corresponding to the center of + # the output image pixels. + call geo_ref (geo, Memr[xref], 1, GT_NCOLS(geo), GT_NCOLS(geo), + Memr[yref], 1, GT_NLINES(geo), GT_NLINES(geo), gsgetr (sx1, + GSXMIN), gsgetr (sx1, GSXMAX), gsgetr (sx1, GSYMIN), gsgetr (sx1, + GSYMAX), GT_ONE) + + # Configure the out-of-bounds pixel references for the input image. + call geo_imset (input, geo, sx1, sy1, sx2, sy2, Memr[xref], + GT_NCOLS(geo), Memr[yref], GT_NLINES(geo)) + + # Loop over the line blocks. + for (l1 = 1; l1 <= GT_NLINES(geo); l1 = l1 + nyblock) { + + # Set line limits in the output image. + l2 = min (l1 + nyblock - 1, GT_NLINES(geo)) + + # Loop over the column blocks + for (c1 = 1; c1 <= GT_NCOLS(geo); c1 = c1 + nxblock) { + + # Set column limits in the output image. + c2 = min (c1 + nxblock - 1, GT_NCOLS(geo)) + + # Interpolate + call geo_gsvector (input, output, geo, msi, Memr[xref], + c1, c2, Memr[yref], l1, l2, sx1, sy1, sx2, sy2) + } + } + + # Clean up. + if (IM_NDIM(input) == 1) + call asifree (msi) + else + call msifree (msi) + call sfree (sp) +end + + +# GEO_STRAN -- Correct an image for geometric distortion block by block using +# interpolated coordinates and image interpolation. + +procedure geo_stran (input, output, geo, sx1, sy1, sx2, sy2, nxblock, nyblock) + +pointer input #I pointer to input image +pointer output #I pointer to output image +pointer geo #I pointer to geotran structure +pointer sx1, sy1 #I pointers to linear surfaces +pointer sx2, sy2 #I pointers to higher order surfaces +int nxblock, nyblock #I working block size + +int nxsample, nysample, ncols, nlines, l1, l2, c1, c2 +int line1, line2, llast1, llast2, nincr +pointer sp, xsample, ysample, xinterp, yinterp +pointer xmsi, ymsi, jmsi, msi, xbuf, ybuf, jbuf +real shift +real gsgetr() + +begin + # Allocate working space and intialize the interpolant. + call smark (sp) + call salloc (xsample, GT_NCOLS(geo), TY_REAL) + call salloc (ysample, GT_NLINES(geo), TY_REAL) + call salloc (xinterp, GT_NCOLS(geo), TY_REAL) + call salloc (yinterp, GT_NLINES(geo), TY_REAL) + + # Compute the sample size. + if (GT_NCOLS(geo) == 1) + nxsample = 1 + else + nxsample = GT_NCOLS(geo) / GT_XSAMPLE(geo) + if (GT_NLINES(geo) == 1) + nysample = 1 + else + nysample = GT_NLINES(geo) / GT_YSAMPLE(geo) + + # Initialize interpolants. + if (IM_NDIM(input) == 1) { + call asiinit (xmsi, II_LINEAR) + call asiinit (ymsi, II_LINEAR) + call asitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), + GT_NSINC(geo), nincr, shift) + call asisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), nincr, + shift, 0.0) + if (GT_FLUXCONSERVE(geo) == YES) + call asiinit (jmsi, II_LINEAR) + } else { + call msiinit (xmsi, II_BILINEAR) + call msiinit (ymsi, II_BILINEAR) + call msitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), + GT_NSINC(geo), nincr, shift) + call msisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), nincr, + nincr, shift, shift, 0.0) + if (GT_FLUXCONSERVE(geo) == YES) + call msiinit (jmsi, II_BILINEAR) + } + call geo_margset (sx1, sy1, sx2, sy2, GT_XMIN(geo), GT_XMAX(geo), + GT_NCOLS(geo), GT_YMIN(geo), GT_YMAX(geo), GT_NLINES(geo), + GT_INTERPOLANT(geo), GT_NSINC(geo), GT_NXYMARGIN(geo)) + + # Setup input image boundary extension parameters. + call geo_ref (geo, Memr[xsample], 1, GT_NCOLS(geo), GT_NCOLS(geo), + Memr[ysample], 1, GT_NLINES(geo), GT_NLINES(geo), gsgetr (sx1, + GSXMIN), gsgetr (sx1, GSXMAX), gsgetr (sx1, GSYMIN), gsgetr (sx1, + GSYMAX), GT_ONE) + call geo_imset (input, geo, sx1, sy1, sx2, sy2, Memr[xsample], + GT_NCOLS(geo), Memr[ysample], GT_NLINES(geo)) + + # Calculate the sampled reference coordinates and the interpolated + # reference coordinates. + call geo_ref (geo, Memr[xsample], 1, nxsample, nxsample, Memr[ysample], + 1, nysample, nysample, gsgetr (sx1, GSXMIN), gsgetr (sx1, GSXMAX), + gsgetr (sx1, GSYMIN), gsgetr (sx1, GSYMAX), GT_ONE) + call geo_sample (geo, Memr[xinterp], 1, GT_NCOLS(geo), nxsample, + Memr[yinterp], 1, GT_NLINES(geo), nysample, GT_ONE) + + # Initialize the buffers. + xbuf = NULL + ybuf = NULL + jbuf = NULL + + # Loop over the line blocks. + for (l1 = 1; l1 <= GT_NLINES(geo); l1 = l1 + nyblock) { + + # Set line limits in the output image. + l2 = min (l1 + nyblock - 1, GT_NLINES(geo)) + nlines = l2 - l1 + 1 + + # Line1 and line2 are the coordinates in the interpolation surface + line1 = max (1, min (nysample - 1, int (Memr[yinterp+l1-1]))) + line2 = min (nysample, int (Memr[yinterp+l2-1] + 1.0)) + + if ((xbuf == NULL) || (ybuf == NULL) || (jbuf == NULL) || + (line1 < llast1) || (line2 > llast2)) { + call geo_xbuffer (sx1, sx2, xmsi, Memr[xsample], Memr[ysample], + 1, nxsample, line1, line2, xbuf) + call geo_ybuffer (sy1, sy2, ymsi, Memr[xsample], Memr[ysample], + 1, nxsample, line1, line2, ybuf) + if (GT_FLUXCONSERVE(geo) == YES) { + if (IM_NDIM(input) == 1) + call geo_jbuffer (sx1, NULL, sx2, NULL, jmsi, + Memr[xsample], Memr[ysample], 1, nxsample, + line1, line2, jbuf) + else + call geo_jbuffer (sx1, sy1, sx2, sy2, jmsi, + Memr[xsample], Memr[ysample], 1, nxsample, + line1, line2, jbuf) + } + llast1 = line1 + llast2 = line2 + } + + + # Loop over the column blocks. + for (c1 = 1; c1 <= GT_NCOLS(geo); c1 = c1 + nxblock) { + + # C1 and c2 are the column limits in the output image. + c2 = min (c1 + nxblock - 1, GT_NCOLS(geo)) + ncols = c2 - c1 + 1 + + # Calculate the coordinates of the output pixels in the input + # image. + call geo_msivector (input, output, geo, xmsi, ymsi, jmsi, msi, + sx1, sy1, sx2, sy2, Memr[xinterp], c1, c2, nxsample, + Memr[yinterp], l1, l2, nysample, 1, line1) + } + } + + # Free space. + if (IM_NDIM(input) == 1) { + call asifree (xmsi) + call asifree (ymsi) + call asifree (msi) + if (GT_FLUXCONSERVE(geo) == YES) + call asifree (jmsi) + } else { + call msifree (xmsi) + call msifree (ymsi) + call msifree (msi) + if (GT_FLUXCONSERVE(geo) == YES) + call msifree (jmsi) + } + call mfree (xbuf, TY_REAL) + call mfree (ybuf, TY_REAL) + if (GT_FLUXCONSERVE(geo) == YES) + call mfree (jbuf, TY_REAL) + call sfree (sp) +end + + +# GEO_REF -- Determine the x and y coordinates at which the coordinate +# surface will be subsampled. + +procedure geo_ref (geo, x, c1, c2, nx, y, l1, l2, ny, xmin, xmax, ymin, ymax, + cmode) + +pointer geo #I pointer to the geotran structure +real x[ARB] #O output x sample coordinates +int c1, c2, nx #I the column limits of the sampled array +real y[ARB] #O output y sample coordinates +int l1, l2, ny #I the line limits of the output coordinates +real xmin, xmax #I limits on x coordinates +real ymin, ymax #I limits on y coordinates +int cmode #I coordinate computation mode + +int i +real xtempmin, xtempmax, ytempmin, ytempmax, dx, dy + +begin + + switch (cmode) { + case GT_FOUR: + if (nx == 1) { + xtempmin = min (xmax, max (xmin, GT_XMIN(geo))) + xtempmax = min (xmax, max (xmin, GT_XMAX(geo))) + x[1] = xtempmin + x[2] = xtempmax + x[3] = xtempmax + x[4] = xtempmin + } else if (nx == GT_NCOLS(geo)) { + if (GT_XMIN(geo) > GT_XMAX(geo)) + dx = -GT_XSCALE(geo) + else + dx = GT_XSCALE(geo) + do i = c1, c2 { + xtempmin = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 1.5) * dx)) + xtempmax = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 0.5) * dx)) + x[4*(i-c1)+1] = xtempmin + x[4*(i-c1)+2] = xtempmax + x[4*(i-c1)+3] = xtempmax + x[4*(i-c1)+4] = xtempmin + } + } else { + if (GT_XMIN(geo) > GT_XMAX(geo)) + dx = -GT_XSCALE(geo) * (GT_NCOLS(geo) - 1.0) / (nx - 1.0) + else + dx = GT_XSCALE(geo) * (GT_NCOLS(geo) - 1.0) / (nx - 1.0) + do i = c1, c2 { + xtempmin = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 1.5) * dx)) + xtempmax = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 0.5) * dx)) + x[4*(i-c1)+1] = xtempmin + x[4*(i-c1)+2] = xtempmax + x[4*(i-c1)+3] = xtempmax + x[4*(i-c1)+4] = xtempmin + } + } + + case GT_TWO: + if (nx == 1) { + xtempmin = min (xmax, max (xmin, GT_XMIN(geo))) + xtempmax = min (xmax, max (xmin, GT_XMAX(geo))) + x[1] = xtempmin + x[2] = xtempmax + } else if (nx == GT_NCOLS(geo)) { + if (GT_XMIN(geo) > GT_XMAX(geo)) + dx = -GT_XSCALE(geo) + else + dx = GT_XSCALE(geo) + do i = c1, c2 { + xtempmin = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 1.5) * dx)) + xtempmax = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 0.5) * dx)) + x[2*(i-c1)+1] = xtempmin + x[2*(i-c1)+2] = xtempmax + } + } else { + if (GT_XMIN(geo) > GT_XMAX(geo)) + dx = -GT_XSCALE(geo) * (GT_NCOLS(geo) - 1.0) / (nx - 1.0) + else + dx = GT_XSCALE(geo) * (GT_NCOLS(geo) - 1.0) / (nx - 1.0) + do i = c1, c2 { + xtempmin = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 1.5) * dx)) + xtempmax = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 0.5) * dx)) + x[2*(i-c1)+1] = xtempmin + x[2*(i-c1)+2] = xtempmax + } + } + + case GT_ONE: + if (nx == 1) { + x[1] = min (xmax, max (xmin, + (GT_XMIN(geo) + GT_XMAX(geo)) / 2.0)) + } else if (nx == GT_NCOLS(geo)) { + if (GT_XMIN(geo) > GT_XMAX(geo)) + dx = -GT_XSCALE(geo) + else + dx = GT_XSCALE(geo) + do i = c1, c2 + x[i-c1+1] = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 1) * dx)) + } else { + if (GT_XMIN(geo) > GT_XMAX(geo)) + dx = -GT_XSCALE(geo) * (GT_NCOLS(geo) - 1.0) / (nx - 1.0) + else + dx = GT_XSCALE(geo) * (GT_NCOLS(geo) - 1.0) / (nx - 1.0) + do i = c1, c2 + x[i-c1+1] = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 1) * dx)) + } + + } + + switch (cmode) { + case GT_FOUR: + if (ny == 1) { + ytempmin = min (ymax, max (ymin, GT_YMIN(geo))) + ytempmax = min (ymax, max (ymin, GT_YMAX(geo))) + y[1] = ytempmin + y[2] = ytempmin + y[3] = ytempmax + y[4] = ytempmax + } else if (ny == GT_NLINES(geo)) { + if (GT_YMIN(geo) > GT_YMAX(geo)) + dy = -GT_YSCALE(geo) + else + dy = GT_YSCALE(geo) + do i = l1, l2 { + ytempmin = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 1.5) * dy)) + ytempmax = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 0.5) * dy)) + y[4*(i-l1)+1] = ytempmin + y[4*(i-l1)+2] = ytempmin + y[4*(i-l1)+3] = ytempmax + y[4*(i-l1)+4] = ytempmax + } + } else { + if (GT_YMIN(geo) > GT_YMAX(geo)) + dy = -GT_YSCALE(geo) * (GT_NLINES(geo) - 1.0) / (ny - 1.0) + else + dy = GT_YSCALE(geo) * (GT_NLINES(geo) - 1.0) / (ny - 1.0) + do i = l1, l2 { + ytempmin = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 1.5) * dy)) + ytempmax = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 0.5) * dy)) + y[4*(i-l1)+1] = ytempmin + y[4*(i-l1)+2] = ytempmin + y[4*(i-l1)+3] = ytempmax + y[4*(i-l1)+4] = ytempmax + } + } + + case GT_TWO: + if (ny == 1) { + ytempmin = min (ymax, max (ymin, GT_YMIN(geo))) + ytempmax = min (ymax, max (ymin, GT_YMAX(geo))) + y[1] = ytempmin + y[2] = ytempmax + } else if (ny == GT_NLINES(geo)) { + if (GT_YMIN(geo) > GT_YMAX(geo)) + dy = -GT_YSCALE(geo) + else + dy = GT_YSCALE(geo) + do i = l1, l2 { + ytempmin = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 1.5) * dy)) + ytempmax = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 0.5) * dy)) + y[2*(i-l1)+1] = ytempmin + y[2*(i-l1)+2] = ytempmax + } + } else { + if (GT_YMIN(geo) > GT_YMAX(geo)) + dy = -GT_YSCALE(geo) * (GT_NLINES(geo) - 1.0) / (ny - 1.0) + else + dy = GT_YSCALE(geo) * (GT_NLINES(geo) - 1.0) / (ny - 1.0) + do i = l1, l2 { + ytempmin = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 1.5) * dy)) + ytempmax = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 0.5) * dy)) + y[2*(i-l1)+1] = ytempmin + y[2*(i-l1)+2] = ytempmax + } + } + case GT_ONE: + if (ny == 1) { + y[1] = min (ymax, max (ymin, + (GT_YMIN(geo) + GT_YMAX(geo)) / 2.0)) + } else if (ny == GT_NLINES(geo)) { + if (GT_YMIN(geo) > GT_YMAX(geo)) + dy = -GT_YSCALE(geo) + else + dy = GT_YSCALE(geo) + do i = l1, l2 + y[i-l1+1] = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 1) * dy)) + } else { + if (GT_YMIN(geo) > GT_YMAX(geo)) + dy = -GT_YSCALE(geo) * (GT_NLINES(geo) - 1.0) / (ny - 1.0) + else + dy = GT_YSCALE(geo) * (GT_NLINES(geo) - 1.0) / (ny - 1.0) + do i = l1, l2 + y[i-l1+1] = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 1) * dy)) + } + + } +end + + +# GEO_SAMPLE -- Calculate the sampled reference points. + +procedure geo_sample (geo, xref, c1, c2, nxsample, yref, l1, l2, nysample, + cmode) + +pointer geo #I pointer to geotran structure +real xref[ARB] #O x reference values +int c1, c2, nxsample #I limits and number of sample points in x +real yref[ARB] #O y reference values +int l1, l2, nysample #I limits and number of sample points in y +int cmode #I coordinate computation mode + +int i +real xtempmin, xtempmax, ytempmin, ytempmax + +begin + switch (cmode) { + case GT_FOUR: + if (GT_NCOLS(geo) == 1) { + xref[1] = 0.5 + xref[2] = 1.5 + xref[3] = 1.5 + xref[4] = 0.5 + } else { + do i = c1, c2 { + xtempmin = min (real (nxsample), max (1., + real ((nxsample - 1) * (i - 0.5) + (GT_NCOLS(geo) - + nxsample)) / (GT_NCOLS(geo) - 1))) + xtempmax = min (real (nxsample), max (1., + real ((nxsample - 1) * (i + 0.5) + (GT_NCOLS(geo) - + nxsample)) / (GT_NCOLS(geo) - 1))) + xref[4*(i-c1)+1] = xtempmin + xref[4*(i-c1)+2] = xtempmax + xref[4*(i-c1)+3] = xtempmax + xref[4*(i-c1)+4] = xtempmin + } + + } + case GT_TWO: + if (GT_NCOLS(geo) == 1) { + xref[1] = 0.5 + xref[2] = 1.5 + } else { + do i = c1, c2 { + xtempmin = min (real (nxsample), max (1., + real ((nxsample - 1) * (i - 0.5) + (GT_NCOLS(geo) - + nxsample)) / (GT_NCOLS(geo) - 1))) + xtempmax = min (real (nxsample), max (1., + real ((nxsample - 1) * (i + 0.5) + (GT_NCOLS(geo) - + nxsample)) / (GT_NCOLS(geo) - 1))) + xref[2*(i-c1)+1] = xtempmin + xref[2*(i-c1)+2] = xtempmax + } + } + case GT_ONE: + if (GT_NCOLS(geo) == 1) + xref[1] = 1.0 + else { + do i = c1, c2 + xref[i-c1+1] = min (real (nxsample), max (1., + real ((nxsample - 1) * i + (GT_NCOLS(geo) - + nxsample)) / (GT_NCOLS(geo) - 1))) + } + } + + switch (cmode) { + case GT_FOUR: + if (GT_NLINES(geo) == 1) { + yref[1] = 0.5 + yref[2] = 0.5 + yref[3] = 1.5 + yref[4] = 1.5 + } else { + do i = l1, l2 { + ytempmin = min (real (nysample), max (1., + real ((nysample - 1) * (i - 0.5) + (GT_NLINES(geo) - + nysample)) / (GT_NLINES(geo) - 1))) + ytempmax = min (real (nysample), max (1., + real ((nysample - 1) * (i + 0.5) + (GT_NLINES(geo) - + nysample)) / (GT_NLINES(geo) - 1))) + yref[4*(i-l1)+1] = ytempmin + yref[4*(i-l1)+2] = ytempmin + yref[4*(i-l1)+3] = ytempmax + yref[4*(i-l1)+4] = ytempmax + } + } + case GT_TWO: + if (GT_NLINES(geo) == 1) { + yref[1] = 0.5 + yref[2] = 1.5 + } else { + do i = l1, l2 { + ytempmin = min (real (nysample), max (1., + real ((nysample - 1) * (i - 0.5) + (GT_NLINES(geo) - + nysample)) / (GT_NLINES(geo) - 1))) + ytempmax = min (real (nysample), max (1., + real ((nysample - 1) * (i + 0.5) + (GT_NLINES(geo) - + nysample)) / (GT_NLINES(geo) - 1))) + yref[2*(i-l1)+1] = ytempmin + yref[2*(i-l1)+2] = ytempmax + } + } + case GT_ONE: + if (GT_NLINES(geo) == 1) + yref[1] = 1.0 + else { + do i = l1, l2 + yref[i-l1+1] = min (real (nysample), max (1., + real ((nysample - 1) * i + (GT_NLINES(geo) - + nysample)) / (GT_NLINES(geo) - 1))) + } + } +end + + +# GEO_XBUFFER -- Compute the x interpolant and coordinates. + +procedure geo_xbuffer (s1, s2, msi, xsample, ysample, c1, c2, l1, l2, buf) + +pointer s1, s2 #I pointers to the x surface +pointer msi #I interpolant +real xsample[ARB] #I sampled x reference coordinates +real ysample[ARB] #I sampled y reference coordinates +int c1, c2 #I columns of interest in sampled image +int l1, l2 #I lines of interest in the sampled image +pointer buf #I pointer to output buffer + +int i, ncols, nlines, llast1, llast2, nclast, nllast +pointer sp, sf, y, z, buf1, buf2 + +begin + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + + # Combine surfaces. + if (s2 == NULL) + call gscopy (s1, sf) + else + call gsadd (s1, s2, sf) + + # Allocate working space. + call smark (sp) + call salloc (y, ncols, TY_REAL) + call salloc (z, ncols, TY_REAL) + + # If buffer undefined then allocate memory for the buffer. Reallocate + # the buffer if the number of lines or columns changes. + if (buf == NULL) { + call malloc (buf, ncols * nlines, TY_REAL) + llast1 = l1 - nlines + llast2 = l2 - nlines + } else if ((nlines != nllast) || (ncols != nclast)) { + call realloc (buf, ncols * nlines, TY_REAL) + llast1 = l1 - nlines + llast2 = l2 - nlines + } + + # Compute the coordinates. + if (l1 < llast1) { + do i = l2, l1, -1 { + if (i > llast1) + buf1 = buf + (i - llast1) * ncols + else { + buf1 = z + call amovkr (ysample[i], Memr[y], ncols) + call gsvector (sf, xsample[c1], Memr[y], Memr[buf1], ncols) + } + buf2 = buf + (i - l1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } else if (l2 > llast2) { + do i = l1, l2 { + if (i < llast2) + buf1 = buf + (i - llast1) * ncols + else { + buf1 = z + call amovkr (ysample[i], Memr[y], ncols) + call gsvector (sf, xsample[c1], Memr[y], Memr[buf1], ncols) + } + buf2 = buf + (i - l1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } + + llast1 = l1 + llast2 = l2 + nclast = ncols + nllast = nlines + + # Fit the interpolant. + if (nlines == 1) + call asifit (msi, Memr[buf], ncols) + else + call msifit (msi, Memr[buf], ncols, nlines, ncols) + + call gsfree (sf) + call sfree (sp) +end + + +# GEO_YBUFFER -- Compute the y interpolant and coordinates. + +procedure geo_ybuffer (s1, s2, msi, xsample, ysample, c1, c2, l1, l2, buf) + +pointer s1, s2 #I pointers to the y surface +pointer msi #I interpolant +real xsample[ARB] #I sampled x reference coordinates +real ysample[ARB] #I sampled y reference coordinates +int c1, c2 #I columns of interest in sampled image +int l1, l2 #I lines of interest in the sampled image +pointer buf #I pointer to output buffer + +int i, ncols, nlines, llast1, llast2, nclast, nllast +pointer sp, sf, y, z, buf1, buf2 + +begin + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + + # Combine surfaces. + if (s2 == NULL) + call gscopy (s1, sf) + else + call gsadd (s1, s2, sf) + + # Allocate working space. + call smark (sp) + call salloc (y, ncols, TY_REAL) + call salloc (z, ncols, TY_REAL) + + # If buffer undefined then allocate memory for the buffer. Reallocate + # the buffer if the number of lines or columns changes. + if (buf == NULL) { + call malloc (buf, ncols * nlines, TY_REAL) + llast1 = l1 - nlines + llast2 = l2 - nlines + } else if ((nlines != nllast) || (ncols != nclast)) { + call realloc (buf, ncols * nlines, TY_REAL) + llast1 = l1 - nlines + llast2 = l2 - nlines + } + + # Compute the coordinates. + if (l1 < llast1) { + do i = l2, l1, -1 { + if (i > llast1) + buf1 = buf + (i - llast1) * ncols + else { + buf1 = z + call amovkr (ysample[i], Memr[y], ncols) + call gsvector (sf, xsample[c1], Memr[y], Memr[buf1], ncols) + } + buf2 = buf + (i - l1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } else if (l2 > llast2) { + do i = l1, l2 { + if (i < llast2) + buf1 = buf + (i - llast1) * ncols + else { + buf1 = z + call amovkr (ysample[i], Memr[y], ncols) + call gsvector (sf, xsample[c1], Memr[y], Memr[buf1], ncols) + } + buf2 = buf + (i - l1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } + + llast1 = l1 + llast2 = l2 + nclast = ncols + nllast = nlines + + # Fit the interpolant. + if (nlines == 1) + call asifit (msi, Memr[buf], ncols) + else + call msifit (msi, Memr[buf], ncols, nlines, ncols) + + call gsfree (sf) + call sfree (sp) +end + + +# GEO_JBUFFER -- Fit the jacobian surface. + +procedure geo_jbuffer (sx1, sy1, sx2, sy2, jmsi, xsample, ysample, c1, c2, l1, + l2, jbuf) + +pointer sx1, sy1 #I pointers to the linear surfaces +pointer sx2, sy2 #I pointers to the distortion surfaces +pointer jmsi #I interpolant +real xsample[ARB] #I sampled x reference coordinates +real ysample[ARB] #I sampled y reference coordinates +int c1, c2 #I columns of interest in sampled image +int l1, l2 #I lines of interest in the sampled image +pointer jbuf #I pointer to output buffer + +int i, ncols, nlines, llast1, llast2, nclast, nllast +pointer sp, sx, sy, y, z, buf1, buf2 + +begin + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + + # Combine surfaces. + if (sx2 == NULL) + call gscopy (sx1, sx) + else + call gsadd (sx1, sx2, sx) + if (sy1 == NULL) + sy = NULL + else if (sy2 == NULL) + call gscopy (sy1, sy) + else + call gsadd (sy1, sy2, sy) + + call smark (sp) + call salloc (y, ncols, TY_REAL) + call salloc (z, ncols, TY_REAL) + + # If buffer undefined then allocate memory for the buffer. Reallocate + # the buffer if the number of lines or columns changes. + if (jbuf == NULL) { + call malloc (jbuf, ncols * nlines, TY_REAL) + llast1 = l1 - nlines + llast2 = l2 - nlines + } else if ((nlines != nllast) || (ncols != nclast)) { + call realloc (jbuf, ncols * nlines, TY_REAL) + llast1 = l1 - nlines + llast2 = l2 - nlines + } + + # Compute surface. + if (l1 < llast1) { + do i = l2, l1, -1 { + if (i > llast1) + buf1 = jbuf + (i - llast1) * ncols + else { + buf1 = z + call amovkr (ysample[i], Memr[y], ncols) + call geo_jgsvector (sx, sy, xsample[c1], Memr[y], + Memr[buf1], ncols) + } + buf2 = jbuf + (i - l1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } else if (l2 > llast2) { + do i = l1, l2 { + if (i < llast2) + buf1 = jbuf + (i - llast1) * ncols + else { + buf1 = z + call amovkr (ysample[i], Memr[y], ncols) + call geo_jgsvector (sx, sy, xsample[c1], Memr[y], + Memr[buf1], ncols) + } + buf2 = jbuf + (i - l1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } + + # Update buffer pointers. + llast1 = l1 + llast2 = l2 + nclast = ncols + nllast = nlines + + # Fit the interpolant. + if (nlines == 1) + call asifit (jmsi, Memr[jbuf], ncols) + else + call msifit (jmsi, Memr[jbuf], ncols, nlines, ncols) + + call gsfree (sx) + call gsfree (sy) + call sfree (sp) +end + + +# GEO_JGSVECTOR -- Procedure to compute the Jacobian of the transformation. + +procedure geo_jgsvector (sx, sy, x, y, out, ncols) + +pointer sx, sy #I surface descriptors +real x[ARB] #I x values +real y[ARB] #I y values +real out[ARB] #O output values +int ncols #I number of points + +pointer sp, der1, der2 + +begin + call smark (sp) + + if (sy == NULL) { + call gsder (sx, x, y, out, ncols, 1, 0) + } else { + call salloc (der1, ncols, TY_REAL) + call salloc (der2, ncols, TY_REAL) + call gsder (sx, x, y, Memr[der1], ncols, 1, 0) + call gsder (sy, x, y, Memr[der2], ncols, 0, 1) + call amulr (Memr[der1], Memr[der2], out, ncols) + call gsder (sx, x, y, Memr[der1], ncols, 0, 1) + call gsder (sy, x, y, Memr[der2], ncols, 1, 0) + call amulr (Memr[der1], Memr[der2], Memr[der1], ncols) + call asubr (out, Memr[der1], out, ncols) + } + + call sfree (sp) +end + + +# GEO_MSIVECTOR -- Procedure to interpolate the surface coordinates + +procedure geo_msivector (in, out, geo, xmsi, ymsi, jmsi, msi, sx1, sy1, sx2, + sy2, xref, c1, c2, nxsample, yref, l1, l2, nysample, x0, y0) + +pointer in #I pointer to input image +pointer out #I pointer to output image +pointer geo #I pointer to geotran structure +pointer xmsi, ymsi #I pointer to the interpolation cord surfaces +pointer jmsi #I pointer to Jacobian surface +pointer msi #I pointer to interpolation surface +pointer sx1, sy1 #I pointers to linear surfaces +pointer sx2, sy2 #I pointer to higher order surfaces +real xref[ARB] #I x reference coordinates +int c1, c2 #I column limits in output image +int nxsample #I the x sample size +real yref[ARB] #I y reference coordinates +int l1, l2 #I line limits in output image +int nysample #I the y sample size +int x0, y0 #I zero points of interpolation coordinates + +int j, ncols, nlines, ncols4, nlines4 +int imc1, imc2, iml1, iml2, nicols, nilines +pointer sp, txref, tyref, x, y, xin, yin, inbuf, outbuf +real xmin, xmax, ymin, ymax, factor +pointer imgs1r(), imgs2r(), imps1r(), imps2r() +real geo_jfactor() + +begin + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + + # Find min max of interpolation coords. + if (IM_NDIM(in) == 1) + call geo_iminmax (xref, yref, c1, c2, l1, l2, x0, 0, + xmsi, ymsi, xmin, xmax, ymin, ymax) + else + call geo_iminmax (xref, yref, c1, c2, l1, l2, x0, y0, + xmsi, ymsi, xmin, xmax, ymin, ymax) + + # Get the appropriate image section and fit the interpolant. + imc1 = int(xmin) - GT_NXYMARGIN(geo) + if (imc1 <= 0) + imc1 = imc1 - 1 + imc2 = nint (xmax) + GT_NXYMARGIN(geo) + 1 + nicols = imc2 - imc1 + 1 + if (IM_NDIM(in) == 1) { + ncols4 = 2 * ncols + nlines4 = 2 * nlines + iml1 = 1 + iml2 = 1 + nilines = 1 + inbuf = imgs1r (in, imc1, imc2) + if (inbuf == EOF) + call error (0, "Error reading image") + call asifit (msi, Memr[inbuf], nicols) + } else { + ncols4 = 4 * ncols + nlines4 = 4 * nlines + iml1 = int(ymin) - GT_NXYMARGIN(geo) + if (iml1 <= 0) + iml1 = iml1 - 1 + iml2 = nint (ymax) + GT_NXYMARGIN(geo) + 1 + nilines = iml2 - iml1 + 1 + inbuf = imgs2r (in, imc1, imc2, iml1, iml2) + if (inbuf == EOF) + call error (0, "Error reading image") + call msifit (msi, Memr[inbuf], nicols, nilines, nicols) + } + + # Allocate working space. + call smark (sp) + if (GT_INTERPOLANT(geo) == II_DRIZZLE || GT_INTERPOLANT(geo) == + II_BIDRIZZLE) { + call salloc (txref, ncols4, TY_REAL) + call salloc (tyref, nlines4, TY_REAL) + call salloc (x, ncols4, TY_REAL) + call salloc (y, ncols4, TY_REAL) + call salloc (xin, ncols4, TY_REAL) + call salloc (yin, ncols4, TY_REAL) + if (IM_NDIM(in) == 1) + call geo_sample (geo, Memr[txref], c1, c2, nxsample, + Memr[tyref], l1, l2, nysample, GT_TWO) + else + call geo_sample (geo, Memr[txref], c1, c2, nxsample, + Memr[tyref], l1, l2, nysample, GT_FOUR) + call aaddkr (Memr[txref], real (-x0 + 1), Memr[x], ncols4) + } else { + call salloc (x, ncols, TY_REAL) + call salloc (y, ncols, TY_REAL) + call salloc (xin, ncols, TY_REAL) + call salloc (yin, ncols, TY_REAL) + call aaddkr (xref[c1], real (-x0 + 1), Memr[x], ncols) + } + + # Compute the output buffer. + do j = l1, l2 { + + # Write the output image. + if (IM_NDIM(in) == 1) + outbuf = imps1r (out, c1, c2) + else + outbuf = imps2r (out, c1, c2, j, j) + if (outbuf == EOF) + call error (0, "Error writing output image") + + # Compute the interpolation coordinates. + if (GT_INTERPOLANT(geo) == II_DRIZZLE || GT_INTERPOLANT(geo) == + II_BIDRIZZLE) { + if (IM_NDIM(in) == 1) { + call asivector (xmsi, Memr[x], Memr[xin], ncols4) + call amovkr (1.0, Memr[yin], ncols4) + } else { + #call amovkr (yref[j] + real (-y0 + 1), Memr[y], ncols) + call geo_repeat (Memr[tyref+4*(j-l1)], 4, Memr[y], ncols) + call aaddkr (Memr[y], real(-y0 + 1), Memr[y], ncols4) + call msivector (xmsi, Memr[x], Memr[y], Memr[xin], ncols4) + call msivector (ymsi, Memr[x], Memr[y], Memr[yin], ncols4) + } + if (imc1 != 1) + call aaddkr (Memr[xin], real (-imc1 + 1), Memr[xin], ncols4) + if (iml1 != 1) + call aaddkr (Memr[yin], real (-iml1 + 1), Memr[yin], ncols4) + } else { + if (IM_NDIM(in) == 1) { + call asivector (xmsi, Memr[x], Memr[xin], ncols) + call amovkr (1.0, Memr[yin], ncols) + } else { + call amovkr (yref[j] + real (-y0 + 1), Memr[y], ncols) + call msivector (xmsi, Memr[x], Memr[y], Memr[xin], ncols) + call msivector (ymsi, Memr[x], Memr[y], Memr[yin], ncols) + } + if (imc1 != 1) + call aaddkr (Memr[xin], real (-imc1 + 1), Memr[xin], ncols) + if (iml1 != 1) + call aaddkr (Memr[yin], real (-iml1 + 1), Memr[yin], ncols) + } + + # Interpolate in the input image. + if (IM_NDIM(in) == 1) + call asivector (msi, Memr[xin], Memr[outbuf], ncols) + else + call msivector (msi, Memr[xin], Memr[yin], Memr[outbuf], ncols) + + # Preserve flux in image. + if (GT_FLUXCONSERVE(geo) == YES) { + factor = GT_XSCALE(geo) * GT_YSCALE(geo) + if (GT_GEOMODE(geo) == GT_LINEAR || (sx2 == NULL && sy2 == + NULL)) { + if (IM_NDIM(in) == 1) + call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, + NULL), Memr[outbuf], ncols) + else + call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, + sy1), Memr[outbuf], ncols) + } else { + if (IM_NDIM(in) == 1) + call geo_msiflux (jmsi, xref, yref, Memr[outbuf], + c1, c2, 0, x0, y0) + else + call geo_msiflux (jmsi, xref, yref, Memr[outbuf], + c1, c2, j, x0, y0) + call amulkr (Memr[outbuf], factor, Memr[outbuf], ncols) + } + } + } + + call sfree (sp) +end + + +# GEO_GSVECTOR -- Evaluate the output image pixels using fitted coordinate +# values and image interpolation. + +procedure geo_gsvector (input, output, geo, msi, xref, c1, c2, yref, l1, l2, + sx1, sy1, sx2, sy2) + +pointer input #I pointer to input image +pointer output #I pointer to output image +pointer geo #I pointer to geotran structure +pointer msi #I pointer to interpolant +real xref[ARB] #I x reference array +int c1, c2 #I columns of interest in output image +real yref[ARB] #I y reference array +int l1, l2 #I lines of interest in the output image +pointer sx1, sy1 #I linear surface descriptors +pointer sx2, sy2 #I distortion surface descriptors + +int j, ncols, nlines, ncols4, nlines4, nicols, nilines +int imc1, imc2, iml1, iml2 +pointer sp, txref, tyref, y, xin, yin, temp, inbuf, outbuf +real xmin, xmax, ymin, ymax, factor +pointer imgs1r(), imgs2r(), imps1r(), imps2r() +real gsgetr(), geo_jfactor() + +begin + # Compute the number of columns. + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + + # Compute the maximum and minimum coordinates. + call geo_minmax (xref, yref, c1, c2, l1, l2, sx1, sy1, sx2, sy2, + xmin, xmax, ymin, ymax) + + # Get the appropriate image section and fill the buffer. + imc1 = int(xmin) - GT_NXYMARGIN(geo) + if (imc1 <= 0) + imc1 = imc1 - 1 + imc2 = nint (xmax) + GT_NXYMARGIN(geo) + 1 + nicols = imc2 - imc1 + 1 + if (IM_NDIM(input) == 1) { + iml1 = 1 + iml2 = 1 + nilines = 1 + ncols4 = 2 * ncols + nlines4 = 2 * nlines + inbuf = imgs1r (input, imc1, imc2) + if (inbuf == EOF) + call error (0, "Error reading image") + call asifit (msi, Memr[inbuf], nicols) + } else { + iml1 = int(ymin) - GT_NXYMARGIN(geo) + if (iml1 <= 0) + iml1 = iml1 - 1 + iml2 = nint (ymax) + GT_NXYMARGIN(geo) + 1 + nilines = iml2 - iml1 + 1 + ncols4 = 4 * ncols + nlines4 = 4 * nlines + inbuf = imgs2r (input, imc1, imc2, iml1, iml2) + if (inbuf == EOF) + call error (0, "Error reading image") + call msifit (msi, Memr[inbuf], nicols, nilines, nicols) + } + + # Allocate working space. + call smark (sp) + if (GT_INTERPOLANT(geo) == II_DRIZZLE || GT_INTERPOLANT(geo) == + II_BIDRIZZLE) { + call salloc (txref, ncols4, TY_REAL) + call salloc (tyref, nlines4, TY_REAL) + call salloc (y, ncols4, TY_REAL) + call salloc (xin, ncols4, TY_REAL) + call salloc (yin, ncols4, TY_REAL) + call salloc (temp, ncols4, TY_REAL) + if (IM_NDIM(input) == 1) + call geo_ref (geo, Memr[txref], c1, c2, GT_NCOLS(geo), + Memr[tyref], l1, l2, GT_NLINES(geo), gsgetr (sx1, GSXMIN), + gsgetr (sx1, GSXMAX), gsgetr (sx1, GSYMIN), gsgetr (sx1, + GSYMAX), GT_TWO) + else + call geo_ref (geo, Memr[txref], c1, c2, GT_NCOLS(geo), + Memr[tyref], l1, l2, GT_NLINES(geo), gsgetr (sx1, GSXMIN), + gsgetr (sx1, GSXMAX), gsgetr (sx1, GSYMIN), gsgetr (sx1, + GSYMAX), GT_FOUR) + } else { + call salloc (y, ncols, TY_REAL) + call salloc (xin, ncols, TY_REAL) + call salloc (yin, ncols, TY_REAL) + call salloc (temp, ncols, TY_REAL) + } + + # Compute the pixels. + do j = l1, l2 { + + # Get output image buffer. + if (IM_NDIM(input) == 1) + outbuf = imps1r (output, c1, c2) + else + outbuf = imps2r (output, c1, c2, j, j) + if (output == EOF) + call error (0, "Error writing output image") + + # Compute the interpolation coordinates. + if (GT_INTERPOLANT(geo) == II_DRIZZLE || GT_INTERPOLANT(geo) == + II_BIDRIZZLE) { + + # Set the y coordinate. + if (IM_NDIM(input) == 1) + call geo_repeat (Memr[tyref+2*(j-l1)], 2, Memr[y], ncols) + else + call geo_repeat (Memr[tyref+4*(j-l1)], 4, Memr[y], ncols) + + # Fit x coords. + call gsvector (sx1, Memr[txref], Memr[y], Memr[xin], ncols4) + if (sx2 != NULL) { + call gsvector (sx2, Memr[txref], Memr[y], Memr[temp], + ncols4) + call aaddr (Memr[xin], Memr[temp], Memr[xin], ncols4) + } + if (imc1 != 1) + call aaddkr (Memr[xin], real (-imc1 + 1), Memr[xin], ncols4) + + # Fit y coords. + call gsvector (sy1, Memr[txref], Memr[y], Memr[yin], ncols4) + if (sy2 != NULL) { + call gsvector (sy2, Memr[txref], Memr[y], Memr[temp], + ncols4) + call aaddr (Memr[yin], Memr[temp], Memr[yin], ncols4) + } + if (iml1 != 1) + call aaddkr (Memr[yin], real (-iml1 + 1), Memr[yin], ncols4) + + } else { + + # Set the y coordinate. + call amovkr (yref[j], Memr[y], ncols) + + # Fit x coords. + call gsvector (sx1, xref[c1], Memr[y], Memr[xin], ncols) + if (sx2 != NULL) { + call gsvector (sx2, xref[c1], Memr[y], Memr[temp], ncols) + call aaddr (Memr[xin], Memr[temp], Memr[xin], ncols) + } + if (imc1 != 1) + call aaddkr (Memr[xin], real (-imc1 + 1), Memr[xin], ncols) + + # Fit y coords. + call gsvector (sy1, xref[c1], Memr[y], Memr[yin], ncols) + if (sy2 != NULL) { + call gsvector (sy2, xref[c1], Memr[y], Memr[temp], ncols) + call aaddr (Memr[yin], Memr[temp], Memr[yin], ncols) + } + if (iml1 != 1) + call aaddkr (Memr[yin], real (-iml1 + 1), Memr[yin], ncols) + } + + # Interpolate in input image. + if (IM_NDIM(input) == 1) + call asivector (msi, Memr[xin], Memr[outbuf], ncols) + else + call msivector (msi, Memr[xin], Memr[yin], Memr[outbuf], ncols) + + # Preserve flux in image. + if (GT_FLUXCONSERVE(geo) == YES) { + factor = GT_XSCALE(geo) * GT_YSCALE(geo) + if (GT_GEOMODE(geo) == GT_LINEAR || (sx2 == NULL && sy2 == + NULL)) { + if (IM_NDIM(input) == 1) + call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, + NULL), Memr[outbuf], ncols) + else + call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, + sy1), Memr[outbuf], ncols) + } else { + if (IM_NDIM(input) == 1) + call geo_gsflux (xref, yref, Memr[outbuf], c1, c2, j, + sx1, NULL, sx2, NULL) + else + call geo_gsflux (xref, yref, Memr[outbuf], c1, c2, j, + sx1, sy1, sx2, sy2) + call amulkr (Memr[outbuf], factor, Memr[outbuf], ncols) + } + } + } + + call sfree (sp) +end + + +# GEO_IMINMAX -- Find minimum and maximum interpolation coordinates. + +procedure geo_iminmax (xref, yref, c1, c2, l1, l2, x0, y0, xmsi, ymsi, xmin, + xmax, ymin, ymax) + +real xref[ARB] #I x reference coords +real yref[ARB] #I y reference coords +int c1, c2 #I columns limits +int l1, l2 #I line limits +int x0, y0 #I interpolation coord zero points +pointer xmsi, ymsi #I coord surfaces +real xmin, xmax #O output xmin and xmax +real ymin, ymax #O output ymin and ymax + +int j, ncols +pointer sp, x, y, xin, yin +real mintemp, maxtemp, x1, x2, y1, y2 +real asieval(), msieval() + +begin + call smark (sp) + ncols = c2 - c1 + 1 + call salloc (x, ncols, TY_REAL) + call salloc (y, ncols, TY_REAL) + call salloc (xin, ncols, TY_REAL) + call salloc (yin, ncols, TY_REAL) + + xmin = MAX_REAL + xmax = -MAX_REAL + ymin = MAX_REAL + ymax = -MAX_REAL + + # find the minimum and maximum + do j = l1, l2 { + + if (j == l1 || j == l2) { + + call aaddkr (xref[c1], real (-x0 + 1), Memr[x], ncols) + if (y0 <= 0) { + call asivector (xmsi, Memr[x], Memr[xin], ncols) + ymin = 1.0 + ymax = 1.0 + } else { + call amovkr (yref[j] + real (-y0 + 1), Memr[y], ncols) + call msivector (xmsi, Memr[x], Memr[y], Memr[xin], ncols) + call msivector (ymsi, Memr[x], Memr[y], Memr[yin], ncols) + call alimr (Memr[yin], ncols, mintemp, maxtemp) + ymin = min (ymin, mintemp) + ymax = max (ymax, maxtemp) + } + call alimr (Memr[xin], ncols, mintemp, maxtemp) + xmin = min (xmin, mintemp) + xmax = max (xmax, maxtemp) + } else { + if (y0 <= 0) { + x1 = asieval (xmsi, xref[c1] + real (-x0 + 1)) + x2 = asieval (xmsi, xref[c1+ncols-1] + real (-x0 + 1)) + ymin = 1.0 + ymax = 1.0 + } else { + x1 = msieval (xmsi, xref[c1] + real (-x0 + 1), + yref[j] + real (-y0 + 1)) + x2 = msieval (xmsi, xref[c1+ncols-1] + real (-x0 + 1), + yref[j] + real (-y0 + 1)) + y1 = msieval (ymsi, xref[c1] + real (-x0 + 1), + yref[j] + real (-y0 + 1)) + y2 = msieval (ymsi, xref[c1+ncols-1] + real (-x0 + 1), + yref[j] + real (-y0 + 1)) + ymin = min (ymin, y1, y2) + ymax = max (ymax, y1, y2) + } + xmin = min (xmin, x1, x2) + xmax = max (xmax, x1, x2) + + } + } + + call sfree (sp) + +end + + +# GEO_MINMAX -- Compute the minimum and maximum fitted coordinates. + +procedure geo_minmax (xref, yref, c1, c2, l1, l2, sx1, sy1, sx2, sy2, + xmin, xmax, ymin, ymax) + +real xref[ARB] #I x reference coords +real yref[ARB] #I y reference coords +int c1, c2 #I columns limits +int l1, l2 #I line limits +pointer sx1, sy1 #I linear surface descriptors +pointer sx2, sy2 #I distortion surface descriptors +real xmin, xmax #O output xmin and xmax +real ymin, ymax #O output ymin and ymax + +int j, ncols +pointer sp, y, xin, yin, temp +real x1, x2, y1, y2, mintemp, maxtemp +real gseval() + +begin + call smark (sp) + ncols = c2 - c1 + 1 + call salloc (y, ncols, TY_REAL) + call salloc (xin, ncols, TY_REAL) + call salloc (yin, ncols, TY_REAL) + call salloc (temp, ncols, TY_REAL) + + xmin = MAX_REAL + xmax = -MAX_REAL + ymin = MAX_REAL + ymax = -MAX_REAL + + # Find the maximum and minimum coordinates. + do j = l1, l2 { + + if (j == l1 || j == l2) { + + call amovkr (yref[j], Memr[y], ncols) + call gsvector (sx1, xref[c1], Memr[y], Memr[xin], ncols) + if (sx2 != NULL) { + call gsvector (sx2, xref[c1], Memr[y], Memr[temp], ncols) + call aaddr (Memr[xin], Memr[temp], Memr[xin], ncols) + } + call gsvector (sy1, xref[c1], Memr[y], Memr[yin], ncols) + if (sy2 != NULL) { + call gsvector (sy2, xref[c1], Memr[y], Memr[temp], ncols) + call aaddr (Memr[yin], Memr[temp], Memr[yin], ncols) + } + + call alimr (Memr[xin], ncols, mintemp, maxtemp) + xmin = min (xmin, mintemp) + xmax = max (xmax, maxtemp) + call alimr (Memr[yin], ncols, mintemp, maxtemp) + ymin = min (ymin, mintemp) + ymax = max (ymax, maxtemp) + + } else { + + x1 = gseval (sx1, xref[c1], yref[j]) + x2 = gseval (sx1, xref[c1+ncols-1], yref[j]) + if (sx2 != NULL) { + x1 = x1 + gseval (sx2, xref[c1], yref[j]) + x2 = x2 + gseval (sx2, xref[c1+ncols-1], yref[j]) + } + xmin = min (xmin, x1, x2) + xmax = max (xmax, x1, x2) + + y1 = gseval (sy1, xref[c1], yref[j]) + y2 = gseval (sy1, xref[c1+ncols-1], yref[j]) + if (sy2 != NULL) { + y1 = y1 + gseval (sy2, xref[c1], yref[j]) + y2 = y2 + gseval (sy2, xref[c1+ncols-1], yref[j]) + } + ymin = min (ymin, y1, y2) + ymax = max (ymax, y1, y2) + + } + } + + call sfree (sp) +end + + +# GEO_MARGSET -- Set up interpolation margin + +procedure geo_margset (sx1, sy1, sx2, sy2, xmin, xmax, ncols, ymin, ymax, + nlines, interpolant, nsinc, nxymargin) + +pointer sx1, sy1 #I linear surface descriptors +pointer sx2, sy2 #I distortion surface descriptors +real xmin, xmax #I the reference coordinate x limits +int ncols #I the number of output image columns +real ymin, ymax #I the reference coordinate y limits +int nlines #I the number of output image lines +int interpolant #I the interpolant type +int nsinc #I the sinc width +int nxymargin #O the interpolation margin + +int dist1, dist2, dist3, dist4, dist5, dist6 +pointer newsx, newsy +real x1, y1, x2, y2 +real gseval() + +begin + if (interpolant == II_SPLINE3 || interpolant == II_BISPLINE3) { + nxymargin = NMARGIN_SPLINE3 + } else if (interpolant == II_LSINC || interpolant == II_BILSINC) { + nxymargin = nsinc + } else if (interpolant == II_SINC || interpolant == II_BISINC) { + nxymargin = nsinc + } else if (interpolant == II_DRIZZLE || interpolant == II_BIDRIZZLE) { + if (sx2 == NULL) + call gscopy (sx1, newsx) + else + call gsadd (sx1, sx2, newsx) + if (sy2 == NULL) + call gscopy (sy1, newsy) + else + call gsadd (sy1, sy2, newsy) + x1 = gseval (newsx, xmin, ymin) + y1 = gseval (newsy, xmin, ymin) + x2 = gseval (newsx, xmax, ymin) + y2 = gseval (newsy, xmax, ymin) + dist1 = sqrt ((x1 - x2) ** 2 + (y1 - y2) ** 2) / ncols + x1 = gseval (newsx, xmax, ymax) + y1 = gseval (newsy, xmax, ymax) + dist2 = sqrt ((x1 - x2) ** 2 + (y1 - y2) ** 2) / nlines + x2 = gseval (newsx, xmin, ymax) + y2 = gseval (newsy, xmin, ymax) + dist3 = sqrt ((x1 - x2) ** 2 + (y1 - y2) ** 2) / ncols + x1 = gseval (newsx, xmin, ymin) + y1 = gseval (newsy, xmin, ymin) + dist4 = sqrt ((x1 - x2) ** 2 + (y1 - y2) ** 2) / nlines + x1 = gseval (newsx, xmin, (ymin + ymax) / 2.0) + y1 = gseval (newsy, xmin, (ymin + ymax) / 2.0) + x2 = gseval (newsx, xmax, (ymin + ymax) / 2.0) + y2 = gseval (newsy, xmax, (ymin + ymax) / 2.0) + dist5 = sqrt ((x1 - x2) ** 2 + (y1 - y2) ** 2) / ncols + x1 = gseval (newsx, (xmin + xmax) / 2.0, ymin) + y1 = gseval (newsy, (xmin + xmax) / 2.0, ymin) + x2 = gseval (newsx, (xmin + xmax) / 2.0, ymax) + y2 = gseval (newsy, (xmin + xmax) / 2.0, ymax) + dist6 = sqrt ((x1 - x2) ** 2 + (y1 - y2) ** 2) / nlines + nxymargin = max (NMARGIN, dist1, dist2, dist3, dist4, + dist5, dist6) + call gsfree (newsx) + call gsfree (newsy) + } else { + nxymargin = NMARGIN + } +end + + +# GEO_IMSET -- Set up input image boundary conditions. + +procedure geo_imset (im, geo, sx1, sy1, sx2, sy2, xref, nx, yref, ny) + +pointer im #I pointer to image +pointer geo #I pointer to geotran structure +pointer sx1, sy1 #I linear surface descriptors +pointer sx2, sy2 #I distortion surface descriptors +real xref[ARB] #I x reference coordinates +int nx #I number of x reference coordinates +real yref[ARB] #I y reference coordinates +int ny #I number of y reference coordinates + +int bndry, npts +pointer sp, x1, x2, y1, y2, xtemp, ytemp +real xn1, xn2, xn3, xn4, yn1, yn2, yn3, yn4, xmin, xmax, ymin, ymax +real gseval() + +begin + npts = max (nx, ny) + + xn1 = gseval (sx1, GT_XMIN(geo), GT_YMIN(geo)) + xn2 = gseval (sx1, GT_XMAX(geo), GT_YMIN(geo)) + xn3 = gseval (sx1, GT_XMAX(geo), GT_YMAX(geo)) + xn4 = gseval (sx1, GT_XMIN(geo), GT_YMAX(geo)) + + yn1 = gseval (sy1, GT_XMIN(geo), GT_YMIN(geo)) + yn2 = gseval (sy1, GT_XMAX(geo), GT_YMIN(geo)) + yn3 = gseval (sy1, GT_XMAX(geo), GT_YMAX(geo)) + yn4 = gseval (sy1, GT_XMIN(geo), GT_YMAX(geo)) + + xmin = min (xn1, xn2, xn3, xn4) + ymin = min (yn1, yn2, yn3, yn4) + xmax = max (xn1, xn2, xn3, xn4) + ymax = max (yn1, yn2, yn3, yn4) + + if (sx2 != NULL) { + call smark (sp) + call salloc (x1, npts, TY_REAL) + call salloc (x2, npts, TY_REAL) + call salloc (xtemp, npts, TY_REAL) + call salloc (ytemp, npts, TY_REAL) + + call amovkr (GT_YMIN(geo), Memr[ytemp], nx) + call gsvector (sx1, xref, Memr[ytemp], Memr[x1], nx) + call gsvector (sx2, xref, Memr[ytemp], Memr[x2], nx) + call aaddr (Memr[x1], Memr[x2], Memr[x1], nx) + call alimr (Memr[x1], nx, xn1, yn1) + + call amovkr (GT_XMAX(geo), Memr[xtemp], ny) + call gsvector (sx1, Memr[xtemp], yref, Memr[x1], ny) + call gsvector (sx2, Memr[xtemp], yref, Memr[x2], ny) + call aaddr (Memr[x1], Memr[x2], Memr[x1], ny) + call alimr (Memr[x1], ny, xn2, yn2) + + call amovkr (GT_YMAX(geo), Memr[ytemp], nx) + call gsvector (sx1, xref, Memr[ytemp], Memr[x1], nx) + call gsvector (sx2, xref, Memr[ytemp], Memr[x2], nx) + call aaddr (Memr[x1], Memr[x2], Memr[x1], nx) + call alimr (Memr[x1], nx, xn3, yn3) + + call amovkr (GT_XMIN(geo), Memr[xtemp], ny) + call gsvector (sx1, Memr[xtemp], yref, Memr[x1], ny) + call gsvector (sx2, Memr[xtemp], yref, Memr[x2], ny) + call aaddr (Memr[x1], Memr[x2], Memr[x1], ny) + call alimr (Memr[x1], ny, xn4, yn4) + + xmin = min (xn1, xn2, xn3, xn4) + xmax = max (yn1, yn2, yn3, yn4) + + call sfree (sp) + } + + if (sy2 != NULL) { + call smark (sp) + call salloc (y1, npts, TY_REAL) + call salloc (y2, npts, TY_REAL) + call salloc (xtemp, npts, TY_REAL) + call salloc (ytemp, npts, TY_REAL) + + call amovkr (GT_YMIN(geo), Memr[ytemp], nx) + call gsvector (sy1, xref, Memr[ytemp], Memr[y1], nx) + call gsvector (sy2, xref, Memr[ytemp], Memr[y2], nx) + call aaddr (Memr[y1], Memr[y2], Memr[y1], nx) + call alimr (Memr[y1], nx, xn1, yn1) + + call amovkr (GT_XMAX(geo), Memr[xtemp], ny) + call gsvector (sy1, Memr[xtemp], yref, Memr[y1], ny) + call gsvector (sy2, Memr[xtemp], yref, Memr[y2], ny) + call aaddr (Memr[y1], Memr[y2], Memr[y1], ny) + call alimr (Memr[y1], ny, xn2, yn2) + + call amovkr (GT_YMAX(geo), Memr[ytemp], nx) + call gsvector (sy1, xref, Memr[ytemp], Memr[y1], nx) + call gsvector (sy2, xref, Memr[ytemp], Memr[y2], nx) + call aaddr (Memr[y1], Memr[y2], Memr[y1], nx) + call alimr (Memr[y1], nx, xn3, yn3) + + call amovkr (GT_XMIN(geo), Memr[xtemp], ny) + call gsvector (sy1, Memr[xtemp], yref, Memr[y1], ny) + call gsvector (sy2, Memr[xtemp], yref, Memr[y2], ny) + call aaddr (Memr[y1], Memr[y2], Memr[y1], ny) + call alimr (Memr[y1], ny, xn4, yn4) + + ymin = min (xn1, xn2, xn3, xn4) + ymax = max (yn1, yn2, yn3, yn4) + + call sfree (sp) + } + + # Compute the out-of-bounds limit. + if (IM_NDIM(im) == 1) { + if (xmin < 1.0 || xmax > real (IM_LEN(im,1))) + bndry = max (1.0 - xmin, xmax - IM_LEN(im,1)) + 1 + else + bndry = 1 + } else { + if (xmin < 1.0 || ymin < 1.0 || xmax > real (IM_LEN(im,1)) || + ymax > real (IM_LEN(im,2))) + bndry = max (1.0 - xmin, 1.0 - ymin, xmax - IM_LEN(im,1), + ymax - IM_LEN(im,2)) + 1 + else + bndry = 1 + } + + call imseti (im, IM_NBNDRYPIX, bndry + GT_NXYMARGIN(geo) + 1) + call imseti (im, IM_TYBNDRY, GT_BOUNDARY(geo)) + call imsetr (im, IM_BNDRYPIXVAL, GT_CONSTANT(geo)) +end + + +# GEO_GSFLUX -- Preserve the image flux after a transformation. + +procedure geo_gsflux (xref, yref, buf, c1, c2, line, sx1, sy1, sx2, sy2) + +real xref[ARB] #I x reference coordinates +real yref[ARB] #I y reference coordinates +real buf[ARB] #O output image buffer +int c1, c2 #I column limits in the output image +int line #I line in the output image +pointer sx1, sy1 #I linear surface descriptors +pointer sx2, sy2 #I distortion surface descriptors + +int ncols +pointer sp, y, der1, der2, jacob, sx, sy + +begin + ncols = c2 - c1 + 1 + + # Get the reference coordinates. + call smark (sp) + call salloc (y, ncols, TY_REAL) + call salloc (jacob, ncols, TY_REAL) + + # Add the two surfaces together for efficiency. + if (sx2 != NULL) + call gsadd (sx1, sx2, sx) + else + call gscopy (sx1, sx) + if (sy1 == NULL) + sy = NULL + else if (sy2 != NULL) + call gsadd (sy1, sy2, sy) + else + call gscopy (sy1, sy) + + # Multiply the output buffer by the Jacobian. + call amovkr (yref[line], Memr[y], ncols) + if (sy == NULL) + call gsder (sx, xref[c1], Memr[y], Memr[jacob], ncols, 1, 0) + else { + call salloc (der1, ncols, TY_REAL) + call salloc (der2, ncols, TY_REAL) + call gsder (sx, xref[c1], Memr[y], Memr[der1], ncols, 1, 0) + call gsder (sy, xref[c1], Memr[y], Memr[der2], ncols, 0, 1) + call amulr (Memr[der1], Memr[der2], Memr[jacob], ncols) + call gsder (sx, xref[c1], Memr[y], Memr[der1], ncols, 0, 1) + call gsder (sy, xref[c1], Memr[y], Memr[der2], ncols, 1, 0) + call amulr (Memr[der1], Memr[der2], Memr[der1], ncols) + call asubr (Memr[jacob], Memr[der1], Memr[jacob], ncols) + } + call aabsr (Memr[jacob], Memr[jacob], ncols) + call amulr (buf, Memr[jacob], buf, ncols) + + # Clean up. + call gsfree (sx) + if (sy != NULL) + call gsfree (sy) + call sfree (sp) +end + + +# GEO_MSIFLUX -- Procedure to interpolate the surface coordinates + +procedure geo_msiflux (jmsi, xinterp, yinterp, outdata, c1, c2, line, x0, y0) + +pointer jmsi #I pointer to the jacobian interpolant +real xinterp[ARB] #I x reference coordinates +real yinterp[ARB] #I y reference coordinates +real outdata[ARB] #O output data +int c1, c2 #I column limits in output image +int line #I line to be flux corrected +int x0, y0 #I zero points of interpolation coordinates + +int ncols +pointer sp, x, y, jacob + +begin + # Allocate tempoaray space. + call smark (sp) + ncols = c2 - c1 + 1 + call salloc (x, ncols, TY_REAL) + call salloc (jacob, ncols, TY_REAL) + + # Calculate the x points. + if (x0 == 1) + call amovr (xinterp[c1], Memr[x], ncols) + else + call aaddkr (xinterp[c1], real (-x0 + 1), Memr[x], ncols) + + # Multiply the data by the Jacobian. + if (line == 0) { + call asivector (jmsi, Memr[x], Memr[jacob], ncols) + } else { + call salloc (y, ncols, TY_REAL) + call amovkr ((yinterp[line] + real (-y0 + 1)), Memr[y], ncols) + call msivector (jmsi, Memr[x], Memr[y], Memr[jacob], ncols) + } + call aabsr (Memr[jacob], Memr[jacob], ncols) + call amulr (outdata, Memr[jacob], outdata, ncols) + + call sfree (sp) +end + + +# GEO_JFACTOR -- Compute the Jacobian of a linear transformation. + +real procedure geo_jfactor (sx1, sy1) + +pointer sx1 #I pointer to x surface +pointer sy1 #I pointer to y surface + +real xval, yval, xx, xy, yx, yy +real gsgetr() + +begin + xval = (gsgetr (sx1, GSXMIN) + gsgetr (sx1, GSXMAX)) / 2.0 + if (sy1 == NULL) + yval = 1.0 + else + yval = (gsgetr (sy1, GSYMIN) + gsgetr (sy1, GSYMIN)) / 2.0 + + call gsder (sx1, xval, yval, xx, 1, 1, 0) + if (sy1 == NULL) { + xy = 0.0 + yy = 1.0 + yx = 0.0 + } else { + call gsder (sx1, xval, yval, xy, 1, 0, 1) + call gsder (sy1, xval, yval, yx, 1, 1, 0) + call gsder (sy1, xval, yval, yy, 1, 0, 1) + } + + return (abs (xx * yy - xy * yx)) +end + + +# GEO_REPEAT -- Copy a small repeated pattern into the output buffer. + +procedure geo_repeat (pat, npat, output, ntimes) + +real pat[ARB] #I the input pattern to be repeated +int npat #I the size of the pattern +real output[ARB] #O the output array +int ntimes #I the number of times the pattern is to be repeated + +int j, i, offset + +begin + do j = 1, ntimes { + offset = npat * j - npat + do i = 1, npat + output[offset+i] = pat[i] + } +end diff --git a/pkg/images/immatch/src/geometry/geoxytran.gx b/pkg/images/immatch/src/geometry/geoxytran.gx new file mode 100644 index 00000000..22d577f1 --- /dev/null +++ b/pkg/images/immatch/src/geometry/geoxytran.gx @@ -0,0 +1,327 @@ +include <ctype.h> +include <mach.h> +include <math.h> +include <math/gsurfit.h> + +define GEO_LINEAR 1 # Linear transformation only +define GEO_DISTORTION 2 # Distortion correction only +define GEO_GEOMETRIC 3 # Full transformation + +$for (rd) + +# GEO_LINIT -- Initialize the linear part of the transformation. + +$if (datatype == r) +procedure geo_linitr (sx1, sy1, sx2, sy2) +$else +procedure geo_linitd (sx1, sy1, sx2, sy2) +$endif + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +pointer sx2, sy2 #I/O pointer to the distortion x and y surfaces + +PIXEL xmag, ymag, xrot, yrot, xref, yref, xout, yout, xshift, yshift +$if (datatype == r) +real clgetr(), gseval() +$else +double clgetd(), dgseval() +$endif + +begin + # Initialize the surfaces. +$if (datatype == r) + call gsinit (sx1, GS_POLYNOMIAL, 2, 2, GS_XNONE, -MAX_REAL, MAX_REAL, + -MAX_REAL, MAX_REAL) + call gsinit (sy1, GS_POLYNOMIAL, 2, 2, GS_XNONE, -MAX_REAL, MAX_REAL, + -MAX_REAL, MAX_REAL) +$else + call dgsinit (sx1, GS_POLYNOMIAL, 2, 2, GS_XNONE, double (-MAX_REAL), + double (MAX_REAL), double (-MAX_REAL), double (MAX_REAL)) + call dgsinit (sy1, GS_POLYNOMIAL, 2, 2, GS_XNONE, double (-MAX_REAL), + double (MAX_REAL), double (-MAX_REAL), double (MAX_REAL)) +$endif + sx2 = NULL + sy2 = NULL + + # Get the magnification parameters. + xmag = clget$t ("xmag") + if (IS_$INDEF$T(xmag)) + xmag = PIXEL(1.0) + ymag = clget$t ("ymag") + if (IS_$INDEF$T(ymag)) + ymag = PIXEL(1.0) + + # Get the rotation parameters. + xrot = clget$t ("xrot") + if (IS_$INDEF$T(xrot)) + xrot = PIXEL(0.0) + xrot = -DEGTORAD(xrot) + yrot = clget$t ("yrot") + if (IS_$INDEF$T(yrot)) + yrot = PIXEL(0.0) + yrot = -DEGTORAD(yrot) + + # Set the magnification and rotation coefficients. + call geo_rotmag$t (sx1, sy1, xmag, ymag, xrot, yrot) + + # Compute the origin of the reference coordinates. + xref = clget$t ("xref") + if (IS_$INDEF$T(xref)) + xref = PIXEL(0.0) + yref = clget$t ("yref") + if (IS_$INDEF$T(yref)) + yref = PIXEL(0.0) + + # Compute the corresponding input coordinates. + xout = clget$t ("xout") + if (IS_$INDEF$T(xout)) +$if (datatype == r) + xout = gseval (sx1, xref, yref) +$else + xout = dgseval (sx1, xref, yref) +$endif + yout = clget$t ("yout") + if (IS_$INDEF$T(yout)) +$if (datatype == r) + yout = gseval (sy1, xref, yref) +$else + yout = dgseval (sy1, xref, yref) +$endif + + # Set the shifts. + xshift = clget$t ("xshift") + yshift = clget$t ("yshift") +$if (datatype == r) + if (IS_$INDEF$T(xshift)) + xshift = xout - gseval (sx1, xref, yref) + if (IS_$INDEF$T(yshift)) + yshift = yout - gseval (sy1, xref, yref) +$else + if (IS_$INDEF$T(xshift)) + xshift = xout - $tgseval (sx1, xref, yref) + if (IS_$INDEF$T(yshift)) + yshift = yout - $tgseval (sy1, xref, yref) +$endif + call geo_xyshift$t (sx1, sy1, xshift, yshift) +end + + +# GEO_SFREE -- Free the x and y surface fitting descriptors. + +$if (datatype == r) +procedure geo_sfreer (sx1, sy1, sx2, sy2) +$else +procedure geo_sfreed (sx1, sy1, sx2, sy2) +$endif + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +pointer sx2, sy2 #I/O pointer to the distortion x and y surfaces + +begin +$if (datatype == r) + call gsfree (sx1) + call gsfree (sy1) + if (sx2 != NULL) + call gsfree (sx2) + if (sy2 != NULL) + call gsfree (sy2) +$else + call dgsfree (sx1) + call dgsfree (sy1) + if (sx2 != NULL) + call dgsfree (sx2) + if (sy2 != NULL) + call dgsfree (sy2) +$endif +end + + +# GEO_SINIT -- Read the surface fits from the database file and make +# any requested changes. + +procedure geo_sinit$t (dt, record, geometry, sx1, sy1, sx2, sy2) + +pointer dt #I pointer to database file produced by geomap +char record[ARB] #I the name of the database record +int geometry #I the type of geometry to be computed +pointer sx1, sy1 #O pointers to the linear x and y surfaces +pointer sx2, sy2 #O pointers to the x and y distortion surfaces + +int i, rec, ncoeff, junk +PIXEL xmag, ymag, xrot, yrot, xref, yref, xout, yout, xshift, yshift +pointer newsx1, newsy1, xcoeff, ycoeff +int dtlocate(), dtscan(), dtgeti() +PIXEL clget$t() +$if (datatype == r) +errchk gsrestore +$else +errchk dgsrestore +$endif + +begin + # Locate record. + rec = dtlocate (dt, record) + + # Get linear part of fit. + ncoeff = dtgeti (dt, rec, "surface1") + call malloc (xcoeff, ncoeff, TY_PIXEL) + call malloc (ycoeff, ncoeff, TY_PIXEL) + do i = 1, ncoeff { + junk = dtscan (dt) + call garg$t (Mem$t[xcoeff+i-1]) + call garg$t (Mem$t[ycoeff+i-1]) + } + + # Restore linear part of fit. +$if (datatype == r) + call gsrestore (sx1, Mem$t[xcoeff]) + call gsrestore (sy1, Mem$t[ycoeff]) +$else + call dgsrestore (sx1, Mem$t[xcoeff]) + call dgsrestore (sy1, Mem$t[ycoeff]) +$endif + + # Get geometric transformation. + xmag = clget$t ("xmag") + ymag = clget$t ("ymag") + xrot = clget$t ("xrotation") + yrot = clget$t ("yrotation") + xout = clget$t ("xout") + yout = clget$t ("yout") + xref = clget$t ("xref") + yref = clget$t ("yref") + xshift = clget$t ("xshift") + yshift = clget$t ("yshift") + + # Get set to adjust linear part of the fit. +$if (datatype == r) + call gscopy (sx1, newsx1) + call gscopy (sy1, newsy1) +$else + call dgscopy (sx1, newsx1) + call dgscopy (sy1, newsy1) +$endif + + if (geometry == GEO_DISTORTION) + call geo_rotmag$t (newsx1, newsy1, PIXEL(1.0), PIXEL(1.0), + PIXEL(0.0), PIXEL(0.0)) + else if (! IS_$INDEF$T(xmag) || ! IS_$INDEF$T(ymag) || + ! IS_$INDEF$T(xrot) || ! IS_$INDEF$T(yrot)) + call geo_drotmag$t (dt, rec, newsx1, newsy1, xmag, ymag, + xrot, yrot) + call geo_dxyshift$t (dt, rec, newsx1, newsy1, xout, yout, xref, yref, + xshift, yshift) +$if (datatype == r) + call gssave (newsx1, Mem$t[xcoeff]) + call gssave (newsy1, Mem$t[ycoeff]) +$else + call dgssave (newsx1, Mem$t[xcoeff]) + call dgssave (newsy1, Mem$t[ycoeff]) +$endif + + # Get distortion part of fit. + ncoeff = dtgeti (dt, rec, "surface2") + if (ncoeff > 0 && (geometry == GEO_GEOMETRIC || + geometry == GEO_DISTORTION)) { + + call realloc (xcoeff, ncoeff, TY_PIXEL) + call realloc (ycoeff, ncoeff, TY_PIXEL) + do i = 1, ncoeff { + junk = dtscan (dt) + call garg$t (Mem$t[xcoeff+i-1]) + call garg$t (Mem$t[ycoeff+i-1]) + } + + # Restore distortion part of fit. +$if (datatype == r) + iferr { + call gsrestore (sx2, Mem$t[xcoeff]) + } then { + call mfree (sx2, TY_STRUCT) + sx2 = NULL + } + iferr { + call gsrestore (sy2, Mem$t[ycoeff]) + } then { + call mfree (sy2, TY_STRUCT) + sy2 = NULL + } +$else + iferr { + call dgsrestore (sx2, Mem$t[xcoeff]) + } then { + call mfree (sx2, TY_STRUCT) + sx2 = NULL + } + iferr { + call dgsrestore (sy2, Mem$t[ycoeff]) + } then { + call mfree (sy2, TY_STRUCT) + sy2 = NULL + } +$endif + + } else { + sx2 = NULL + sy2 = NULL + } + + # Redefine the linear surfaces. +$if (datatype == r) + call gsfree (sx1) + call gscopy (newsx1, sx1) + call gsfree (newsx1) + call gsfree (sy1) + call gscopy (newsy1, sy1) + call gsfree (newsy1) +$else + call dgsfree (sx1) + call dgscopy (newsx1, sx1) + call dgsfree (newsx1) + call dgsfree (sy1) + call dgscopy (newsy1, sy1) + call dgsfree (newsy1) +$endif + + # Cleanup. + call mfree (xcoeff, TY_PIXEL) + call mfree (ycoeff, TY_PIXEL) +end + + +# GEO_DO_TRANSFORM -- The linear transformation is performed in this procedure. +# First the coordinates are scaled, then rotated and translated. The +# transformed coordinates are returned. + +procedure geo_do_transform$t (x, y, xt, yt, sx1, sy1, sx2, sy2) + +PIXEL x, y # initial positions +PIXEL xt, yt # transformed positions +pointer sx1, sy1 # pointer to linear surfaces +pointer sx2, sy2 # pointer to distortion surfaces + +$if (datatype == r) +real gseval() +$else +double dgseval() +$endif + +begin +$if (datatype == r) + xt = gseval (sx1, x, y) + if (sx2 != NULL) + xt = xt + gseval (sx2, x, y) + yt = gseval (sy1, x, y) + if (sy2 != NULL) + yt = yt + gseval (sy2, x, y) +$else + xt = dgseval (sx1, x, y) + if (sx2 != NULL) + xt = xt + dgseval (sx2, x, y) + yt = dgseval (sy1, x, y) + if (sy2 != NULL) + yt = yt + dgseval (sy2, x, y) +$endif +end + +$endfor diff --git a/pkg/images/immatch/src/geometry/geoxytran.x b/pkg/images/immatch/src/geometry/geoxytran.x new file mode 100644 index 00000000..e8bb9f64 --- /dev/null +++ b/pkg/images/immatch/src/geometry/geoxytran.x @@ -0,0 +1,446 @@ +include <ctype.h> +include <mach.h> +include <math.h> +include <math/gsurfit.h> + +define GEO_LINEAR 1 # Linear transformation only +define GEO_DISTORTION 2 # Distortion correction only +define GEO_GEOMETRIC 3 # Full transformation + + + +# GEO_LINIT -- Initialize the linear part of the transformation. + +procedure geo_linitr (sx1, sy1, sx2, sy2) + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +pointer sx2, sy2 #I/O pointer to the distortion x and y surfaces + +real xmag, ymag, xrot, yrot, xref, yref, xout, yout, xshift, yshift +real clgetr(), gseval() + +begin + # Initialize the surfaces. + call gsinit (sx1, GS_POLYNOMIAL, 2, 2, GS_XNONE, -MAX_REAL, MAX_REAL, + -MAX_REAL, MAX_REAL) + call gsinit (sy1, GS_POLYNOMIAL, 2, 2, GS_XNONE, -MAX_REAL, MAX_REAL, + -MAX_REAL, MAX_REAL) + sx2 = NULL + sy2 = NULL + + # Get the magnification parameters. + xmag = clgetr ("xmag") + if (IS_INDEFR(xmag)) + xmag = real(1.0) + ymag = clgetr ("ymag") + if (IS_INDEFR(ymag)) + ymag = real(1.0) + + # Get the rotation parameters. + xrot = clgetr ("xrot") + if (IS_INDEFR(xrot)) + xrot = real(0.0) + xrot = -DEGTORAD(xrot) + yrot = clgetr ("yrot") + if (IS_INDEFR(yrot)) + yrot = real(0.0) + yrot = -DEGTORAD(yrot) + + # Set the magnification and rotation coefficients. + call geo_rotmagr (sx1, sy1, xmag, ymag, xrot, yrot) + + # Compute the origin of the reference coordinates. + xref = clgetr ("xref") + if (IS_INDEFR(xref)) + xref = real(0.0) + yref = clgetr ("yref") + if (IS_INDEFR(yref)) + yref = real(0.0) + + # Compute the corresponding input coordinates. + xout = clgetr ("xout") + if (IS_INDEFR(xout)) + xout = gseval (sx1, xref, yref) + yout = clgetr ("yout") + if (IS_INDEFR(yout)) + yout = gseval (sy1, xref, yref) + + # Set the shifts. + xshift = clgetr ("xshift") + yshift = clgetr ("yshift") + if (IS_INDEFR(xshift)) + xshift = xout - gseval (sx1, xref, yref) + if (IS_INDEFR(yshift)) + yshift = yout - gseval (sy1, xref, yref) + call geo_xyshiftr (sx1, sy1, xshift, yshift) +end + + +# GEO_SFREE -- Free the x and y surface fitting descriptors. + +procedure geo_sfreer (sx1, sy1, sx2, sy2) + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +pointer sx2, sy2 #I/O pointer to the distortion x and y surfaces + +begin + call gsfree (sx1) + call gsfree (sy1) + if (sx2 != NULL) + call gsfree (sx2) + if (sy2 != NULL) + call gsfree (sy2) +end + + +# GEO_SINIT -- Read the surface fits from the database file and make +# any requested changes. + +procedure geo_sinitr (dt, record, geometry, sx1, sy1, sx2, sy2) + +pointer dt #I pointer to database file produced by geomap +char record[ARB] #I the name of the database record +int geometry #I the type of geometry to be computed +pointer sx1, sy1 #O pointers to the linear x and y surfaces +pointer sx2, sy2 #O pointers to the x and y distortion surfaces + +int i, rec, ncoeff, junk +real xmag, ymag, xrot, yrot, xref, yref, xout, yout, xshift, yshift +pointer newsx1, newsy1, xcoeff, ycoeff +int dtlocate(), dtscan(), dtgeti() +real clgetr() +errchk gsrestore + +begin + # Locate record. + rec = dtlocate (dt, record) + + # Get linear part of fit. + ncoeff = dtgeti (dt, rec, "surface1") + call malloc (xcoeff, ncoeff, TY_REAL) + call malloc (ycoeff, ncoeff, TY_REAL) + do i = 1, ncoeff { + junk = dtscan (dt) + call gargr (Memr[xcoeff+i-1]) + call gargr (Memr[ycoeff+i-1]) + } + + # Restore linear part of fit. + call gsrestore (sx1, Memr[xcoeff]) + call gsrestore (sy1, Memr[ycoeff]) + + # Get geometric transformation. + xmag = clgetr ("xmag") + ymag = clgetr ("ymag") + xrot = clgetr ("xrotation") + yrot = clgetr ("yrotation") + xout = clgetr ("xout") + yout = clgetr ("yout") + xref = clgetr ("xref") + yref = clgetr ("yref") + xshift = clgetr ("xshift") + yshift = clgetr ("yshift") + + # Get set to adjust linear part of the fit. + call gscopy (sx1, newsx1) + call gscopy (sy1, newsy1) + + if (geometry == GEO_DISTORTION) + call geo_rotmagr (newsx1, newsy1, real(1.0), real(1.0), + real(0.0), real(0.0)) + else if (! IS_INDEFR(xmag) || ! IS_INDEFR(ymag) || + ! IS_INDEFR(xrot) || ! IS_INDEFR(yrot)) + call geo_drotmagr (dt, rec, newsx1, newsy1, xmag, ymag, + xrot, yrot) + call geo_dxyshiftr (dt, rec, newsx1, newsy1, xout, yout, xref, yref, + xshift, yshift) + call gssave (newsx1, Memr[xcoeff]) + call gssave (newsy1, Memr[ycoeff]) + + # Get distortion part of fit. + ncoeff = dtgeti (dt, rec, "surface2") + if (ncoeff > 0 && (geometry == GEO_GEOMETRIC || + geometry == GEO_DISTORTION)) { + + call realloc (xcoeff, ncoeff, TY_REAL) + call realloc (ycoeff, ncoeff, TY_REAL) + do i = 1, ncoeff { + junk = dtscan (dt) + call gargr (Memr[xcoeff+i-1]) + call gargr (Memr[ycoeff+i-1]) + } + + # Restore distortion part of fit. + iferr { + call gsrestore (sx2, Memr[xcoeff]) + } then { + call mfree (sx2, TY_STRUCT) + sx2 = NULL + } + iferr { + call gsrestore (sy2, Memr[ycoeff]) + } then { + call mfree (sy2, TY_STRUCT) + sy2 = NULL + } + + } else { + sx2 = NULL + sy2 = NULL + } + + # Redefine the linear surfaces. + call gsfree (sx1) + call gscopy (newsx1, sx1) + call gsfree (newsx1) + call gsfree (sy1) + call gscopy (newsy1, sy1) + call gsfree (newsy1) + + # Cleanup. + call mfree (xcoeff, TY_REAL) + call mfree (ycoeff, TY_REAL) +end + + +# GEO_DO_TRANSFORM -- The linear transformation is performed in this procedure. +# First the coordinates are scaled, then rotated and translated. The +# transformed coordinates are returned. + +procedure geo_do_transformr (x, y, xt, yt, sx1, sy1, sx2, sy2) + +real x, y # initial positions +real xt, yt # transformed positions +pointer sx1, sy1 # pointer to linear surfaces +pointer sx2, sy2 # pointer to distortion surfaces + +real gseval() + +begin + xt = gseval (sx1, x, y) + if (sx2 != NULL) + xt = xt + gseval (sx2, x, y) + yt = gseval (sy1, x, y) + if (sy2 != NULL) + yt = yt + gseval (sy2, x, y) +end + + + +# GEO_LINIT -- Initialize the linear part of the transformation. + +procedure geo_linitd (sx1, sy1, sx2, sy2) + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +pointer sx2, sy2 #I/O pointer to the distortion x and y surfaces + +double xmag, ymag, xrot, yrot, xref, yref, xout, yout, xshift, yshift +double clgetd(), dgseval() + +begin + # Initialize the surfaces. + call dgsinit (sx1, GS_POLYNOMIAL, 2, 2, GS_XNONE, double (-MAX_REAL), + double (MAX_REAL), double (-MAX_REAL), double (MAX_REAL)) + call dgsinit (sy1, GS_POLYNOMIAL, 2, 2, GS_XNONE, double (-MAX_REAL), + double (MAX_REAL), double (-MAX_REAL), double (MAX_REAL)) + sx2 = NULL + sy2 = NULL + + # Get the magnification parameters. + xmag = clgetd ("xmag") + if (IS_INDEFD(xmag)) + xmag = double(1.0) + ymag = clgetd ("ymag") + if (IS_INDEFD(ymag)) + ymag = double(1.0) + + # Get the rotation parameters. + xrot = clgetd ("xrot") + if (IS_INDEFD(xrot)) + xrot = double(0.0) + xrot = -DEGTORAD(xrot) + yrot = clgetd ("yrot") + if (IS_INDEFD(yrot)) + yrot = double(0.0) + yrot = -DEGTORAD(yrot) + + # Set the magnification and rotation coefficients. + call geo_rotmagd (sx1, sy1, xmag, ymag, xrot, yrot) + + # Compute the origin of the reference coordinates. + xref = clgetd ("xref") + if (IS_INDEFD(xref)) + xref = double(0.0) + yref = clgetd ("yref") + if (IS_INDEFD(yref)) + yref = double(0.0) + + # Compute the corresponding input coordinates. + xout = clgetd ("xout") + if (IS_INDEFD(xout)) + xout = dgseval (sx1, xref, yref) + yout = clgetd ("yout") + if (IS_INDEFD(yout)) + yout = dgseval (sy1, xref, yref) + + # Set the shifts. + xshift = clgetd ("xshift") + yshift = clgetd ("yshift") + if (IS_INDEFD(xshift)) + xshift = xout - dgseval (sx1, xref, yref) + if (IS_INDEFD(yshift)) + yshift = yout - dgseval (sy1, xref, yref) + call geo_xyshiftd (sx1, sy1, xshift, yshift) +end + + +# GEO_SFREE -- Free the x and y surface fitting descriptors. + +procedure geo_sfreed (sx1, sy1, sx2, sy2) + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +pointer sx2, sy2 #I/O pointer to the distortion x and y surfaces + +begin + call dgsfree (sx1) + call dgsfree (sy1) + if (sx2 != NULL) + call dgsfree (sx2) + if (sy2 != NULL) + call dgsfree (sy2) +end + + +# GEO_SINIT -- Read the surface fits from the database file and make +# any requested changes. + +procedure geo_sinitd (dt, record, geometry, sx1, sy1, sx2, sy2) + +pointer dt #I pointer to database file produced by geomap +char record[ARB] #I the name of the database record +int geometry #I the type of geometry to be computed +pointer sx1, sy1 #O pointers to the linear x and y surfaces +pointer sx2, sy2 #O pointers to the x and y distortion surfaces + +int i, rec, ncoeff, junk +double xmag, ymag, xrot, yrot, xref, yref, xout, yout, xshift, yshift +pointer newsx1, newsy1, xcoeff, ycoeff +int dtlocate(), dtscan(), dtgeti() +double clgetd() +errchk dgsrestore + +begin + # Locate record. + rec = dtlocate (dt, record) + + # Get linear part of fit. + ncoeff = dtgeti (dt, rec, "surface1") + call malloc (xcoeff, ncoeff, TY_DOUBLE) + call malloc (ycoeff, ncoeff, TY_DOUBLE) + do i = 1, ncoeff { + junk = dtscan (dt) + call gargd (Memd[xcoeff+i-1]) + call gargd (Memd[ycoeff+i-1]) + } + + # Restore linear part of fit. + call dgsrestore (sx1, Memd[xcoeff]) + call dgsrestore (sy1, Memd[ycoeff]) + + # Get geometric transformation. + xmag = clgetd ("xmag") + ymag = clgetd ("ymag") + xrot = clgetd ("xrotation") + yrot = clgetd ("yrotation") + xout = clgetd ("xout") + yout = clgetd ("yout") + xref = clgetd ("xref") + yref = clgetd ("yref") + xshift = clgetd ("xshift") + yshift = clgetd ("yshift") + + # Get set to adjust linear part of the fit. + call dgscopy (sx1, newsx1) + call dgscopy (sy1, newsy1) + + if (geometry == GEO_DISTORTION) + call geo_rotmagd (newsx1, newsy1, double(1.0), double(1.0), + double(0.0), double(0.0)) + else if (! IS_INDEFD(xmag) || ! IS_INDEFD(ymag) || + ! IS_INDEFD(xrot) || ! IS_INDEFD(yrot)) + call geo_drotmagd (dt, rec, newsx1, newsy1, xmag, ymag, + xrot, yrot) + call geo_dxyshiftd (dt, rec, newsx1, newsy1, xout, yout, xref, yref, + xshift, yshift) + call dgssave (newsx1, Memd[xcoeff]) + call dgssave (newsy1, Memd[ycoeff]) + + # Get distortion part of fit. + ncoeff = dtgeti (dt, rec, "surface2") + if (ncoeff > 0 && (geometry == GEO_GEOMETRIC || + geometry == GEO_DISTORTION)) { + + call realloc (xcoeff, ncoeff, TY_DOUBLE) + call realloc (ycoeff, ncoeff, TY_DOUBLE) + do i = 1, ncoeff { + junk = dtscan (dt) + call gargd (Memd[xcoeff+i-1]) + call gargd (Memd[ycoeff+i-1]) + } + + # Restore distortion part of fit. + iferr { + call dgsrestore (sx2, Memd[xcoeff]) + } then { + call mfree (sx2, TY_STRUCT) + sx2 = NULL + } + iferr { + call dgsrestore (sy2, Memd[ycoeff]) + } then { + call mfree (sy2, TY_STRUCT) + sy2 = NULL + } + + } else { + sx2 = NULL + sy2 = NULL + } + + # Redefine the linear surfaces. + call dgsfree (sx1) + call dgscopy (newsx1, sx1) + call dgsfree (newsx1) + call dgsfree (sy1) + call dgscopy (newsy1, sy1) + call dgsfree (newsy1) + + # Cleanup. + call mfree (xcoeff, TY_DOUBLE) + call mfree (ycoeff, TY_DOUBLE) +end + + +# GEO_DO_TRANSFORM -- The linear transformation is performed in this procedure. +# First the coordinates are scaled, then rotated and translated. The +# transformed coordinates are returned. + +procedure geo_do_transformd (x, y, xt, yt, sx1, sy1, sx2, sy2) + +double x, y # initial positions +double xt, yt # transformed positions +pointer sx1, sy1 # pointer to linear surfaces +pointer sx2, sy2 # pointer to distortion surfaces + +double dgseval() + +begin + xt = dgseval (sx1, x, y) + if (sx2 != NULL) + xt = xt + dgseval (sx2, x, y) + yt = dgseval (sy1, x, y) + if (sy2 != NULL) + yt = yt + dgseval (sy2, x, y) +end + + diff --git a/pkg/images/immatch/src/geometry/mkpkg b/pkg/images/immatch/src/geometry/mkpkg new file mode 100644 index 00000000..e6e98b24 --- /dev/null +++ b/pkg/images/immatch/src/geometry/mkpkg @@ -0,0 +1,34 @@ +# Make the GEOMAP/GEOXYTRAN and CCMAP/CCSETWCS/CCTRAN tasks + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + +generic: + $set GEN = "$$generic -k" + + $ifolder (geofunc.x, geofunc.gx) + $(GEN) geofunc.gx -o geofunc.x $endif + $ifolder (t_geomap.x, t_geomap.gx) + $(GEN) t_geomap.gx -o t_geomap.x $endif + $ifolder (geoxytran.x,geoxytran.gx) + $(GEN) geoxytran.gx -o geoxytran.x $endif + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + geofunc.x <math.h> <math/gsurfit.h> + geotimtran.x <imhdr.h> <imset.h> <mach.h> <math/gsurfit.h> \ + <math/iminterp.h> geotran.h + geotran.x <imhdr.h> <imset.h> <mach.h> <math/gsurfit.h> \ + <math/iminterp.h> geotran.h + geoxytran.x <mach.h> <ctype.h> <math.h> <math/gsurfit.h> + t_geomap.x <fset.h> <error.h> <mach.h> <math/gsurfit.h> \ + <math.h> "../../../lib/geomap.h" + t_geotran.x <imhdr.h> <mwset.h> <math.h> <math/gsurfit.h> \ + geotran.h + t_geoxytran.x <fset.h> <ctype.h> + trinvert.x + ; diff --git a/pkg/images/immatch/src/geometry/t_geomap.gx b/pkg/images/immatch/src/geometry/t_geomap.gx new file mode 100644 index 00000000..02d530e5 --- /dev/null +++ b/pkg/images/immatch/src/geometry/t_geomap.gx @@ -0,0 +1,921 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <fset.h> +include <error.h> +include <mach.h> +include <math.h> +include <math/gsurfit.h> +include "../../../lib/geomap.h" + +define GM_REAL 1 # computation type is real +define GM_DOUBLE 2 # computation type is double + +$for (r) + +# T_GEOMAP -- Procedure to calculate the transformation required to transform +# the coordinate system of a reference image to the coordinate system of +# an input image. The transformation is of the following form. +# +# xin = f (xref, yref) +# yin = g (xref, yref) + +procedure t_geomap () + +bool verbose, interactive +double xmin, xmax, ymin, ymax, reject +int geometry, function, calctype, nfiles, list, in, reclist, nrecords +int xxorder, xyorder, xxterms, yxorder, yyorder, yxterms, maxiter +int reslist, nresfiles, res +pointer sp, in_name, str, out, fit, gd, graphics +real rxmin, rxmax, rymin, rymax + +bool clgetb() +double clgetd() +int clgeti(), clgwrd(), clplen(), errget(), imtopenp(), imtlen() +int imtgetim() +pointer clpopnu(), clgfil(), dtmap(), gopen(), open() + +errchk geo_mapr(), geo_mapd() + +begin + # Get working space. + call smark (sp) + call salloc (in_name, SZ_FNAME, TY_CHAR) + call salloc (graphics, SZ_FNAME, TY_CHAR) + call salloc (str, max(SZ_LINE, SZ_FNAME), TY_CHAR) + + # Get input data file(s). + list = clpopnu ("input") + nfiles = clplen (list) + + # Open database output file. + call clgstr ("database", Memc[str], SZ_FNAME) + out = dtmap (Memc[str], APPEND) + + # Get minimum and maximum reference values. + xmin = clgetd ("xmin") + if (IS_INDEFD(xmin)) + rxmin = INDEFR + else + rxmin = xmin + xmax = clgetd ("xmax") + if (IS_INDEFD(xmax)) + rxmax = INDEFR + else + rxmax = xmax + ymin = clgetd ("ymin") + if (IS_INDEFD(ymin)) + rymin = INDEFR + else + rymin = ymin + ymax = clgetd ("ymax") + if (IS_INDEFD(ymax)) + rymax = INDEFR + else + rymax = ymax + + # Get the records list. + reclist = imtopenp ("transforms") + nrecords = imtlen (reclist) + if ((nrecords > 0) && (nrecords != nfiles)) { + call eprintf ( + "The number of records is not equal to the number of input files") + call clpcls (list) + call dtunmap (out) + call imtclose (reclist) + call sfree (sp) + return + } + + # Get the results file list. + reslist = clpopnu ("results") + nresfiles = clplen (reslist) + if (nresfiles > 1 && nresfiles != nfiles) { + call eprintf ("Error: there are too few results files\n") + call clpcls (list) + call dtunmap (out) + call imtclose (reclist) + call clpcls (reslist) + call sfree (sp) + return + } + + # Get the surface fitting parameters. + geometry = clgwrd ("fitgeometry", Memc[str], SZ_LINE, GM_GEOMETRIES) + function = clgwrd ("function", Memc[str], SZ_LINE, GM_FUNCS) + xxorder = clgeti ("xxorder") + xyorder = clgeti ("xyorder") + xxterms = clgwrd ("xxterms", Memc[str], SZ_LINE, GM_XFUNCS) - 1 + yxorder = clgeti ("yxorder") + yyorder = clgeti ("yyorder") + yxterms = clgwrd ("yxterms", Memc[str], SZ_LINE, GM_XFUNCS) - 1 + maxiter = clgeti ("maxiter") + reject = clgetd ("reject") + calctype = clgwrd ("calctype", Memc[str], SZ_LINE, ",real,double,") + + # Get the graphics parameters. + verbose = clgetb ("verbose") + interactive = clgetb ("interactive") + call clgstr ("graphics", Memc[graphics], SZ_FNAME) + + # Flush standard output on newline. + call fseti (STDOUT, F_FLUSHNL, YES) + + # Initialize the fit structure. + call geo_minit (fit, GM_NONE, geometry, function, xxorder, xyorder, + xxterms, yxorder, yyorder, yxterms, maxiter, reject) + + # Loop over the files. + while (clgfil (list, Memc[in_name], SZ_FNAME) != EOF) { + + # Open text file of coordinates. + in = open (Memc[in_name], READ_ONLY, TEXT_FILE) + + # Open the results files. + if (nresfiles <= 0) + res = NULL + else if (clgfil (reslist, Memc[str], SZ_FNAME) != EOF) + res = open (Memc[str], NEW_FILE, TEXT_FILE) + + # Set file name in structure. + if (nrecords > 0) { + if (imtgetim (reclist, GM_RECORD(fit), SZ_FNAME) != EOF) + ; + } else + call strcpy (Memc[in_name], GM_RECORD(fit), SZ_FNAME) + + if (verbose && res != STDOUT) { + call fstats (in, F_FILENAME, Memc[str], SZ_FNAME) + call printf ("\nCoordinate list: %s Transform: %s\n") + call pargstr (Memc[str]) + call pargstr (GM_RECORD(fit)) + if (res != NULL) + call fstats (res, F_FILENAME, Memc[str], SZ_FNAME) + else + call strcpy ("", Memc[str], SZ_FNAME) + call printf (" Results file: %s\n") + call pargstr (Memc[str]) + call flush (STDOUT) + } + if (res != NULL) { + call fstats (in, F_FILENAME, Memc[str], SZ_FNAME) + call fprintf (res, "\n# Coordinate list: %s Transform: %s\n") + call pargstr (Memc[str]) + call pargstr (GM_RECORD(fit)) + if (res != NULL) + call fstats (res, F_FILENAME, Memc[str], SZ_FNAME) + else + call strcpy ("", Memc[str], SZ_FNAME) + call fprintf (res, "# Results file: %s\n") + call pargstr (Memc[str]) + call flush (STDOUT) + } + + if (interactive) { + gd = gopen (Memc[graphics], NEW_FILE, STDGRAPH) + } else + gd = NULL + + iferr { + if (calctype == GM_REAL) + call geo_mapr (gd, in, out, res, fit, rxmin, rxmax, rymin, + rymax, verbose) + else + call geo_mapd (gd, in, out, res, fit, xmin, xmax, ymin, + ymax, verbose) + } then { + if (verbose && res != STDOUT) { + call printf ("Error fitting coordinate list: %s\n") + call pargstr (Memc[in_name]) + call flush (STDOUT) + if (errget (Memc[str], SZ_LINE) == 0) + ; + call printf ("\t%s\n") + call pargstr (Memc[str)) + } + if (res != NULL) { + call fprintf (res, "# Error fitting coordinate list: %s\n") + call pargstr (Memc[in_name]) + call flush (STDOUT) + if (errget (Memc[str], SZ_LINE) == 0) + ; + call fprintf (res, "# %s\n") + call pargstr (Memc[str)) + } + } + + call close (in) + if (nresfiles == nfiles) + call close ( res) + + if (gd != NULL) + call gclose (gd) + } + + # Close up. + call geo_free (fit) + if (nresfiles < nfiles) + call close ( res) + call dtunmap (out) + call imtclose (reclist) + call clpcls (list) + call sfree (sp) +end + +$endfor + +$for (rd) + +# GEO_MAP -- Procedure to calculate the coordinate transformations + +procedure geo_map$t (gd, in, out, res, fit, xmin, xmax, ymin, ymax, verbose) + +pointer gd #I the graphics stream +int in #I the input file descriptor +pointer out #I the output file descriptor +int res #I the results file descriptor +pointer fit #I pointer to fit parameters +PIXEL xmin, xmax #I max and min xref values +PIXEL ymin, ymax #I max and min yref values +bool verbose #I verbose mode + +int npts, ngood +pointer sp, str, xref, yref, xin, yin, wts, xfit, yfit, xerrmsg, yerrmsg +pointer sx1, sy1, sx2, sy2 +PIXEL mintemp, maxtemp + +PIXEL asum$t() +int geo_rdxy$t() +errchk geo_fit$t, geo_mgfit$t() + +begin + # Get working space. + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (xerrmsg, SZ_LINE, TY_CHAR) + call salloc (yerrmsg, SZ_LINE, TY_CHAR) + + # Initialize pointers. + xref = NULL + yref = NULL + xin = NULL + yin = NULL + wts = NULL + + # Read in data and check that data is in range. + npts = geo_rdxy$t (in, xref, yref, xin, yin, xmin, xmax, ymin, ymax) + if (npts <= 0) { + call fstats (in, F_FILENAME, Memc[str], SZ_FNAME) + call printf ("Coordinate list: %s has no data in range.\n") + call pargstr (Memc[str]) + call sfree (sp) + return + } + + # Compute the mean of the reference and input coordinates. + GM_XOREF(fit) = double (asum$t (Mem$t[xref], npts) / npts) + GM_YOREF(fit) = double (asum$t (Mem$t[yref], npts) / npts) + GM_XOIN(fit) = double (asum$t (Mem$t[xin], npts) / npts) + GM_YOIN(fit) = double (asum$t (Mem$t[yin], npts) / npts) + + # Set the reference point for the projections to INDEF. + GM_XREFPT(fit) = INDEFD + GM_YREFPT(fit) = INDEFD + + # Compute the weights. + call malloc (xfit, npts, TY_PIXEL) + call malloc (yfit, npts, TY_PIXEL) + call malloc (wts, npts, TY_PIXEL) + call amovk$t (PIXEL(1.), Mem$t[wts], npts) + + # Determine the x max and min. + if (IS_$INDEF$T(xmin) || IS_$INDEF$T(xmax)) { + call alim$t (Mem$t[xref], npts, mintemp, maxtemp) + if (! IS_$INDEF$T(xmin)) + GM_XMIN(fit) = double (xmin) + else + GM_XMIN(fit) = double (mintemp) + if (! IS_$INDEF$T(xmax)) + GM_XMAX(fit) = double (xmax) + else + GM_XMAX(fit) = double (maxtemp) + } else { + GM_XMIN(fit) = double (xmin) + GM_XMAX(fit) = double (xmax) + } + + # Determine the y max and min. + if (IS_$INDEF$T(ymin) || IS_$INDEF$T(ymax)) { + call alim$t (Mem$t[yref], npts, mintemp, maxtemp) + if (! IS_$INDEF$T(ymin)) + GM_YMIN(fit) = double (ymin) + else + GM_YMIN(fit) = double (mintemp) + if (! IS_$INDEF$T(ymax)) + GM_YMAX(fit) = double (ymax) + else + GM_YMAX(fit) = double (maxtemp) + } else { + GM_YMIN(fit) = double (ymin) + GM_YMAX(fit) = double (ymax) + } + + # Initalize surface pointers. + sx1 = NULL + sy1 = NULL + sx2 = NULL + sy2 = NULL + + # Fit the data. + if (gd != NULL) { + iferr { + call geo_mgfit$t (gd, fit, sx1, sy1, sx2, sy2, Mem$t[xref], + Mem$t[yref], Mem$t[xin], Mem$t[yin], Mem$t[wts], npts, + Memc[xerrmsg], Memc[yerrmsg], SZ_LINE) + } then { + call gdeactivate (gd, 0) + call mfree (xfit, TY_PIXEL) + call mfree (yfit, TY_PIXEL) + call mfree (wts, TY_PIXEL) + call geo_mmfree$t (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few points for X or Y fits.") + } + call gdeactivate (gd, 0) + if (verbose && res != STDOUT) { + call printf ("Coordinate mapping status\n") + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "# Coordinate mapping status\n") + } + } else { + if (verbose && res != STDOUT) { + call printf ("Coordinate mapping status\n ") + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "# Coordinate mapping status\n# ") + } + iferr { + call geo_fit$t (fit, sx1, sy1, sx2, sy2, Mem$t[xref], + Mem$t[yref], Mem$t[xin], Mem$t[yin], Mem$t[wts], npts, + Memc[xerrmsg], Memc[yerrmsg], SZ_LINE) + } then { + call mfree (xfit, TY_PIXEL) + call mfree (yfit, TY_PIXEL) + call mfree (wts, TY_PIXEL) + call geo_mmfree$t (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few points for X or Y fits.") + } + if (verbose && res != STDOUT) { + call printf ("%s %s\n") + call pargstr (Memc[xerrmsg]) + call pargstr (Memc[yerrmsg]) + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "%s %s\n") + call pargstr (Memc[xerrmsg]) + call pargstr (Memc[yerrmsg]) + call flush (STDOUT) + } + } + ngood = GM_NPTS(fit) - GM_NWTS0(fit) + if (verbose && res != STDOUT) { + call printf (" Xin and Yin fit rms: %0.7g %0.7g\n") + if (ngood <= 1) { + call pargd (0.0d0) + call pargd (0.0d0) + } else { + call pargd (sqrt (GM_XRMS(fit) / (ngood - 1))) + call pargd (sqrt (GM_YRMS(fit) / (ngood - 1))) + } + call geo_show$t (STDOUT, fit, sx1, sy1, NO) + } + if (res != NULL) { + call fprintf (res, "# Xin and Yin fit rms: %0.7g %0.7g\n") + if (ngood <= 1) { + call pargd (0.0) + call pargd (0.0) + } else { + call pargd (sqrt (GM_XRMS(fit) / (ngood - 1))) + call pargd (sqrt (GM_YRMS(fit) / (ngood - 1))) + } + call geo_show$t (res, fit, sx1, sy1, YES) + } + + # Compute and print the fitted x and y values. + if (res != NULL) { + call geo_eval$t (sx1, sy1, sx2, sy2, Mem$t[xref], Mem$t[yref], + Mem$t[xfit], Mem$t[yfit], npts) + call geo_plist$t (res, fit, Mem$t[xref], Mem$t[yref], Mem$t[xin], + Mem$t[yin], Mem$t[xfit], Mem$t[yfit], Mem$t[wts], npts) + } + + # Free the data + if (xref != NULL) + call mfree (xref, TY_PIXEL) + if (yref != NULL) + call mfree (yref, TY_PIXEL) + if (xin != NULL) + call mfree (xin, TY_PIXEL) + if (yin != NULL) + call mfree (yin, TY_PIXEL) + if (xfit != NULL) + call mfree (xfit, TY_PIXEL) + if (yfit != NULL) + call mfree (yfit, TY_PIXEL) + if (wts != NULL) + call mfree (wts, TY_PIXEL) + + # Output the data. + call geo_mout$t (fit, out, sx1, sy1, sx2, sy2) + + # Free the space and close files. + call geo_mmfree$t (sx1, sy1, sx2, sy2) + call sfree (sp) +end + + +define GEO_DEFBUFSIZE 1000 # default data buffer sizes + +# GEO_RDXY -- Read in the data points. + +int procedure geo_rdxy$t (fd, xref, yref, xin, yin, xmin, xmax, ymin, ymax) + +int fd # the input file descriptor +pointer xref # the x reference coordinates +pointer yref # the y reference coordinates +pointer xin # the x coordinates +pointer yin # the y coordinates +PIXEL xmin, xmax # the range of the x coordinates +PIXEL ymin, ymax # the range of the y coordinates + +int npts, bufsize +int fscan(), nscan() + +begin + bufsize = GEO_DEFBUFSIZE + call malloc (xref, bufsize, TY_PIXEL) + call malloc (yref, bufsize, TY_PIXEL) + call malloc (xin, bufsize, TY_PIXEL) + call malloc (yin, bufsize, TY_PIXEL) + + npts = 0 + while (fscan (fd) != EOF) { + + # Decode the data. + call garg$t (Mem$t[xref+npts]) + call garg$t (Mem$t[yref+npts]) + call garg$t (Mem$t[xin+npts]) + call garg$t (Mem$t[yin+npts]) + if (nscan() < 4) + next + + # Check the data limits. + if (! IS_$INDEF$T(xmin)) { + if (Mem$t[xref+npts] < xmin) + next + } + if (! IS_$INDEF$T(xmax)) { + if (Mem$t[xref+npts] > xmax) + next + } + if (! IS_$INDEF$T(ymin)) { + if (Mem$t[yref+npts] < ymin) + next + } + if (! IS_$INDEF$T(ymax)) { + if (Mem$t[yref+npts] > ymax) + next + } + + npts = npts + 1 + if (npts >= bufsize) { + bufsize = bufsize + GEO_DEFBUFSIZE + call realloc (xref, bufsize, TY_PIXEL) + call realloc (yref, bufsize, TY_PIXEL) + call realloc (xin, bufsize, TY_PIXEL) + call realloc (yin, bufsize, TY_PIXEL) + } + } + + if (npts <= 0) { + call mfree (xref, TY_PIXEL) + call mfree (yref, TY_PIXEL) + call mfree (xin, TY_PIXEL) + call mfree (yin, TY_PIXEL) + xref = NULL + yref = NULL + xin = NULL + yin = NULL + } else if (npts < bufsize) { + call realloc (xref, npts, TY_PIXEL) + call realloc (yref, npts, TY_PIXEL) + call realloc (xin, npts, TY_PIXEL) + call realloc (yin, npts, TY_PIXEL) + } + + return (npts) +end + + +# GEO_EVAL -- Evalute the fit. + +procedure geo_eval$t (sx1, sy1, sx2, sy2, xref, yref, xi, eta, npts) + +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to higher order surfaces +PIXEL xref[ARB] #I the x reference coordinates +PIXEL yref[ARB] #I the y reference coordinates +PIXEL xi[ARB] #O the fitted xi coordinates +PIXEL eta[ARB] #O the fitted eta coordinates +int npts #I the number of points + +pointer sp, temp + +begin + call smark (sp) + call salloc (temp, npts, TY_PIXEL) + +$if (datatype == r) + call gsvector (sx1, xref, yref, xi, npts) +$else + call dgsvector (sx1, xref, yref, xi, npts) +$endif + if (sx2 != NULL) { +$if (datatype == r) + call gsvector (sx2, xref, yref, Mem$t[temp], npts) +$else + call dgsvector (sx2, xref, yref, Mem$t[temp], npts) +$endif + call aadd$t (Mem$t[temp], xi, xi, npts) + } +$if (datatype == r) + call gsvector (sy1, xref, yref, eta, npts) +$else + call dgsvector (sy1, xref, yref, eta, npts) +$endif + if (sy2 != NULL) { +$if (datatype == r) + call gsvector (sy2, xref, yref, Mem$t[temp], npts) +$else + call dgsvector (sy2, xref, yref, Mem$t[temp], npts) +$endif + + call aadd$t (Mem$t[temp], eta, eta, npts) + } + + call sfree (sp) +end + + +# GEO_MOUT -- Write the output database file. + +procedure geo_mout$t (fit, out, sx1, sy1, sx2, sy2) + +pointer fit #I pointer to fitting structure +int out #I pointer to database file +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to distortion surfaces + +int i, npts, ncoeff +pointer sp, str, xcoeff, ycoeff +PIXEL xrms, yrms, xshift, yshift, xscale, yscale, xrot, yrot +$if (datatype == r) +int gsgeti() +$else +int dgsgeti() +$endif +int rg_wrdstr() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Compute the x and y fit rms. + #npts = max (0, GM_NPTS(fit) - GM_NREJECT(fit) - GM_NWTS0(fit)) + npts = max (0, GM_NPTS(fit) - GM_NWTS0(fit)) + xrms = max (0.0d0, GM_XRMS(fit)) + yrms = max (0.0d0, GM_YRMS(fit)) + if (npts > 1) { + xrms = sqrt (xrms / (npts - 1)) + yrms = sqrt (yrms / (npts - 1)) + } else { + xrms = 0.0d0 + yrms = 0.0d0 + } + + # Print title. + call dtptime (out) + call dtput (out, "begin\t%s\n") + call pargstr (GM_RECORD(fit)) + + # Print the x and y mean values. + call dtput (out, "\txrefmean\t%g\n") + call pargd (GM_XOREF(fit)) + call dtput (out, "\tyrefmean\t%g\n") + call pargd (GM_YOREF(fit)) + call dtput (out, "\txmean\t\t%g\n") + call pargd (GM_XOIN(fit)) + call dtput (out, "\tymean\t\t%g\n") + call pargd (GM_YOIN(fit)) + + # Print some of the fitting parameters. + if (rg_wrdstr (GM_FIT(fit), Memc[str], SZ_FNAME, GM_GEOMETRIES) <= 0) + call strcpy ("general", Memc[str], SZ_FNAME) + call dtput (out, "\tgeometry\t%s\n") + call pargstr (Memc[str]) + if (rg_wrdstr (GM_FUNCTION(fit), Memc[str], SZ_FNAME, GM_FUNCS) <= 0) + call strcpy ("polynomial", Memc[str], SZ_FNAME) + call dtput (out, "\tfunction\t%s\n") + call pargstr (Memc[str]) + + # Output the geometric parameters. + call geo_lcoeff$t (sx1, sy1, xshift, yshift, xscale, yscale, xrot, yrot) + call dtput (out, "\txshift\t\t%g\n") + call parg$t (xshift) + call dtput (out, "\tyshift\t\t%g\n") + call parg$t (yshift) + call dtput (out, "\txmag\t\t%g\n") + call parg$t (xscale) + call dtput (out, "\tymag\t\t%g\n") + call parg$t (yscale) + call dtput (out, "\txrotation\t%g\n") + call parg$t (xrot) + call dtput (out, "\tyrotation\t%g\n") + call parg$t (yrot) + + # Out the rms values. + call dtput (out, "\txrms\t\t%g\n") + call parg$t (PIXEL(xrms)) + call dtput (out, "\tyrms\t\t%g\n") + call parg$t (PIXEL(yrms)) + + # Allocate memory for linear coefficients. +$if (datatype == r) + ncoeff = max (gsgeti (sx1, GSNSAVE), gsgeti (sy1, GSNSAVE)) +$else + ncoeff = max (dgsgeti (sx1, GSNSAVE), dgsgeti (sy1, GSNSAVE)) +$endif + call calloc (xcoeff, ncoeff, TY_PIXEL) + call calloc (ycoeff, ncoeff, TY_PIXEL) + + # Output the linear coefficients. +$if (datatype == r) + call gssave (sx1, Mem$t[xcoeff]) + call gssave (sy1, Mem$t[ycoeff]) +$else + call dgssave (sx1, Mem$t[xcoeff]) + call dgssave (sy1, Mem$t[ycoeff]) +$endif + call dtput (out, "\tsurface1\t%d\n") + call pargi (ncoeff) + do i = 1, ncoeff { + call dtput (out, "\t\t\t%g\t%g\n") + call parg$t (Mem$t[xcoeff+i-1]) + call parg$t (Mem$t[ycoeff+i-1]) + } + + call mfree (xcoeff, TY_PIXEL) + call mfree (ycoeff, TY_PIXEL) + + # Allocate memory for higer order coefficients. + if (sx2 == NULL) + ncoeff = 0 + else +$if (datatype == r) + ncoeff = gsgeti (sx2, GSNSAVE) +$else + ncoeff = dgsgeti (sx2, GSNSAVE) +$endif + if (sy2 == NULL) + ncoeff = max (0, ncoeff) + else +$if (datatype == r) + ncoeff = max (gsgeti (sy2, GSNSAVE), ncoeff) +$else + ncoeff = max (dgsgeti (sy2, GSNSAVE), ncoeff) +$endif + call calloc (xcoeff, ncoeff, TY_PIXEL) + call calloc (ycoeff, ncoeff, TY_PIXEL) + + # Save the coefficients. +$if (datatype == r) + call gssave (sx2, Mem$t[xcoeff]) + call gssave (sy2, Mem$t[ycoeff]) +$else + call dgssave (sx2, Mem$t[xcoeff]) + call dgssave (sy2, Mem$t[ycoeff]) +$endif + + # Output the coefficients. + call dtput (out, "\tsurface2\t%d\n") + call pargi (ncoeff) + do i = 1, ncoeff { + call dtput (out, "\t\t\t%g\t%g\n") + call parg$t (Mem$t[xcoeff+i-1]) + call parg$t (Mem$t[ycoeff+i-1]) + } + + # Cleanup. + call mfree (xcoeff, TY_PIXEL) + call mfree (ycoeff, TY_PIXEL) + call sfree (sp) +end + + +# GEO_PLIST -- Print the input, output, and fitted data and the residuals. + +procedure geo_plist$t (fd, fit, xref, yref, xin, yin, xfit, yfit, wts, npts) + +int fd #I the results file descriptor +pointer fit #I pointer to the fit structure +PIXEL xref[ARB] #I the input x coordinates +PIXEL yref[ARB] #I the input y coordinates +PIXEL xin[ARB] #I the input ra / longitude coordinates +PIXEL yin[ARB] #I the input dec / latitude coordinates +PIXEL xfit[ARB] #I the fitted ra / longitude coordinates +PIXEL yfit[ARB] #I the fitted dec / latitude coordinates +PIXEL wts[ARB] #I the weights array +int npts #I the number of data points + +int i, index +pointer sp, fmtstr, twts + +begin + # Allocate working space. + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (twts, npts, TY_PIXEL) + + # Compute the weights. + call amov$t (wts, Mem$t[twts], npts) + do i = 1, GM_NREJECT(fit) { + index = Memi[GM_REJ(fit)+i-1] + if (wts[index] > PIXEL(0.0)) + Mem$t[twts+index-1] = PIXEL(0.0) + } + + # Print banner. + call fprintf (fd, "\n# Input Coordinate Listing\n") + call fprintf (fd, "# Column 1: X (reference) \n") + call fprintf (fd, "# Column 2: Y (reference)\n") + call fprintf (fd, "# Column 3: X (input)\n") + call fprintf (fd, "# Column 4: Y (input)\n") + call fprintf (fd, "# Column 5: X (fit)\n") + call fprintf (fd, "# Column 6: Y (fit)\n") + call fprintf (fd, "# Column 7: X (residual)\n") + call fprintf (fd, "# Column 8: Y (residual)\n\n") + + # Create the format string. + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s %s %s %s %s\n") +$if (datatype == r) + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") +$else + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") +$endif + + # Print the data. + do i = 1, npts { + call fprintf (fd, Memc[fmtstr]) + call parg$t (xref[i]) + call parg$t (yref[i]) + call parg$t (xin[i]) + call parg$t (yin[i]) + if (Mem$t[twts+i-1] > 0.0d0) { + call parg$t (xfit[i]) + call parg$t (yfit[i]) + call parg$t (xin[i] - xfit[i]) + call parg$t (yin[i] - yfit[i]) + } else { + call parg$t (INDEF) + call parg$t (INDEF) + call parg$t (INDEF) + call parg$t (INDEF) + } + + } + + call fprintf (fd, "\n") + + call sfree (sp) + +end + +# GEO_SHOW -- Print the coordinate mapping parameters. + +procedure geo_show$t (fd, fit, sx1, sy1, comment) + +int fd #I the output file descriptor +pointer fit #I pointer to the fit structure +pointer sx1, sy1 #I pointer to linear surfaces +int comment #I comment the output ? + +PIXEL xshift, yshift, a, b, c, d +PIXEL xscale, yscale, xrot, yrot +pointer sp, str +bool fp_equal$t() + +begin + # Allocate temporary space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Compute the geometric parameters. + call geo_gcoeff$t (sx1, sy1, xshift, yshift, a, b, c, d) + + if (comment == NO) { + call fprintf (fd, "Coordinate mapping parameters\n") + } else { + call fprintf (fd, "# Coordinate mapping parameters\n") + } + + if (comment == NO) { + call fprintf (fd, + " Mean Xref and Yref: %0.7g %0.7g\n") + call pargd (GM_XOREF(fit)) + call pargd (GM_YOREF(fit)) + call fprintf (fd, + " Mean Xin and Yin: %0.7g %0.7g\n") + call pargd (GM_XOIN(fit)) + call pargd (GM_YOIN(fit)) + call fprintf (fd, + " X and Y shift: %0.7g %0.7g (xin yin)\n") + call parg$t (xshift) + call parg$t (yshift) + } else { + call fprintf (fd, + "# Mean Xref and Yref: %0.7g %0.7g\n") + call pargd (GM_XOREF(fit)) + call pargd (GM_YOREF(fit)) + call fprintf (fd, + "# Mean Xin and Yin: %0.7g %g0.7\n") + call pargd (GM_XOIN(fit)) + call pargd (GM_YOIN(fit)) + call fprintf (fd, + "# X and Y shift: %0.7g %0.7g (xin yin)\n") + call parg$t (xshift) + call parg$t (yshift) + } + + # Output the scale factors. + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + if (comment == NO) { + call fprintf (fd, + " X and Y scale: %0.7g %0.7g (xin / xref yin / yref)\n") + call parg$t (xscale) + call parg$t (yscale) + } else { + call fprintf (fd, + "# X and Y scale: %0.7g %0.7g (xin / xref yin / yref)\n") + call parg$t (xscale) + call parg$t (yscale) + } + + # Output the rotation factors. + if (fp_equal$t (a, PIXEL(0.0)) && fp_equal$t (c, PIXEL(0.0))) + xrot = PIXEL(0.0) + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < PIXEL(0.0)) + xrot = xrot + PIXEL(360.0) + if (fp_equal$t (b, PIXEL(0.0)) && fp_equal$t (d, PIXEL(0.0))) + yrot = PIXEL(0.0) + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < PIXEL(0.0)) + yrot = yrot + PIXEL(360.0) + if (comment == NO) { + call fprintf (fd, + " X and Y axis rotation: %0.5f %0.5f (degrees degrees)\n") + call parg$t (xrot) + call parg$t (yrot) + } else { + call fprintf (fd, + "# X and Y axis rotation: %0.5f %0.5f (degrees degrees)\n") + call parg$t (xrot) + call parg$t (yrot) + } + + call sfree (sp) +end + +$endfor diff --git a/pkg/images/immatch/src/geometry/t_geomap.x b/pkg/images/immatch/src/geometry/t_geomap.x new file mode 100644 index 00000000..6f1c20f0 --- /dev/null +++ b/pkg/images/immatch/src/geometry/t_geomap.x @@ -0,0 +1,1509 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <fset.h> +include <error.h> +include <mach.h> +include <math.h> +include <math/gsurfit.h> +include "../../../lib/geomap.h" + +define GM_REAL 1 # computation type is real +define GM_DOUBLE 2 # computation type is double + + + +# T_GEOMAP -- Procedure to calculate the transformation required to transform +# the coordinate system of a reference image to the coordinate system of +# an input image. The transformation is of the following form. +# +# xin = f (xref, yref) +# yin = g (xref, yref) + +procedure t_geomap () + +bool verbose, interactive +double xmin, xmax, ymin, ymax, reject +int geometry, function, calctype, nfiles, list, in, reclist, nrecords +int xxorder, xyorder, xxterms, yxorder, yyorder, yxterms, maxiter +int reslist, nresfiles, res +pointer sp, in_name, str, out, fit, gd, graphics +real rxmin, rxmax, rymin, rymax + +bool clgetb() +double clgetd() +int clgeti(), clgwrd(), clplen(), errget(), imtopenp(), imtlen() +int imtgetim() +pointer clpopnu(), clgfil(), dtmap(), gopen(), open() + +errchk geo_mapr(), geo_mapd() + +begin + # Get working space. + call smark (sp) + call salloc (in_name, SZ_FNAME, TY_CHAR) + call salloc (graphics, SZ_FNAME, TY_CHAR) + call salloc (str, max(SZ_LINE, SZ_FNAME), TY_CHAR) + + # Get input data file(s). + list = clpopnu ("input") + nfiles = clplen (list) + + # Open database output file. + call clgstr ("database", Memc[str], SZ_FNAME) + out = dtmap (Memc[str], APPEND) + + # Get minimum and maximum reference values. + xmin = clgetd ("xmin") + if (IS_INDEFD(xmin)) + rxmin = INDEFR + else + rxmin = xmin + xmax = clgetd ("xmax") + if (IS_INDEFD(xmax)) + rxmax = INDEFR + else + rxmax = xmax + ymin = clgetd ("ymin") + if (IS_INDEFD(ymin)) + rymin = INDEFR + else + rymin = ymin + ymax = clgetd ("ymax") + if (IS_INDEFD(ymax)) + rymax = INDEFR + else + rymax = ymax + + # Get the records list. + reclist = imtopenp ("transforms") + nrecords = imtlen (reclist) + if ((nrecords > 0) && (nrecords != nfiles)) { + call eprintf ( + "The number of records is not equal to the number of input files") + call clpcls (list) + call dtunmap (out) + call imtclose (reclist) + call sfree (sp) + return + } + + # Get the results file list. + reslist = clpopnu ("results") + nresfiles = clplen (reslist) + if (nresfiles > 1 && nresfiles != nfiles) { + call eprintf ("Error: there are too few results files\n") + call clpcls (list) + call dtunmap (out) + call imtclose (reclist) + call clpcls (reslist) + call sfree (sp) + return + } + + # Get the surface fitting parameters. + geometry = clgwrd ("fitgeometry", Memc[str], SZ_LINE, GM_GEOMETRIES) + function = clgwrd ("function", Memc[str], SZ_LINE, GM_FUNCS) + xxorder = clgeti ("xxorder") + xyorder = clgeti ("xyorder") + xxterms = clgwrd ("xxterms", Memc[str], SZ_LINE, GM_XFUNCS) - 1 + yxorder = clgeti ("yxorder") + yyorder = clgeti ("yyorder") + yxterms = clgwrd ("yxterms", Memc[str], SZ_LINE, GM_XFUNCS) - 1 + maxiter = clgeti ("maxiter") + reject = clgetd ("reject") + calctype = clgwrd ("calctype", Memc[str], SZ_LINE, ",real,double,") + + # Get the graphics parameters. + verbose = clgetb ("verbose") + interactive = clgetb ("interactive") + call clgstr ("graphics", Memc[graphics], SZ_FNAME) + + # Flush standard output on newline. + call fseti (STDOUT, F_FLUSHNL, YES) + + # Initialize the fit structure. + call geo_minit (fit, GM_NONE, geometry, function, xxorder, xyorder, + xxterms, yxorder, yyorder, yxterms, maxiter, reject) + + # Loop over the files. + while (clgfil (list, Memc[in_name], SZ_FNAME) != EOF) { + + # Open text file of coordinates. + in = open (Memc[in_name], READ_ONLY, TEXT_FILE) + + # Open the results files. + if (nresfiles <= 0) + res = NULL + else if (clgfil (reslist, Memc[str], SZ_FNAME) != EOF) + res = open (Memc[str], NEW_FILE, TEXT_FILE) + + # Set file name in structure. + if (nrecords > 0) { + if (imtgetim (reclist, GM_RECORD(fit), SZ_FNAME) != EOF) + ; + } else + call strcpy (Memc[in_name], GM_RECORD(fit), SZ_FNAME) + + if (verbose && res != STDOUT) { + call fstats (in, F_FILENAME, Memc[str], SZ_FNAME) + call printf ("\nCoordinate list: %s Transform: %s\n") + call pargstr (Memc[str]) + call pargstr (GM_RECORD(fit)) + if (res != NULL) + call fstats (res, F_FILENAME, Memc[str], SZ_FNAME) + else + call strcpy ("", Memc[str], SZ_FNAME) + call printf (" Results file: %s\n") + call pargstr (Memc[str]) + call flush (STDOUT) + } + if (res != NULL) { + call fstats (in, F_FILENAME, Memc[str], SZ_FNAME) + call fprintf (res, "\n# Coordinate list: %s Transform: %s\n") + call pargstr (Memc[str]) + call pargstr (GM_RECORD(fit)) + if (res != NULL) + call fstats (res, F_FILENAME, Memc[str], SZ_FNAME) + else + call strcpy ("", Memc[str], SZ_FNAME) + call fprintf (res, "# Results file: %s\n") + call pargstr (Memc[str]) + call flush (STDOUT) + } + + if (interactive) { + gd = gopen (Memc[graphics], NEW_FILE, STDGRAPH) + } else + gd = NULL + + iferr { + if (calctype == GM_REAL) + call geo_mapr (gd, in, out, res, fit, rxmin, rxmax, rymin, + rymax, verbose) + else + call geo_mapd (gd, in, out, res, fit, xmin, xmax, ymin, + ymax, verbose) + } then { + if (verbose && res != STDOUT) { + call printf ("Error fitting coordinate list: %s\n") + call pargstr (Memc[in_name]) + call flush (STDOUT) + if (errget (Memc[str], SZ_LINE) == 0) + ; + call printf ("\t%s\n") + call pargstr (Memc[str)) + } + if (res != NULL) { + call fprintf (res, "# Error fitting coordinate list: %s\n") + call pargstr (Memc[in_name]) + call flush (STDOUT) + if (errget (Memc[str], SZ_LINE) == 0) + ; + call fprintf (res, "# %s\n") + call pargstr (Memc[str)) + } + } + + call close (in) + if (nresfiles == nfiles) + call close ( res) + + if (gd != NULL) + call gclose (gd) + } + + # Close up. + call geo_free (fit) + if (nresfiles < nfiles) + call close ( res) + call dtunmap (out) + call imtclose (reclist) + call clpcls (list) + call sfree (sp) +end + + + + + +# GEO_MAP -- Procedure to calculate the coordinate transformations + +procedure geo_mapr (gd, in, out, res, fit, xmin, xmax, ymin, ymax, verbose) + +pointer gd #I the graphics stream +int in #I the input file descriptor +pointer out #I the output file descriptor +int res #I the results file descriptor +pointer fit #I pointer to fit parameters +real xmin, xmax #I max and min xref values +real ymin, ymax #I max and min yref values +bool verbose #I verbose mode + +int npts, ngood +pointer sp, str, xref, yref, xin, yin, wts, xfit, yfit, xerrmsg, yerrmsg +pointer sx1, sy1, sx2, sy2 +real mintemp, maxtemp + +real asumr() +int geo_rdxyr() +errchk geo_fitr, geo_mgfitr() + +begin + # Get working space. + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (xerrmsg, SZ_LINE, TY_CHAR) + call salloc (yerrmsg, SZ_LINE, TY_CHAR) + + # Initialize pointers. + xref = NULL + yref = NULL + xin = NULL + yin = NULL + wts = NULL + + # Read in data and check that data is in range. + npts = geo_rdxyr (in, xref, yref, xin, yin, xmin, xmax, ymin, ymax) + if (npts <= 0) { + call fstats (in, F_FILENAME, Memc[str], SZ_FNAME) + call printf ("Coordinate list: %s has no data in range.\n") + call pargstr (Memc[str]) + call sfree (sp) + return + } + + # Compute the mean of the reference and input coordinates. + GM_XOREF(fit) = double (asumr (Memr[xref], npts) / npts) + GM_YOREF(fit) = double (asumr (Memr[yref], npts) / npts) + GM_XOIN(fit) = double (asumr (Memr[xin], npts) / npts) + GM_YOIN(fit) = double (asumr (Memr[yin], npts) / npts) + + # Set the reference point for the projections to INDEF. + GM_XREFPT(fit) = INDEFD + GM_YREFPT(fit) = INDEFD + + # Compute the weights. + call malloc (xfit, npts, TY_REAL) + call malloc (yfit, npts, TY_REAL) + call malloc (wts, npts, TY_REAL) + call amovkr (real(1.), Memr[wts], npts) + + # Determine the x max and min. + if (IS_INDEFR(xmin) || IS_INDEFR(xmax)) { + call alimr (Memr[xref], npts, mintemp, maxtemp) + if (! IS_INDEFR(xmin)) + GM_XMIN(fit) = double (xmin) + else + GM_XMIN(fit) = double (mintemp) + if (! IS_INDEFR(xmax)) + GM_XMAX(fit) = double (xmax) + else + GM_XMAX(fit) = double (maxtemp) + } else { + GM_XMIN(fit) = double (xmin) + GM_XMAX(fit) = double (xmax) + } + + # Determine the y max and min. + if (IS_INDEFR(ymin) || IS_INDEFR(ymax)) { + call alimr (Memr[yref], npts, mintemp, maxtemp) + if (! IS_INDEFR(ymin)) + GM_YMIN(fit) = double (ymin) + else + GM_YMIN(fit) = double (mintemp) + if (! IS_INDEFR(ymax)) + GM_YMAX(fit) = double (ymax) + else + GM_YMAX(fit) = double (maxtemp) + } else { + GM_YMIN(fit) = double (ymin) + GM_YMAX(fit) = double (ymax) + } + + # Initalize surface pointers. + sx1 = NULL + sy1 = NULL + sx2 = NULL + sy2 = NULL + + # Fit the data. + if (gd != NULL) { + iferr { + call geo_mgfitr (gd, fit, sx1, sy1, sx2, sy2, Memr[xref], + Memr[yref], Memr[xin], Memr[yin], Memr[wts], npts, + Memc[xerrmsg], Memc[yerrmsg], SZ_LINE) + } then { + call gdeactivate (gd, 0) + call mfree (xfit, TY_REAL) + call mfree (yfit, TY_REAL) + call mfree (wts, TY_REAL) + call geo_mmfreer (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few points for X or Y fits.") + } + call gdeactivate (gd, 0) + if (verbose && res != STDOUT) { + call printf ("Coordinate mapping status\n") + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "# Coordinate mapping status\n") + } + } else { + if (verbose && res != STDOUT) { + call printf ("Coordinate mapping status\n ") + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "# Coordinate mapping status\n# ") + } + iferr { + call geo_fitr (fit, sx1, sy1, sx2, sy2, Memr[xref], + Memr[yref], Memr[xin], Memr[yin], Memr[wts], npts, + Memc[xerrmsg], Memc[yerrmsg], SZ_LINE) + } then { + call mfree (xfit, TY_REAL) + call mfree (yfit, TY_REAL) + call mfree (wts, TY_REAL) + call geo_mmfreer (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few points for X or Y fits.") + } + if (verbose && res != STDOUT) { + call printf ("%s %s\n") + call pargstr (Memc[xerrmsg]) + call pargstr (Memc[yerrmsg]) + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "%s %s\n") + call pargstr (Memc[xerrmsg]) + call pargstr (Memc[yerrmsg]) + call flush (STDOUT) + } + } + ngood = GM_NPTS(fit) - GM_NWTS0(fit) + if (verbose && res != STDOUT) { + call printf (" Xin and Yin fit rms: %0.7g %0.7g\n") + if (ngood <= 1) { + call pargd (0.0d0) + call pargd (0.0d0) + } else { + call pargd (sqrt (GM_XRMS(fit) / (ngood - 1))) + call pargd (sqrt (GM_YRMS(fit) / (ngood - 1))) + } + call geo_showr (STDOUT, fit, sx1, sy1, NO) + } + if (res != NULL) { + call fprintf (res, "# Xin and Yin fit rms: %0.7g %0.7g\n") + if (ngood <= 1) { + call pargd (0.0) + call pargd (0.0) + } else { + call pargd (sqrt (GM_XRMS(fit) / (ngood - 1))) + call pargd (sqrt (GM_YRMS(fit) / (ngood - 1))) + } + call geo_showr (res, fit, sx1, sy1, YES) + } + + # Compute and print the fitted x and y values. + if (res != NULL) { + call geo_evalr (sx1, sy1, sx2, sy2, Memr[xref], Memr[yref], + Memr[xfit], Memr[yfit], npts) + call geo_plistr (res, fit, Memr[xref], Memr[yref], Memr[xin], + Memr[yin], Memr[xfit], Memr[yfit], Memr[wts], npts) + } + + # Free the data + if (xref != NULL) + call mfree (xref, TY_REAL) + if (yref != NULL) + call mfree (yref, TY_REAL) + if (xin != NULL) + call mfree (xin, TY_REAL) + if (yin != NULL) + call mfree (yin, TY_REAL) + if (xfit != NULL) + call mfree (xfit, TY_REAL) + if (yfit != NULL) + call mfree (yfit, TY_REAL) + if (wts != NULL) + call mfree (wts, TY_REAL) + + # Output the data. + call geo_moutr (fit, out, sx1, sy1, sx2, sy2) + + # Free the space and close files. + call geo_mmfreer (sx1, sy1, sx2, sy2) + call sfree (sp) +end + + +define GEO_DEFBUFSIZE 1000 # default data buffer sizes + +# GEO_RDXY -- Read in the data points. + +int procedure geo_rdxyr (fd, xref, yref, xin, yin, xmin, xmax, ymin, ymax) + +int fd # the input file descriptor +pointer xref # the x reference coordinates +pointer yref # the y reference coordinates +pointer xin # the x coordinates +pointer yin # the y coordinates +real xmin, xmax # the range of the x coordinates +real ymin, ymax # the range of the y coordinates + +int npts, bufsize +int fscan(), nscan() + +begin + bufsize = GEO_DEFBUFSIZE + call malloc (xref, bufsize, TY_REAL) + call malloc (yref, bufsize, TY_REAL) + call malloc (xin, bufsize, TY_REAL) + call malloc (yin, bufsize, TY_REAL) + + npts = 0 + while (fscan (fd) != EOF) { + + # Decode the data. + call gargr (Memr[xref+npts]) + call gargr (Memr[yref+npts]) + call gargr (Memr[xin+npts]) + call gargr (Memr[yin+npts]) + if (nscan() < 4) + next + + # Check the data limits. + if (! IS_INDEFR(xmin)) { + if (Memr[xref+npts] < xmin) + next + } + if (! IS_INDEFR(xmax)) { + if (Memr[xref+npts] > xmax) + next + } + if (! IS_INDEFR(ymin)) { + if (Memr[yref+npts] < ymin) + next + } + if (! IS_INDEFR(ymax)) { + if (Memr[yref+npts] > ymax) + next + } + + npts = npts + 1 + if (npts >= bufsize) { + bufsize = bufsize + GEO_DEFBUFSIZE + call realloc (xref, bufsize, TY_REAL) + call realloc (yref, bufsize, TY_REAL) + call realloc (xin, bufsize, TY_REAL) + call realloc (yin, bufsize, TY_REAL) + } + } + + if (npts <= 0) { + call mfree (xref, TY_REAL) + call mfree (yref, TY_REAL) + call mfree (xin, TY_REAL) + call mfree (yin, TY_REAL) + xref = NULL + yref = NULL + xin = NULL + yin = NULL + } else if (npts < bufsize) { + call realloc (xref, npts, TY_REAL) + call realloc (yref, npts, TY_REAL) + call realloc (xin, npts, TY_REAL) + call realloc (yin, npts, TY_REAL) + } + + return (npts) +end + + +# GEO_EVAL -- Evalute the fit. + +procedure geo_evalr (sx1, sy1, sx2, sy2, xref, yref, xi, eta, npts) + +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to higher order surfaces +real xref[ARB] #I the x reference coordinates +real yref[ARB] #I the y reference coordinates +real xi[ARB] #O the fitted xi coordinates +real eta[ARB] #O the fitted eta coordinates +int npts #I the number of points + +pointer sp, temp + +begin + call smark (sp) + call salloc (temp, npts, TY_REAL) + + call gsvector (sx1, xref, yref, xi, npts) + if (sx2 != NULL) { + call gsvector (sx2, xref, yref, Memr[temp], npts) + call aaddr (Memr[temp], xi, xi, npts) + } + call gsvector (sy1, xref, yref, eta, npts) + if (sy2 != NULL) { + call gsvector (sy2, xref, yref, Memr[temp], npts) + + call aaddr (Memr[temp], eta, eta, npts) + } + + call sfree (sp) +end + + +# GEO_MOUT -- Write the output database file. + +procedure geo_moutr (fit, out, sx1, sy1, sx2, sy2) + +pointer fit #I pointer to fitting structure +int out #I pointer to database file +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to distortion surfaces + +int i, npts, ncoeff +pointer sp, str, xcoeff, ycoeff +real xrms, yrms, xshift, yshift, xscale, yscale, xrot, yrot +int gsgeti() +int rg_wrdstr() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Compute the x and y fit rms. + #npts = max (0, GM_NPTS(fit) - GM_NREJECT(fit) - GM_NWTS0(fit)) + npts = max (0, GM_NPTS(fit) - GM_NWTS0(fit)) + xrms = max (0.0d0, GM_XRMS(fit)) + yrms = max (0.0d0, GM_YRMS(fit)) + if (npts > 1) { + xrms = sqrt (xrms / (npts - 1)) + yrms = sqrt (yrms / (npts - 1)) + } else { + xrms = 0.0d0 + yrms = 0.0d0 + } + + # Print title. + call dtptime (out) + call dtput (out, "begin\t%s\n") + call pargstr (GM_RECORD(fit)) + + # Print the x and y mean values. + call dtput (out, "\txrefmean\t%g\n") + call pargd (GM_XOREF(fit)) + call dtput (out, "\tyrefmean\t%g\n") + call pargd (GM_YOREF(fit)) + call dtput (out, "\txmean\t\t%g\n") + call pargd (GM_XOIN(fit)) + call dtput (out, "\tymean\t\t%g\n") + call pargd (GM_YOIN(fit)) + + # Print some of the fitting parameters. + if (rg_wrdstr (GM_FIT(fit), Memc[str], SZ_FNAME, GM_GEOMETRIES) <= 0) + call strcpy ("general", Memc[str], SZ_FNAME) + call dtput (out, "\tgeometry\t%s\n") + call pargstr (Memc[str]) + if (rg_wrdstr (GM_FUNCTION(fit), Memc[str], SZ_FNAME, GM_FUNCS) <= 0) + call strcpy ("polynomial", Memc[str], SZ_FNAME) + call dtput (out, "\tfunction\t%s\n") + call pargstr (Memc[str]) + + # Output the geometric parameters. + call geo_lcoeffr (sx1, sy1, xshift, yshift, xscale, yscale, xrot, yrot) + call dtput (out, "\txshift\t\t%g\n") + call pargr (xshift) + call dtput (out, "\tyshift\t\t%g\n") + call pargr (yshift) + call dtput (out, "\txmag\t\t%g\n") + call pargr (xscale) + call dtput (out, "\tymag\t\t%g\n") + call pargr (yscale) + call dtput (out, "\txrotation\t%g\n") + call pargr (xrot) + call dtput (out, "\tyrotation\t%g\n") + call pargr (yrot) + + # Out the rms values. + call dtput (out, "\txrms\t\t%g\n") + call pargr (real(xrms)) + call dtput (out, "\tyrms\t\t%g\n") + call pargr (real(yrms)) + + # Allocate memory for linear coefficients. + ncoeff = max (gsgeti (sx1, GSNSAVE), gsgeti (sy1, GSNSAVE)) + call calloc (xcoeff, ncoeff, TY_REAL) + call calloc (ycoeff, ncoeff, TY_REAL) + + # Output the linear coefficients. + call gssave (sx1, Memr[xcoeff]) + call gssave (sy1, Memr[ycoeff]) + call dtput (out, "\tsurface1\t%d\n") + call pargi (ncoeff) + do i = 1, ncoeff { + call dtput (out, "\t\t\t%g\t%g\n") + call pargr (Memr[xcoeff+i-1]) + call pargr (Memr[ycoeff+i-1]) + } + + call mfree (xcoeff, TY_REAL) + call mfree (ycoeff, TY_REAL) + + # Allocate memory for higer order coefficients. + if (sx2 == NULL) + ncoeff = 0 + else + ncoeff = gsgeti (sx2, GSNSAVE) + if (sy2 == NULL) + ncoeff = max (0, ncoeff) + else + ncoeff = max (gsgeti (sy2, GSNSAVE), ncoeff) + call calloc (xcoeff, ncoeff, TY_REAL) + call calloc (ycoeff, ncoeff, TY_REAL) + + # Save the coefficients. + call gssave (sx2, Memr[xcoeff]) + call gssave (sy2, Memr[ycoeff]) + + # Output the coefficients. + call dtput (out, "\tsurface2\t%d\n") + call pargi (ncoeff) + do i = 1, ncoeff { + call dtput (out, "\t\t\t%g\t%g\n") + call pargr (Memr[xcoeff+i-1]) + call pargr (Memr[ycoeff+i-1]) + } + + # Cleanup. + call mfree (xcoeff, TY_REAL) + call mfree (ycoeff, TY_REAL) + call sfree (sp) +end + + +# GEO_PLIST -- Print the input, output, and fitted data and the residuals. + +procedure geo_plistr (fd, fit, xref, yref, xin, yin, xfit, yfit, wts, npts) + +int fd #I the results file descriptor +pointer fit #I pointer to the fit structure +real xref[ARB] #I the input x coordinates +real yref[ARB] #I the input y coordinates +real xin[ARB] #I the input ra / longitude coordinates +real yin[ARB] #I the input dec / latitude coordinates +real xfit[ARB] #I the fitted ra / longitude coordinates +real yfit[ARB] #I the fitted dec / latitude coordinates +real wts[ARB] #I the weights array +int npts #I the number of data points + +int i, index +pointer sp, fmtstr, twts + +begin + # Allocate working space. + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (twts, npts, TY_REAL) + + # Compute the weights. + call amovr (wts, Memr[twts], npts) + do i = 1, GM_NREJECT(fit) { + index = Memi[GM_REJ(fit)+i-1] + if (wts[index] > real(0.0)) + Memr[twts+index-1] = real(0.0) + } + + # Print banner. + call fprintf (fd, "\n# Input Coordinate Listing\n") + call fprintf (fd, "# Column 1: X (reference) \n") + call fprintf (fd, "# Column 2: Y (reference)\n") + call fprintf (fd, "# Column 3: X (input)\n") + call fprintf (fd, "# Column 4: Y (input)\n") + call fprintf (fd, "# Column 5: X (fit)\n") + call fprintf (fd, "# Column 6: Y (fit)\n") + call fprintf (fd, "# Column 7: X (residual)\n") + call fprintf (fd, "# Column 8: Y (residual)\n\n") + + # Create the format string. + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s %s %s %s %s\n") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + + # Print the data. + do i = 1, npts { + call fprintf (fd, Memc[fmtstr]) + call pargr (xref[i]) + call pargr (yref[i]) + call pargr (xin[i]) + call pargr (yin[i]) + if (Memr[twts+i-1] > 0.0d0) { + call pargr (xfit[i]) + call pargr (yfit[i]) + call pargr (xin[i] - xfit[i]) + call pargr (yin[i] - yfit[i]) + } else { + call pargr (INDEFR) + call pargr (INDEFR) + call pargr (INDEFR) + call pargr (INDEFR) + } + + } + + call fprintf (fd, "\n") + + call sfree (sp) + +end + +# GEO_SHOW -- Print the coordinate mapping parameters. + +procedure geo_showr (fd, fit, sx1, sy1, comment) + +int fd #I the output file descriptor +pointer fit #I pointer to the fit structure +pointer sx1, sy1 #I pointer to linear surfaces +int comment #I comment the output ? + +real xshift, yshift, a, b, c, d +real xscale, yscale, xrot, yrot +pointer sp, str +bool fp_equalr() + +begin + # Allocate temporary space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Compute the geometric parameters. + call geo_gcoeffr (sx1, sy1, xshift, yshift, a, b, c, d) + + if (comment == NO) { + call fprintf (fd, "Coordinate mapping parameters\n") + } else { + call fprintf (fd, "# Coordinate mapping parameters\n") + } + + if (comment == NO) { + call fprintf (fd, + " Mean Xref and Yref: %0.7g %0.7g\n") + call pargd (GM_XOREF(fit)) + call pargd (GM_YOREF(fit)) + call fprintf (fd, + " Mean Xin and Yin: %0.7g %0.7g\n") + call pargd (GM_XOIN(fit)) + call pargd (GM_YOIN(fit)) + call fprintf (fd, + " X and Y shift: %0.7g %0.7g (xin yin)\n") + call pargr (xshift) + call pargr (yshift) + } else { + call fprintf (fd, + "# Mean Xref and Yref: %0.7g %0.7g\n") + call pargd (GM_XOREF(fit)) + call pargd (GM_YOREF(fit)) + call fprintf (fd, + "# Mean Xin and Yin: %0.7g %g0.7\n") + call pargd (GM_XOIN(fit)) + call pargd (GM_YOIN(fit)) + call fprintf (fd, + "# X and Y shift: %0.7g %0.7g (xin yin)\n") + call pargr (xshift) + call pargr (yshift) + } + + # Output the scale factors. + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + if (comment == NO) { + call fprintf (fd, + " X and Y scale: %0.7g %0.7g (xin / xref yin / yref)\n") + call pargr (xscale) + call pargr (yscale) + } else { + call fprintf (fd, + "# X and Y scale: %0.7g %0.7g (xin / xref yin / yref)\n") + call pargr (xscale) + call pargr (yscale) + } + + # Output the rotation factors. + if (fp_equalr (a, real(0.0)) && fp_equalr (c, real(0.0))) + xrot = real(0.0) + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < real(0.0)) + xrot = xrot + real(360.0) + if (fp_equalr (b, real(0.0)) && fp_equalr (d, real(0.0))) + yrot = real(0.0) + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < real(0.0)) + yrot = yrot + real(360.0) + if (comment == NO) { + call fprintf (fd, + " X and Y axis rotation: %0.5f %0.5f (degrees degrees)\n") + call pargr (xrot) + call pargr (yrot) + } else { + call fprintf (fd, + "# X and Y axis rotation: %0.5f %0.5f (degrees degrees)\n") + call pargr (xrot) + call pargr (yrot) + } + + call sfree (sp) +end + + + +# GEO_MAP -- Procedure to calculate the coordinate transformations + +procedure geo_mapd (gd, in, out, res, fit, xmin, xmax, ymin, ymax, verbose) + +pointer gd #I the graphics stream +int in #I the input file descriptor +pointer out #I the output file descriptor +int res #I the results file descriptor +pointer fit #I pointer to fit parameters +double xmin, xmax #I max and min xref values +double ymin, ymax #I max and min yref values +bool verbose #I verbose mode + +int npts, ngood +pointer sp, str, xref, yref, xin, yin, wts, xfit, yfit, xerrmsg, yerrmsg +pointer sx1, sy1, sx2, sy2 +double mintemp, maxtemp + +double asumd() +int geo_rdxyd() +errchk geo_fitd, geo_mgfitd() + +begin + # Get working space. + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (xerrmsg, SZ_LINE, TY_CHAR) + call salloc (yerrmsg, SZ_LINE, TY_CHAR) + + # Initialize pointers. + xref = NULL + yref = NULL + xin = NULL + yin = NULL + wts = NULL + + # Read in data and check that data is in range. + npts = geo_rdxyd (in, xref, yref, xin, yin, xmin, xmax, ymin, ymax) + if (npts <= 0) { + call fstats (in, F_FILENAME, Memc[str], SZ_FNAME) + call printf ("Coordinate list: %s has no data in range.\n") + call pargstr (Memc[str]) + call sfree (sp) + return + } + + # Compute the mean of the reference and input coordinates. + GM_XOREF(fit) = double (asumd (Memd[xref], npts) / npts) + GM_YOREF(fit) = double (asumd (Memd[yref], npts) / npts) + GM_XOIN(fit) = double (asumd (Memd[xin], npts) / npts) + GM_YOIN(fit) = double (asumd (Memd[yin], npts) / npts) + + # Set the reference point for the projections to INDEF. + GM_XREFPT(fit) = INDEFD + GM_YREFPT(fit) = INDEFD + + # Compute the weights. + call malloc (xfit, npts, TY_DOUBLE) + call malloc (yfit, npts, TY_DOUBLE) + call malloc (wts, npts, TY_DOUBLE) + call amovkd (double(1.), Memd[wts], npts) + + # Determine the x max and min. + if (IS_INDEFD(xmin) || IS_INDEFD(xmax)) { + call alimd (Memd[xref], npts, mintemp, maxtemp) + if (! IS_INDEFD(xmin)) + GM_XMIN(fit) = double (xmin) + else + GM_XMIN(fit) = double (mintemp) + if (! IS_INDEFD(xmax)) + GM_XMAX(fit) = double (xmax) + else + GM_XMAX(fit) = double (maxtemp) + } else { + GM_XMIN(fit) = double (xmin) + GM_XMAX(fit) = double (xmax) + } + + # Determine the y max and min. + if (IS_INDEFD(ymin) || IS_INDEFD(ymax)) { + call alimd (Memd[yref], npts, mintemp, maxtemp) + if (! IS_INDEFD(ymin)) + GM_YMIN(fit) = double (ymin) + else + GM_YMIN(fit) = double (mintemp) + if (! IS_INDEFD(ymax)) + GM_YMAX(fit) = double (ymax) + else + GM_YMAX(fit) = double (maxtemp) + } else { + GM_YMIN(fit) = double (ymin) + GM_YMAX(fit) = double (ymax) + } + + # Initalize surface pointers. + sx1 = NULL + sy1 = NULL + sx2 = NULL + sy2 = NULL + + # Fit the data. + if (gd != NULL) { + iferr { + call geo_mgfitd (gd, fit, sx1, sy1, sx2, sy2, Memd[xref], + Memd[yref], Memd[xin], Memd[yin], Memd[wts], npts, + Memc[xerrmsg], Memc[yerrmsg], SZ_LINE) + } then { + call gdeactivate (gd, 0) + call mfree (xfit, TY_DOUBLE) + call mfree (yfit, TY_DOUBLE) + call mfree (wts, TY_DOUBLE) + call geo_mmfreed (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few points for X or Y fits.") + } + call gdeactivate (gd, 0) + if (verbose && res != STDOUT) { + call printf ("Coordinate mapping status\n") + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "# Coordinate mapping status\n") + } + } else { + if (verbose && res != STDOUT) { + call printf ("Coordinate mapping status\n ") + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "# Coordinate mapping status\n# ") + } + iferr { + call geo_fitd (fit, sx1, sy1, sx2, sy2, Memd[xref], + Memd[yref], Memd[xin], Memd[yin], Memd[wts], npts, + Memc[xerrmsg], Memc[yerrmsg], SZ_LINE) + } then { + call mfree (xfit, TY_DOUBLE) + call mfree (yfit, TY_DOUBLE) + call mfree (wts, TY_DOUBLE) + call geo_mmfreed (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few points for X or Y fits.") + } + if (verbose && res != STDOUT) { + call printf ("%s %s\n") + call pargstr (Memc[xerrmsg]) + call pargstr (Memc[yerrmsg]) + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "%s %s\n") + call pargstr (Memc[xerrmsg]) + call pargstr (Memc[yerrmsg]) + call flush (STDOUT) + } + } + ngood = GM_NPTS(fit) - GM_NWTS0(fit) + if (verbose && res != STDOUT) { + call printf (" Xin and Yin fit rms: %0.7g %0.7g\n") + if (ngood <= 1) { + call pargd (0.0d0) + call pargd (0.0d0) + } else { + call pargd (sqrt (GM_XRMS(fit) / (ngood - 1))) + call pargd (sqrt (GM_YRMS(fit) / (ngood - 1))) + } + call geo_showd (STDOUT, fit, sx1, sy1, NO) + } + if (res != NULL) { + call fprintf (res, "# Xin and Yin fit rms: %0.7g %0.7g\n") + if (ngood <= 1) { + call pargd (0.0) + call pargd (0.0) + } else { + call pargd (sqrt (GM_XRMS(fit) / (ngood - 1))) + call pargd (sqrt (GM_YRMS(fit) / (ngood - 1))) + } + call geo_showd (res, fit, sx1, sy1, YES) + } + + # Compute and print the fitted x and y values. + if (res != NULL) { + call geo_evald (sx1, sy1, sx2, sy2, Memd[xref], Memd[yref], + Memd[xfit], Memd[yfit], npts) + call geo_plistd (res, fit, Memd[xref], Memd[yref], Memd[xin], + Memd[yin], Memd[xfit], Memd[yfit], Memd[wts], npts) + } + + # Free the data + if (xref != NULL) + call mfree (xref, TY_DOUBLE) + if (yref != NULL) + call mfree (yref, TY_DOUBLE) + if (xin != NULL) + call mfree (xin, TY_DOUBLE) + if (yin != NULL) + call mfree (yin, TY_DOUBLE) + if (xfit != NULL) + call mfree (xfit, TY_DOUBLE) + if (yfit != NULL) + call mfree (yfit, TY_DOUBLE) + if (wts != NULL) + call mfree (wts, TY_DOUBLE) + + # Output the data. + call geo_moutd (fit, out, sx1, sy1, sx2, sy2) + + # Free the space and close files. + call geo_mmfreed (sx1, sy1, sx2, sy2) + call sfree (sp) +end + + +define GEO_DEFBUFSIZE 1000 # default data buffer sizes + +# GEO_RDXY -- Read in the data points. + +int procedure geo_rdxyd (fd, xref, yref, xin, yin, xmin, xmax, ymin, ymax) + +int fd # the input file descriptor +pointer xref # the x reference coordinates +pointer yref # the y reference coordinates +pointer xin # the x coordinates +pointer yin # the y coordinates +double xmin, xmax # the range of the x coordinates +double ymin, ymax # the range of the y coordinates + +int npts, bufsize +int fscan(), nscan() + +begin + bufsize = GEO_DEFBUFSIZE + call malloc (xref, bufsize, TY_DOUBLE) + call malloc (yref, bufsize, TY_DOUBLE) + call malloc (xin, bufsize, TY_DOUBLE) + call malloc (yin, bufsize, TY_DOUBLE) + + npts = 0 + while (fscan (fd) != EOF) { + + # Decode the data. + call gargd (Memd[xref+npts]) + call gargd (Memd[yref+npts]) + call gargd (Memd[xin+npts]) + call gargd (Memd[yin+npts]) + if (nscan() < 4) + next + + # Check the data limits. + if (! IS_INDEFD(xmin)) { + if (Memd[xref+npts] < xmin) + next + } + if (! IS_INDEFD(xmax)) { + if (Memd[xref+npts] > xmax) + next + } + if (! IS_INDEFD(ymin)) { + if (Memd[yref+npts] < ymin) + next + } + if (! IS_INDEFD(ymax)) { + if (Memd[yref+npts] > ymax) + next + } + + npts = npts + 1 + if (npts >= bufsize) { + bufsize = bufsize + GEO_DEFBUFSIZE + call realloc (xref, bufsize, TY_DOUBLE) + call realloc (yref, bufsize, TY_DOUBLE) + call realloc (xin, bufsize, TY_DOUBLE) + call realloc (yin, bufsize, TY_DOUBLE) + } + } + + if (npts <= 0) { + call mfree (xref, TY_DOUBLE) + call mfree (yref, TY_DOUBLE) + call mfree (xin, TY_DOUBLE) + call mfree (yin, TY_DOUBLE) + xref = NULL + yref = NULL + xin = NULL + yin = NULL + } else if (npts < bufsize) { + call realloc (xref, npts, TY_DOUBLE) + call realloc (yref, npts, TY_DOUBLE) + call realloc (xin, npts, TY_DOUBLE) + call realloc (yin, npts, TY_DOUBLE) + } + + return (npts) +end + + +# GEO_EVAL -- Evalute the fit. + +procedure geo_evald (sx1, sy1, sx2, sy2, xref, yref, xi, eta, npts) + +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to higher order surfaces +double xref[ARB] #I the x reference coordinates +double yref[ARB] #I the y reference coordinates +double xi[ARB] #O the fitted xi coordinates +double eta[ARB] #O the fitted eta coordinates +int npts #I the number of points + +pointer sp, temp + +begin + call smark (sp) + call salloc (temp, npts, TY_DOUBLE) + + call dgsvector (sx1, xref, yref, xi, npts) + if (sx2 != NULL) { + call dgsvector (sx2, xref, yref, Memd[temp], npts) + call aaddd (Memd[temp], xi, xi, npts) + } + call dgsvector (sy1, xref, yref, eta, npts) + if (sy2 != NULL) { + call dgsvector (sy2, xref, yref, Memd[temp], npts) + + call aaddd (Memd[temp], eta, eta, npts) + } + + call sfree (sp) +end + + +# GEO_MOUT -- Write the output database file. + +procedure geo_moutd (fit, out, sx1, sy1, sx2, sy2) + +pointer fit #I pointer to fitting structure +int out #I pointer to database file +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to distortion surfaces + +int i, npts, ncoeff +pointer sp, str, xcoeff, ycoeff +double xrms, yrms, xshift, yshift, xscale, yscale, xrot, yrot +int dgsgeti() +int rg_wrdstr() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Compute the x and y fit rms. + #npts = max (0, GM_NPTS(fit) - GM_NREJECT(fit) - GM_NWTS0(fit)) + npts = max (0, GM_NPTS(fit) - GM_NWTS0(fit)) + xrms = max (0.0d0, GM_XRMS(fit)) + yrms = max (0.0d0, GM_YRMS(fit)) + if (npts > 1) { + xrms = sqrt (xrms / (npts - 1)) + yrms = sqrt (yrms / (npts - 1)) + } else { + xrms = 0.0d0 + yrms = 0.0d0 + } + + # Print title. + call dtptime (out) + call dtput (out, "begin\t%s\n") + call pargstr (GM_RECORD(fit)) + + # Print the x and y mean values. + call dtput (out, "\txrefmean\t%g\n") + call pargd (GM_XOREF(fit)) + call dtput (out, "\tyrefmean\t%g\n") + call pargd (GM_YOREF(fit)) + call dtput (out, "\txmean\t\t%g\n") + call pargd (GM_XOIN(fit)) + call dtput (out, "\tymean\t\t%g\n") + call pargd (GM_YOIN(fit)) + + # Print some of the fitting parameters. + if (rg_wrdstr (GM_FIT(fit), Memc[str], SZ_FNAME, GM_GEOMETRIES) <= 0) + call strcpy ("general", Memc[str], SZ_FNAME) + call dtput (out, "\tgeometry\t%s\n") + call pargstr (Memc[str]) + if (rg_wrdstr (GM_FUNCTION(fit), Memc[str], SZ_FNAME, GM_FUNCS) <= 0) + call strcpy ("polynomial", Memc[str], SZ_FNAME) + call dtput (out, "\tfunction\t%s\n") + call pargstr (Memc[str]) + + # Output the geometric parameters. + call geo_lcoeffd (sx1, sy1, xshift, yshift, xscale, yscale, xrot, yrot) + call dtput (out, "\txshift\t\t%g\n") + call pargd (xshift) + call dtput (out, "\tyshift\t\t%g\n") + call pargd (yshift) + call dtput (out, "\txmag\t\t%g\n") + call pargd (xscale) + call dtput (out, "\tymag\t\t%g\n") + call pargd (yscale) + call dtput (out, "\txrotation\t%g\n") + call pargd (xrot) + call dtput (out, "\tyrotation\t%g\n") + call pargd (yrot) + + # Out the rms values. + call dtput (out, "\txrms\t\t%g\n") + call pargd (double(xrms)) + call dtput (out, "\tyrms\t\t%g\n") + call pargd (double(yrms)) + + # Allocate memory for linear coefficients. + ncoeff = max (dgsgeti (sx1, GSNSAVE), dgsgeti (sy1, GSNSAVE)) + call calloc (xcoeff, ncoeff, TY_DOUBLE) + call calloc (ycoeff, ncoeff, TY_DOUBLE) + + # Output the linear coefficients. + call dgssave (sx1, Memd[xcoeff]) + call dgssave (sy1, Memd[ycoeff]) + call dtput (out, "\tsurface1\t%d\n") + call pargi (ncoeff) + do i = 1, ncoeff { + call dtput (out, "\t\t\t%g\t%g\n") + call pargd (Memd[xcoeff+i-1]) + call pargd (Memd[ycoeff+i-1]) + } + + call mfree (xcoeff, TY_DOUBLE) + call mfree (ycoeff, TY_DOUBLE) + + # Allocate memory for higer order coefficients. + if (sx2 == NULL) + ncoeff = 0 + else + ncoeff = dgsgeti (sx2, GSNSAVE) + if (sy2 == NULL) + ncoeff = max (0, ncoeff) + else + ncoeff = max (dgsgeti (sy2, GSNSAVE), ncoeff) + call calloc (xcoeff, ncoeff, TY_DOUBLE) + call calloc (ycoeff, ncoeff, TY_DOUBLE) + + # Save the coefficients. + call dgssave (sx2, Memd[xcoeff]) + call dgssave (sy2, Memd[ycoeff]) + + # Output the coefficients. + call dtput (out, "\tsurface2\t%d\n") + call pargi (ncoeff) + do i = 1, ncoeff { + call dtput (out, "\t\t\t%g\t%g\n") + call pargd (Memd[xcoeff+i-1]) + call pargd (Memd[ycoeff+i-1]) + } + + # Cleanup. + call mfree (xcoeff, TY_DOUBLE) + call mfree (ycoeff, TY_DOUBLE) + call sfree (sp) +end + + +# GEO_PLIST -- Print the input, output, and fitted data and the residuals. + +procedure geo_plistd (fd, fit, xref, yref, xin, yin, xfit, yfit, wts, npts) + +int fd #I the results file descriptor +pointer fit #I pointer to the fit structure +double xref[ARB] #I the input x coordinates +double yref[ARB] #I the input y coordinates +double xin[ARB] #I the input ra / longitude coordinates +double yin[ARB] #I the input dec / latitude coordinates +double xfit[ARB] #I the fitted ra / longitude coordinates +double yfit[ARB] #I the fitted dec / latitude coordinates +double wts[ARB] #I the weights array +int npts #I the number of data points + +int i, index +pointer sp, fmtstr, twts + +begin + # Allocate working space. + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (twts, npts, TY_DOUBLE) + + # Compute the weights. + call amovd (wts, Memd[twts], npts) + do i = 1, GM_NREJECT(fit) { + index = Memi[GM_REJ(fit)+i-1] + if (wts[index] > double(0.0)) + Memd[twts+index-1] = double(0.0) + } + + # Print banner. + call fprintf (fd, "\n# Input Coordinate Listing\n") + call fprintf (fd, "# Column 1: X (reference) \n") + call fprintf (fd, "# Column 2: Y (reference)\n") + call fprintf (fd, "# Column 3: X (input)\n") + call fprintf (fd, "# Column 4: Y (input)\n") + call fprintf (fd, "# Column 5: X (fit)\n") + call fprintf (fd, "# Column 6: Y (fit)\n") + call fprintf (fd, "# Column 7: X (residual)\n") + call fprintf (fd, "# Column 8: Y (residual)\n\n") + + # Create the format string. + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s %s %s %s %s\n") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + + # Print the data. + do i = 1, npts { + call fprintf (fd, Memc[fmtstr]) + call pargd (xref[i]) + call pargd (yref[i]) + call pargd (xin[i]) + call pargd (yin[i]) + if (Memd[twts+i-1] > 0.0d0) { + call pargd (xfit[i]) + call pargd (yfit[i]) + call pargd (xin[i] - xfit[i]) + call pargd (yin[i] - yfit[i]) + } else { + call pargd (INDEFD) + call pargd (INDEFD) + call pargd (INDEFD) + call pargd (INDEFD) + } + + } + + call fprintf (fd, "\n") + + call sfree (sp) + +end + +# GEO_SHOW -- Print the coordinate mapping parameters. + +procedure geo_showd (fd, fit, sx1, sy1, comment) + +int fd #I the output file descriptor +pointer fit #I pointer to the fit structure +pointer sx1, sy1 #I pointer to linear surfaces +int comment #I comment the output ? + +double xshift, yshift, a, b, c, d +double xscale, yscale, xrot, yrot +pointer sp, str +bool fp_equald() + +begin + # Allocate temporary space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Compute the geometric parameters. + call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) + + if (comment == NO) { + call fprintf (fd, "Coordinate mapping parameters\n") + } else { + call fprintf (fd, "# Coordinate mapping parameters\n") + } + + if (comment == NO) { + call fprintf (fd, + " Mean Xref and Yref: %0.7g %0.7g\n") + call pargd (GM_XOREF(fit)) + call pargd (GM_YOREF(fit)) + call fprintf (fd, + " Mean Xin and Yin: %0.7g %0.7g\n") + call pargd (GM_XOIN(fit)) + call pargd (GM_YOIN(fit)) + call fprintf (fd, + " X and Y shift: %0.7g %0.7g (xin yin)\n") + call pargd (xshift) + call pargd (yshift) + } else { + call fprintf (fd, + "# Mean Xref and Yref: %0.7g %0.7g\n") + call pargd (GM_XOREF(fit)) + call pargd (GM_YOREF(fit)) + call fprintf (fd, + "# Mean Xin and Yin: %0.7g %g0.7\n") + call pargd (GM_XOIN(fit)) + call pargd (GM_YOIN(fit)) + call fprintf (fd, + "# X and Y shift: %0.7g %0.7g (xin yin)\n") + call pargd (xshift) + call pargd (yshift) + } + + # Output the scale factors. + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + if (comment == NO) { + call fprintf (fd, + " X and Y scale: %0.7g %0.7g (xin / xref yin / yref)\n") + call pargd (xscale) + call pargd (yscale) + } else { + call fprintf (fd, + "# X and Y scale: %0.7g %0.7g (xin / xref yin / yref)\n") + call pargd (xscale) + call pargd (yscale) + } + + # Output the rotation factors. + if (fp_equald (a, double(0.0)) && fp_equald (c, double(0.0))) + xrot = double(0.0) + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < double(0.0)) + xrot = xrot + double(360.0) + if (fp_equald (b, double(0.0)) && fp_equald (d, double(0.0))) + yrot = double(0.0) + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < double(0.0)) + yrot = yrot + double(360.0) + if (comment == NO) { + call fprintf (fd, + " X and Y axis rotation: %0.5f %0.5f (degrees degrees)\n") + call pargd (xrot) + call pargd (yrot) + } else { + call fprintf (fd, + "# X and Y axis rotation: %0.5f %0.5f (degrees degrees)\n") + call pargd (xrot) + call pargd (yrot) + } + + call sfree (sp) +end + + diff --git a/pkg/images/immatch/src/geometry/t_geotran.x b/pkg/images/immatch/src/geometry/t_geotran.x new file mode 100644 index 00000000..5e5cd2e3 --- /dev/null +++ b/pkg/images/immatch/src/geometry/t_geotran.x @@ -0,0 +1,880 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mwset.h> +include <math.h> +include <math/gsurfit.h> +include "geotran.h" + +# T_GEOTRAN -- Geometrically transform a list of images either linearly or +# using a transformation computed by the GEOMAP task. + +procedure t_geotran () + +int ncols, nlines # output picture size +real xmin, xmax, ymin, ymax # minimum and maximum ref values +real xscale, yscale # output picture scale +real xin, yin # input picture origin +real xshift, yshift # x and y shifts +real xout, yout # output picture origin +real xmag, ymag # input picture scale +real xrotation, yrotation # rotation angle +int nxblock, nyblock # block size of image to be used + +bool verbose +int list1, list2, tflist, ndim, nc, nl, mode +pointer sp, imtlist1, imtlist2, database, transform, record +pointer image1, image2, imtemp, imroot, section, str +pointer geo, sx1, sy1, sx2, sy2, in, out, mw +real xs, ys, txshift, tyshift, txmag, tymag, txrot, tyrot +double oltv[2], nltv[2], oltm[2,2], nltm[2,2] + +bool clgetb(), envgetb(), streq() +int imtopen(), imtlen(), clgeti(), imtgetim(), clgwrd(), btoi() +pointer immap(), mw_openim() +real clgetr() +errchk immap() + +begin + # Set up the geotran structure. + call smark (sp) + call salloc (imtlist1, SZ_LINE, TY_CHAR) + call salloc (imtlist2, SZ_LINE, TY_CHAR) + call salloc (database, SZ_FNAME, TY_CHAR) + call salloc (transform, SZ_FNAME, TY_CHAR) + call salloc (record, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (imroot, SZ_FNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (geo, LEN_GEOSTRUCT, TY_STRUCT) + + # Get the input and output lists and database file. + call clgstr ("input", Memc[imtlist1], SZ_FNAME) + call clgstr ("output", Memc[imtlist2], SZ_FNAME) + call clgstr ("database", Memc[database], SZ_FNAME) + if (Memc[database] != EOS) { + call clgstr ("transforms", Memc[transform], SZ_FNAME) + tflist = imtopen (Memc[transform]) + GT_GEOMODE(geo) = clgwrd ("geometry", Memc[str], SZ_LINE, + ",junk,linear,distortion,geometric,") + } else { + tflist = NULL + GT_GEOMODE(geo) = GT_NONE + } + + # Get the output picture format parameters. + xmin = clgetr ("xmin") + xmax = clgetr ("xmax") + ymin = clgetr ("ymin") + ymax = clgetr ("ymax") + xscale = clgetr ("xscale") + yscale = clgetr ("yscale") + ncols= clgeti ("ncols") + nlines = clgeti ("nlines") + + # Get the geometric transformation parameters. + xin = clgetr ("xin") + yin = clgetr ("yin") + xshift = clgetr ("xshift") + yshift = clgetr ("yshift") + xout = clgetr ("xout") + yout = clgetr ("yout") + xmag = clgetr ("xmag") + ymag = clgetr ("ymag") + xrotation = clgetr ("xrotation") + yrotation = clgetr ("yrotation") + + # Get the interpolation parameters. + call clgstr ("interpolant", GT_INTERPSTR(geo), SZ_FNAME) + #GT_INTERPOLANT(geo) = clgwrd ("interpolant", Memc[str], SZ_LINE, + #",nearest,linear,poly3,poly5,spline3,") + GT_BOUNDARY(geo) = clgwrd ("boundary", Memc[str], SZ_LINE, + ",constant,nearest,reflect,wrap,") + GT_CONSTANT(geo) = clgetr ("constant") + GT_XSAMPLE(geo) = clgetr ("xsample") + GT_YSAMPLE(geo) = clgetr ("ysample") + GT_FLUXCONSERVE(geo) = btoi (clgetb("fluxconserve")) + + nxblock = clgeti ("nxblock") + nyblock = clgeti ("nyblock") + verbose = clgetb ("verbose") + + # Open the lists of images and check the scale lengths. + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + if (tflist != NULL) + call imtclose (tflist) + call error (0, "Input and output lists not the same length.") + } + + # Check the transform list. + if (tflist != NULL) { + if (imtlen (tflist) > 1 && imtlen (tflist) != imtlen (list1)) { + call imtclose (list1) + call imtclose (list2) + call imtclose (tflist) + call error (0, "Transform and input lists not the same length.") + } + } + + # Loop over the images. + if (verbose) { + call printf ("\n") + } + while (imtgetim (list1, Memc[image1], SZ_FNAME) != EOF && + imtgetim (list2, Memc[image2], SZ_FNAME) != EOF) { + + # Print messages. + if (verbose) { + call printf ("Transforming image %s to image %s\n") + call pargstr (Memc[image1]) + call pargstr (Memc[image2]) + call flush (STDOUT) + } + + # Open the images. + in = immap (Memc[image1], READ_ONLY, 0) + call imgimage (Memc[image1], Memc[str], SZ_FNAME) + call imgimage (Memc[image2], Memc[imroot], SZ_FNAME) + call imgsection (Memc[image2], Memc[section], SZ_FNAME) + if (streq (Memc[str], Memc[imroot])) { + call strcpy (Memc[imroot], Memc[imtemp], SZ_FNAME) + call mktemp ("tmp", Memc[image2], SZ_FNAME) + } else + call strcpy (Memc[image2], Memc[imtemp], SZ_FNAME) + ifnoerr (out = immap (Memc[image2], READ_WRITE, 0)) { + mode = READ_WRITE + nc = IM_LEN(out,1) + nl = IM_LEN(out,2) + xs = INDEF + ys = INDEF + } else if (Memc[section] != EOS) { + mode = NEW_IMAGE + out = immap (Memc[imroot], NEW_IMAGE, 0) + IM_NDIM(out) = IM_NDIM(in) + if (IS_INDEFI(ncols)) + IM_LEN(out,1) = IM_LEN(in,1) + else + IM_LEN(out,1) = ncols + if (IS_INDEFI(nlines)) + IM_LEN(out,2) = IM_LEN(in,2) + else + IM_LEN(out,2) = nlines + IM_PIXTYPE(out) = IM_PIXTYPE(in) + call geo_imzero (out, GT_CONSTANT(geo)) + call imunmap (out) + out = immap (Memc[image2], READ_WRITE, 0) + nc = IM_LEN(out,1) + nl = IM_LEN(out,2) + xs = INDEF + ys = INDEF + } else { + mode = NEW_COPY + out = immap (Memc[image2], NEW_COPY, in) + nc = ncols + nl = nlines + xs = xscale + ys = yscale + } + + # Set the geometry parameters. + call geo_set (geo, xmin, xmax, ymin, ymax, xs, ys, nc, nl, xin, + yin, xshift, yshift, xout, yout, xmag, ymag, xrotation, + yrotation) + + # Get the coordinate surfaces. + if (GT_GEOMODE(geo) == GT_NONE) { + call geo_format (in, out, geo, sx1, sy1, sx2, sy2) + if (verbose) { + call geo_lcoeffr (sx1, sy1, txshift, tyshift, txmag, + tymag, txrot, tyrot) + call printf (" xshift: %.2f yshift: %.2f ") + call pargr (txshift) + call pargr (tyshift) + call printf ("xmag: %.2f ymag: %.2f ") + call pargr (txmag) + call pargr (tymag) + call printf ("xrot: %.2f yrot: %.2f\n") + call pargr (txrot) + call pargr (tyrot) + call flush (STDOUT) + } + } else { + if (imtgetim (tflist, Memc[str], SZ_FNAME) != EOF) + call strcpy (Memc[str], Memc[record], SZ_FNAME) + call geo_dformat (in, out, geo, Memc[database], Memc[record], + sx1, sy1, sx2, sy2) + if (verbose) { + call printf (" Using transform %s in database %s\n") + call pargstr (Memc[record]) + call pargstr (Memc[database]) + call flush (STDOUT) + } + } + + # Transform the image. + if (IM_LEN(out,1) <= nxblock && IM_LEN(out,2) <= nyblock) { + if (GT_XSAMPLE(geo) > 1.0 || GT_YSAMPLE(geo) > 1.0) + call geo_simtran (in, out, geo, sx1, sy1, sx2, sy2) + else + call geo_imtran (in, out, geo, sx1, sy1, sx2, sy2) + } else { + if (GT_XSAMPLE(geo) > 1.0 || GT_YSAMPLE(geo) > 1.0) { + if (IM_NDIM(out) == 1) + call geo_stran (in, out, geo, sx1, sy1, sx2, sy2, + nxblock, 1) + else + call geo_stran (in, out, geo, sx1, sy1, sx2, sy2, + nxblock, nyblock) + } else { + if (IM_NDIM(out) == 1) + call geo_tran (in, out, geo, sx1, sy1, sx2, sy2, + nxblock, 1) + else + call geo_tran (in, out, geo, sx1, sy1, sx2, sy2, + nxblock, nyblock) + } + } + + # Update the linear part of the wcs. + if (!envgetb ("nomwcs") && mode == NEW_COPY) { + ndim = IM_NDIM(in) + mw = mw_openim (in) + call geo_gwcs (geo, sx1, sy1, oltm, oltv) + call mw_invertd (oltm, nltm, ndim) + call mw_vmuld (nltm, oltv, nltv, ndim) + call anegd (nltv, nltv, ndim) + call geo_swcs (mw, nltm, nltv, ndim) + call mw_saveim (mw, out) + call mw_close (mw) + } + + # Free the surfaces. + call gsfree (sx1) + call gsfree (sy1) + call gsfree (sx2) + call gsfree (sy2) + + # Close the images. + call imunmap (in) + call imunmap (out) + + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + + # Clean up. + call sfree (sp) + if (tflist != NULL) + call imtclose (tflist) + call imtclose (list1) + call imtclose (list2) +end + + +# GEO_IMZERO -- Create a dummy output image filled with the constant boundary +# extension value. + +procedure geo_imzero (im, constant) + +pointer im #I pointer to the input image +real constant #I the constant value to insert in the imagw + +int npix +pointer sp, v, buf +int impnls(), impnll(), impnlr(), impnld(), impnlx() + +begin + # Setup start vector for sequential reads and writes. + call smark (sp) + call salloc (v, IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[v], IM_MAXDIM) + + # Initialize the image. + npix = IM_LEN(im, 1) + switch (IM_PIXTYPE(im)) { + case TY_SHORT: + while (impnls (im, buf, Meml[v]) != EOF) + call amovks (short (constant), Mems[buf], npix) + case TY_USHORT, TY_INT, TY_LONG: + while (impnll (im, buf, Meml[v]) != EOF) + call amovkl (long (constant), Meml[buf], npix) + case TY_REAL: + while (impnlr (im, buf, Meml[v]) != EOF) + call amovkr (constant, Memr[buf], npix) + case TY_DOUBLE: + while (impnld (im, buf, Meml[v]) != EOF) + call amovkd (double (constant), Memd[buf], npix) + case TY_COMPLEX: + while (impnlx (im, buf, Meml[v]) != EOF) + call amovkx (complex (constant, 0.0), Memx[buf], npix) + default: + call error (1, "Unknown pixel datatype") + } + + call sfree (sp) +end + + +# GEO_SET -- Set the image dependent task parameters individually for each +# image. + +procedure geo_set (geo, xmin, xmax, ymin, ymax, xscale, yscale, ncols, nlines, + xin, yin, xshift, yshift, xout, yout, xmag, ymag, xrotation, yrotation) + +pointer geo #I pointer to geotran structure +real xmin, xmax #I minimum and maximum reference values +real ymin, ymax #I minimum and maximum reference values +real xscale, yscale #I output picture scale +int ncols, nlines #I output picture size +real xin, yin #I input picture pixel coordinates +real xshift, yshift #I shift of origin +real xout, yout #I corresponding output picture coords +real xmag, ymag #I input picture scale +real xrotation, yrotation #I scale angle + +begin + # Set the output picture format parameters. + GT_XMIN(geo) = xmin + GT_XMAX(geo) = xmax + GT_YMIN(geo) = ymin + GT_YMAX(geo) = ymax + GT_XSCALE(geo) = xscale + GT_YSCALE(geo) = yscale + GT_NCOLS(geo) = ncols + GT_NLINES(geo) = nlines + + # Set the transformation parameters. + GT_XIN(geo) = xin + GT_YIN(geo) = yin + GT_XSHIFT(geo) = xshift + GT_YSHIFT(geo) = yshift + GT_XOUT(geo) = xout + GT_YOUT(geo) = yout + GT_XMAG(geo) = xmag + GT_YMAG(geo) = ymag + GT_XROTATION(geo) = xrotation + GT_YROTATION(geo) = yrotation +end + + +# GEO_FORMAT -- Format the output picture when there is no database file. + +procedure geo_format (in, out, geo, sx1, sy1, sx2, sy2) + +pointer in #I pointer to the input image +pointer out #I pointer to the ouput image +pointer geo #I pointer to the geotran structure +pointer sx1, sy1 #O pointer to linear surfaces +pointer sx2, sy2 #O pointer to distortion surfaces + +real xmax, ymax + +begin + # Get the scale transformation parameters. + if (IS_INDEFR(GT_XMAG(geo))) + GT_XMAG(geo) = 1. + if (IM_NDIM(in) == 1) + GT_YMAG(geo) = 1. + else if (IS_INDEFR(GT_YMAG(geo))) + GT_YMAG(geo) = 1. + + # Get the rotate transformation parameters. + if (IM_NDIM(in) == 1) + GT_XROTATION(geo) = DEGTORAD(0.) + else if (IS_INDEFR(GT_XROTATION(geo))) + GT_XROTATION(geo) = DEGTORAD(0.) + else + GT_XROTATION(geo) = DEGTORAD(GT_XROTATION(geo)) + if (IM_NDIM(in) == 1) + GT_YROTATION(geo) = DEGTORAD(0.) + else if (IS_INDEFR(GT_YROTATION(geo))) + GT_YROTATION(geo) = DEGTORAD(0.) + else + GT_YROTATION(geo) = DEGTORAD(GT_YROTATION(geo)) + + # Automatically compute the maximum extent of the image. + if (GT_XMAX(geo) <= 0.0 || GT_YMAX(geo) <= 0.0) { + + # Compute the size of the output image. + xmax = abs (cos(GT_XROTATION(geo)) * IM_LEN(in,1) / + GT_XMAG(geo)) + abs(sin(GT_YROTATION(geo)) * IM_LEN(in,2) / + GT_YMAG(geo)) + ymax = abs (sin(GT_XROTATION(geo)) * IM_LEN(in, 1) / + GT_XMAG(geo)) + abs (cos(GT_YROTATION(geo)) * IM_LEN(in,2) / + GT_YMAG(geo)) + } + + # Set up the x reference coordinate limits. + if (IS_INDEF(GT_XMIN(geo))) + GT_XMIN(geo) = 1. + else + GT_XMIN(geo) = max (1.0, GT_XMIN(geo)) + if (IS_INDEF(GT_XMAX(geo))) + GT_XMAX(geo) = IM_LEN(in,1) + else if (GT_XMAX(geo) <= 0.0) + #GT_XMAX(geo) = int (xmax + 1.0) + GT_XMAX(geo) = xmax + + # Set up the y reference coordinate limits. + if (IS_INDEF(GT_YMIN(geo))) + GT_YMIN(geo) = 1. + else + GT_YMIN(geo) = max (1.0, GT_YMIN(geo)) + if (IS_INDEF(GT_YMAX(geo))) + GT_YMAX(geo) = IM_LEN(in, 2) + else if (GT_YMAX(geo) <= 0.0) + #GT_YMAX(geo) = int (ymax + 1.0) + GT_YMAX(geo) = ymax + + # Set the number of columns and rows. + if (IS_INDEFI(GT_NCOLS(geo))) + GT_NCOLS(geo) = IM_LEN(in, 1) + if (IM_NDIM(in) == 1) + GT_NLINES(geo) = 1 + else if (IS_INDEFI(GT_NLINES(geo))) + GT_NLINES(geo) = IM_LEN(in, 2) + + # Set scale, overiding number of columns and rows if necessary. + if (IS_INDEFR(GT_XSCALE(geo))) + GT_XSCALE(geo) = (GT_XMAX(geo) - GT_XMIN(geo)) / (GT_NCOLS(geo) - 1) + else + GT_NCOLS(geo) = (GT_XMAX(geo) - GT_XMIN(geo)) / GT_XSCALE(geo) + 1 + if (IM_NDIM(in) == 1) + GT_YSCALE(geo) = 1.0 + else if (IS_INDEFR(GT_YSCALE(geo))) + GT_YSCALE(geo) = (GT_YMAX(geo) - GT_YMIN(geo)) / + (GT_NLINES(geo) - 1) + else + GT_NLINES(geo) = (GT_YMAX(geo) - GT_YMIN(geo)) / GT_YSCALE(geo) + 1 + IM_LEN(out, 1) = GT_NCOLS(geo) + IM_LEN(out, 2) = GT_NLINES(geo) + + # Set up the surfaces, distortion surfaces are NULL. + if (IM_NDIM(in) == 1) { + call gsinit (sx1, GS_POLYNOMIAL, 2, 2, GS_XNONE, GT_XMIN(geo), + GT_XMAX(geo), 0.5, 1.5) + call gsinit (sy1, GS_POLYNOMIAL, 2, 2, GS_XNONE, GT_XMIN(geo), + GT_XMAX(geo), 0.5, 1.5) + } else { + call gsinit (sx1, GS_POLYNOMIAL, 2, 2, GS_XNONE, GT_XMIN(geo), + GT_XMAX(geo), GT_YMIN(geo), GT_YMAX(geo)) + call gsinit (sy1, GS_POLYNOMIAL, 2, 2, GS_XNONE, GT_XMIN(geo), + GT_XMAX(geo), GT_YMIN(geo), GT_YMAX(geo)) + } + sx2 = NULL + sy2 = NULL + + # Adjust rotation, x and y scale, scale angle, and flip. + call geo_rotmagr (sx1, sy1, GT_XMAG(geo), GT_YMAG(geo), + GT_XROTATION(geo), GT_YROTATION(geo)) + + # Adjust the shift. + call geo_shift (in, out, geo, sx1, sy1) +end + + +# GEO_DFORMAT -- Get the coordinate transformation from a database file. + +procedure geo_dformat (in, out, geo, database, transform, sx1, sy1, sx2, sy2) + +pointer in, out #I pointers to input and output images +pointer geo #I pointer to geotran structure +char database[ARB] #I name of database file +char transform[ARB] #I name of transform +pointer sx1, sy1 #O pointer to linear part of surface fit +pointer sx2, sy2 #O pointer to higher order surface + +int i, dt, rec, ncoeff, junk +pointer xcoeff, ycoeff, newsx1, newsy1 +int dtmap(), dtlocate(), dtgeti(), dtscan() +errchk gsrestore + +begin + # Map the database and locate the transformation record. + dt = dtmap (database, READ_ONLY) + rec = dtlocate (dt, transform) + + # Get the linear part of the fit. + ncoeff = dtgeti (dt, rec, "surface1") + call malloc (xcoeff, ncoeff, TY_REAL) + call malloc (ycoeff, ncoeff, TY_REAL) + do i = 1, ncoeff { + junk = dtscan (dt) + call gargr (Memr[xcoeff+i-1]) + call gargr (Memr[ycoeff+i-1]) + } + call gsrestore (sx1, Memr[xcoeff]) + call gsrestore (sy1, Memr[ycoeff]) + + # Set the output image format parameters. + call geo_dout (in, out, geo, sx1, sy1) + + # Adjust the linear part of the fit. + call gscopy (sx1, newsx1) + call gscopy (sy1, newsy1) + if (GT_GEOMODE(geo) == GT_DISTORT) + call geo_rotmagr (newsx1, newsy1, 1.0, 1.0, 0.0, 0.0) + else if (! IS_INDEFR(GT_XMAG(geo)) || ! IS_INDEFR(GT_YMAG(geo)) || + ! IS_INDEFR(GT_XROTATION(geo)) || ! IS_INDEFR(GT_YROTATION(geo))) + call geo_dcoeff (geo, dt, rec, newsx1, newsy1) + call geo_dshift (in, out, dt, rec, geo, newsx1, newsy1) + + # Get the higher order part of the fit. + ncoeff = dtgeti (dt, rec, "surface2") + if (ncoeff > 0 && (GT_GEOMODE(geo) == GT_GEOMETRIC || GT_GEOMODE(geo) == + GT_DISTORT)) { + + # Get the distortion coefficients. + call realloc (xcoeff, ncoeff, TY_REAL) + call realloc (ycoeff, ncoeff, TY_REAL) + do i = 1, ncoeff { + junk = dtscan(dt) + call gargr (Memr[xcoeff+i-1]) + call gargr (Memr[ycoeff+i-1]) + } + iferr { + call gsrestore (sx2, Memr[xcoeff]) + } then { + call mfree (sx2, TY_STRUCT) + sx2 = NULL + } + iferr { + call gsrestore (sy2, Memr[ycoeff]) + } then { + call mfree (sy2, TY_STRUCT) + sy2 = NULL + } + + } else { + + sx2 = NULL + sy2 = NULL + } + + # Redefine the surfaces. + call gsfree (sx1) + call gscopy (newsx1, sx1) + call gsfree (newsx1) + call gsfree (sy1) + call gscopy (newsy1, sy1) + call gsfree (newsy1) + + # Cleanup. + call mfree (xcoeff, TY_REAL) + call mfree (ycoeff, TY_REAL) + call dtunmap (dt) +end + + +# GEO_DOUT -- Set the output image format using information in the database +# file. + +procedure geo_dout (in, out, geo, sx1, sy1) + +pointer in, out #I pointers to input and output image +pointer geo #I pointer to geotran sturcture +pointer sx1, sy1 #I pointers to linear surface descriptors + +real gsgetr () + +begin + # Set the reference coordinate limits. + if (IS_INDEFR(GT_XMIN(geo))) + GT_XMIN(geo) = gsgetr (sx1, GSXMIN) + if (IS_INDEFR(GT_XMAX(geo))) + GT_XMAX(geo) = gsgetr (sx1, GSXMAX) + if (IS_INDEFR(GT_YMIN(geo))) + GT_YMIN(geo) = gsgetr (sy1, GSYMIN) + if (IS_INDEFR(GT_YMAX(geo))) + GT_YMAX(geo) = gsgetr (sy1, GSYMAX) + + # Set the number of lines and columns. + if (IS_INDEFI(GT_NCOLS(geo))) + GT_NCOLS(geo) = IM_LEN(in, 1) + if (IM_NDIM(in) == 1) + GT_NLINES(geo) = 1 + else if (IS_INDEFI(GT_NLINES(geo))) + GT_NLINES(geo) = IM_LEN(in, 2) + + # Set scale, overiding the number of columns and rows if necessary. + if (IS_INDEFR(GT_XSCALE(geo))) + GT_XSCALE(geo) = (GT_XMAX(geo) - GT_XMIN(geo)) / (GT_NCOLS(geo) - 1) + else + GT_NCOLS(geo) = abs ((GT_XMAX(geo) - GT_XMIN(geo)) / + GT_XSCALE(geo)) + 1 + if (IM_NDIM(in) == 1) + GT_YSCALE(geo) = 1.0 + else if (IS_INDEFR(GT_YSCALE(geo))) + GT_YSCALE(geo) = (GT_YMAX(geo) - GT_YMIN(geo)) / + (GT_NLINES(geo) - 1) + else + GT_NLINES(geo) = abs ((GT_YMAX(geo) - GT_YMIN(geo)) / + GT_YSCALE(geo)) + 1 + + # Set the output image size. + IM_LEN(out,1) = GT_NCOLS(geo) + IM_LEN(out,2) = GT_NLINES(geo) +end + + +# GEO_DSHIFT -- Adjust the shifts using information in the database file. + +procedure geo_dshift (in, out, dt, rec, geo, sx1, sy1) + +pointer in, out #I pointer to input and output images +pointer dt #I pointer to database +int rec #I pointer to database record +pointer geo #I pointer to geotran structure +pointer sx1, sy1 #U pointers to linear surfaces + +real gseval() + +begin + # Define the output origin. + if (IS_INDEFR(GT_XOUT(geo))) + GT_XOUT(geo) = (GT_XMAX(geo) + GT_XMIN(geo)) / 2.0 + if (IS_INDEFR(GT_YOUT(geo))) + GT_YOUT(geo) = (GT_YMAX(geo) + GT_YMIN(geo)) / 2.0 + + # Define the input image origin. + if (IS_INDEFR(GT_XIN(geo))) + GT_XIN(geo) = gseval (sx1, GT_XOUT(geo), GT_YOUT(geo)) + if (IS_INDEFR(GT_YIN(geo))) + GT_YIN(geo) = gseval (sy1, GT_XOUT(geo), GT_YOUT(geo)) + + # Define the shifts. + if (IS_INDEFR(GT_XSHIFT(geo))) + GT_XSHIFT(geo) = GT_XIN(geo) - gseval (sx1, GT_XOUT(geo), + GT_YOUT(geo)) + if (IS_INDEFR(GT_YSHIFT(geo))) + GT_YSHIFT(geo) = GT_YIN(geo) - gseval (sy1, GT_XOUT(geo), + GT_YOUT(geo)) + + # Correct the coefficients. + call geo_xyshiftr (sx1, sy1, GT_XSHIFT(geo), GT_YSHIFT(geo)) +end + + +# GEO_SHIFT -- Compute the shift. + +procedure geo_shift (in, out, geo, sx1, sy1) + +pointer in, out #I pointer to input and output images +pointer geo #I pointer to geotran structure +pointer sx1, sy1 #I pointers to linear surfaces + +real gseval() + +begin + # Determine the output origin. + if (IS_INDEFR(GT_XOUT(geo))) + GT_XOUT(geo) = (GT_XMAX(geo) + GT_XMIN(geo)) / 2.0 + if (IS_INDEFR(GT_YOUT(geo))) + GT_YOUT(geo) = (GT_YMAX(geo) + GT_YMIN(geo)) / 2.0 + + # Determine the input origin. + if (IS_INDEFR(GT_XIN(geo))) + GT_XIN(geo) = (real (IM_LEN (in, 1)) + 1.) / 2. + if (IS_INDEFR(GT_YIN(geo))) + GT_YIN(geo) = (real (IM_LEN (in, 2)) + 1.) / 2. + + # Determine the final x and y shifts. + if (! IS_INDEFR(GT_XSHIFT(geo))) + GT_XOUT(geo) = GT_XIN(geo) + GT_XSHIFT(geo) + if (! IS_INDEFR(GT_YSHIFT(geo))) + GT_YOUT(geo) = GT_YIN(geo) + GT_YSHIFT(geo) + GT_XSHIFT(geo) = GT_XIN(geo) - gseval (sx1, GT_XOUT(geo), + GT_YOUT(geo)) + GT_YSHIFT(geo) = GT_YIN(geo) - gseval (sy1, GT_XOUT(geo), + GT_YOUT(geo)) + + # Alter coefficients. + call geo_xyshiftr (sx1, sy1, GT_XSHIFT(geo), GT_YSHIFT(geo)) +end + + +# GEO_DCOEFF -- Alter the linear componets of the surface fit after the fact. + +procedure geo_dcoeff (geo, dt, rec, sx1, sy1) + +pointer geo #I pointer to geotran structure +pointer dt #I pointer to database record +int rec #I database record +pointer sx1, sy1 #U pointers to the linear surface + +real dtgetr() +errchk dtgetr() + +begin + # Get the transformation parameters. + if (IS_INDEFR(GT_XMAG(geo))) { + iferr (GT_XMAG(geo) = dtgetr (dt, rec, "xmag")) + GT_XMAG(geo) = dtgetr (dt, rec, "xscale") + } + if (IS_INDEFR(GT_YMAG(geo))) { + iferr (GT_YMAG(geo) = dtgetr (dt, rec, "ymag")) + GT_YMAG(geo) = dtgetr (dt, rec, "yscale") + } + if (IS_INDEFR(GT_XROTATION(geo))) + GT_XROTATION(geo) = DEGTORAD(dtgetr (dt, rec, "xrotation")) + else + GT_XROTATION(geo) = DEGTORAD(GT_XROTATION(geo)) + if (IS_INDEFR(GT_YROTATION(geo))) + GT_YROTATION(geo) = DEGTORAD(dtgetr (dt, rec, "yrotation")) + else + GT_YROTATION(geo) = DEGTORAD(GT_YROTATION(geo)) + + call geo_rotmagr (sx1, sy1, GT_XMAG(geo), GT_YMAG(geo), + GT_XROTATION(geo), GT_YROTATION(geo)) +end + + +# GEO_GWCS -- Compute the ltm and ltv vectors using the GEOTRAN coordinate +# surfaces. + +procedure geo_gwcs (geo, sx1, sy1, ltm, ltv) + +pointer geo # pointer to the geotran structure +pointer sx1 # pointer to the linear x coordinate surface +pointer sy1 # pointer to the linear y coordinate surface +double ltm[2,2] # rotation matrix +double ltv[2] # shift vector + +double xscale, yscale, xmin, ymin +int ncoeff +pointer sp, xcoeff, ycoeff +real xrange, yrange +int gsgeti() +real gsgetr() + +begin + # Allocate space for the coefficients. + call smark (sp) + ncoeff = max (gsgeti (sx1, GSNSAVE), gsgeti (sy1, GSNSAVE)) + call salloc (xcoeff, ncoeff, TY_REAL) + call salloc (ycoeff, ncoeff, TY_REAL) + + # Fetch the coefficients. + call gssave (sx1, Memr[xcoeff]) + call gssave (sy1, Memr[ycoeff]) + + # Denormalize the coefficients for non-polynomial functions. + xrange = gsgetr (sx1, GSXMAX) - gsgetr (sx1, GSXMIN) + yrange = gsgetr (sy1, GSYMAX) - gsgetr (sy1, GSYMIN) + if (gsgeti (sx1, GSTYPE) != GS_POLYNOMIAL) { + Memr[xcoeff+GS_SAVECOEFF+1] = Memr[xcoeff+GS_SAVECOEFF+1] * 2. / + xrange + Memr[xcoeff+GS_SAVECOEFF+2] = Memr[xcoeff+GS_SAVECOEFF+2] * 2. / + yrange + } + if (gsgeti (sy1, GSTYPE) != GS_POLYNOMIAL) { + Memr[ycoeff+GS_SAVECOEFF+1] = Memr[ycoeff+GS_SAVECOEFF+1] * 2. / + xrange + Memr[ycoeff+GS_SAVECOEFF+2] = Memr[ycoeff+GS_SAVECOEFF+2] * 2. / + yrange + } + + # Set the shift vector. + ltv[1] = Memr[xcoeff+GS_SAVECOEFF] + ltv[2] = Memr[ycoeff+GS_SAVECOEFF] + + # Set the rotation vector. + ltm[1,1] = Memr[xcoeff+GS_SAVECOEFF+1] + ltm[2,1] = Memr[xcoeff+GS_SAVECOEFF+2] + ltm[1,2] = Memr[ycoeff+GS_SAVECOEFF+1] + ltm[2,2] = Memr[ycoeff+GS_SAVECOEFF+2] + + # Get the sign of the scale vector which is always +ve. + xmin = GT_XMIN(geo) + ymin = GT_YMIN(geo) + if (GT_XMIN(geo) > GT_XMAX(geo)) + xscale = -GT_XSCALE(geo) + else + xscale = GT_XSCALE(geo) + if (GT_YMIN(geo) > GT_YMAX(geo)) + yscale = -GT_YSCALE(geo) + else + yscale = GT_YSCALE(geo) + + # Correct for reference units that are not in pixels. + ltv[1] = ltv[1] + ltm[1,1] * xmin + ltm[2,1] * ymin - ltm[1,1] * + xscale - ltm[2,1] * yscale + ltv[2] = ltv[2] + ltm[1,2] * xmin + ltm[2,2] * ymin - ltm[1,2] * + xscale - ltm[2,2] * yscale + ltm[1,1] = ltm[1,1] * xscale + ltm[2,1] = ltm[2,1] * yscale + ltm[1,2] = ltm[1,2] * xscale + ltm[2,2] = ltm[2,2] * yscale + + call sfree (sp) +end + + +define LTM Memd[ltm+(($2)-1)*pdim+($1)-1] + +# GEO_SWCS -- Update the wcs and write it to the image header. + +procedure geo_swcs (mw, gltm, gltv, ldim) + +pointer mw # the mwcs descriptor +double gltm[ldim,ldim] # the input cd matrix from geotran +double gltv[ldim] # the input shift vector from geotran +int ldim # number of logical dimensions + +int axes[IM_MAXDIM], naxes, pdim, nelem, axmap, ax1, ax2 +pointer sp, ltm, ltv_1, ltv_2 +int mw_stati() + +begin + # Convert axis bitflags to the axis lists. + if (ldim == 1) { + call mw_gaxlist (mw, 01B, axes, naxes) + if (naxes < 1) + return + } else { + call mw_gaxlist (mw, 03B, axes, naxes) + if (naxes < 2) + return + } + + # Initialize the parameters. + pdim = mw_stati (mw, MW_NDIM) + nelem = pdim * pdim + axmap = mw_stati (mw, MW_USEAXMAP) + call mw_seti (mw, MW_USEAXMAP, NO) + + # Allocate working space. + call smark (sp) + call salloc (ltm, nelem, TY_DOUBLE) + call salloc (ltv_1, pdim, TY_DOUBLE) + call salloc (ltv_2, pdim, TY_DOUBLE) + + # Initialize the vectors and matrices. + call mw_mkidmd (Memd[ltm], pdim) + call aclrd (Memd[ltv_1], pdim) + call aclrd (Memd[ltv_2], pdim) + + # Enter the linear operation. + ax1 = axes[1] + Memd[ltv_2+ax1-1] = gltv[1] + LTM(ax1,ax1) = gltm[1,1] + if (ldim == 2) { + ax2 = axes[2] + Memd[ltv_2+ax2-1] = gltv[2] + LTM(ax2,ax1) = gltm[2,1] + LTM(ax1,ax2) = gltm[1,2] + LTM(ax2,ax2) = gltm[2,2] + } + + # Perform the translation. + call mw_translated (mw, Memd[ltv_1], Memd[ltm], Memd[ltv_2], pdim) + + call sfree (sp) + call mw_seti (mw, MW_USEAXMAP, axmap) +end diff --git a/pkg/images/immatch/src/geometry/t_geoxytran.x b/pkg/images/immatch/src/geometry/t_geoxytran.x new file mode 100644 index 00000000..c99b9a0c --- /dev/null +++ b/pkg/images/immatch/src/geometry/t_geoxytran.x @@ -0,0 +1,343 @@ +include <fset.h> +include <ctype.h> +include <math/gsurfit.h> + +define MAX_FIELDS 100 # Maximum number of fields in list +define TABSIZE 8 # Spacing of tab stops + +# Define the permitted computation types +define GEO_REAL 1 # Computation type is real +define GEO_DOUBLE 2 # Computation type is double + +# T_GEOXYTRAN -- Transform a list of x and y coordinates using the geometric +# transformation operations computed by the GEOMAP task. + +procedure t_geoxytran() + +int inlist, outlist, reclist, calctype, geometry, dir, xcolumn, ycolumn +int min_sigdigits, infd, outfd +pointer sp, in_fname, out_fname, record, xformat, yformat, str, dt +pointer sx1, sy1, sx2, sy2 +int clgwrd(), clgeti(), open() +bool streq() +int fntopnb(), fntlenb(), fntgfnb(), imtopenp(), imtlen(), imtgetim() +pointer dtmap() + +begin + # Allocate memory for transformation parameters structure + call smark (sp) + call salloc (in_fname, SZ_FNAME, TY_CHAR) + call salloc (out_fname, SZ_FNAME, TY_CHAR) + call salloc (record, SZ_FNAME, TY_CHAR) + call salloc (xformat, SZ_FNAME, TY_CHAR) + call salloc (yformat, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Open the input and output file lists. + call clgstr ("input", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) + call strcpy ("STDIN", Memc[str], SZ_FNAME) + inlist = fntopnb(Memc[str], NO) + call clgstr ("output", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) + call strcpy ("STDOUT", Memc[str], SZ_FNAME) + outlist = fntopnb (Memc[str], NO) + call clgstr ("database", Memc[str], SZ_FNAME) + if (Memc[str] != EOS) { + dt = dtmap (Memc[str], READ_ONLY) + reclist = imtopenp ("transforms") + } else { + dt = NULL + reclist = NULL + } + + # Test the input and out file and record lists for validity. + if (fntlenb(inlist) <= 0) + call error (0, "The input file list is empty") + if (fntlenb(outlist) <= 0) + call error (0, "The output file list is empty") + if (fntlenb(outlist) > 1 && fntlenb(outlist) != fntlenb(inlist)) + call error (0, + "Input and output file lists are not the same length") + if (dt != NULL && reclist != NULL) { + if (imtlen (reclist) > 1 && imtlen (reclist) != fntlenb (inlist)) + call error (0, + "Input file and record lists are not the same length.") + } + + # Get geometry and transformation direction. + geometry = clgwrd ("geometry", Memc[str], SZ_LINE, + ",linear,distortion,geometric,") + dir = clgwrd ("direction", Memc[str], SZ_LINE, + ",forward,backward,") + + # Get field numbers from cl + if (dir == 1) + calctype = clgwrd ("calctype", Memc[str], SZ_LINE, + ",real,double,") + else + calctype = GEO_DOUBLE + xcolumn = clgeti ("xcolumn") + ycolumn = clgeti ("ycolumn") + call clgstr ("xformat", Memc[xformat], SZ_FNAME) + call clgstr ("yformat", Memc[yformat], SZ_FNAME) + min_sigdigits = clgeti ("min_sigdigits") + + # Get the output file name. + if (fntgfnb (outlist, Memc[out_fname], SZ_FNAME) == EOF) + call strcpy ("STDOUT", Memc[out_fname], SZ_FNAME) + outfd = open (Memc[out_fname], NEW_FILE, TEXT_FILE) + if (streq (Memc[out_fname], "STDOUT") || outfd == STDOUT) + call fseti (outfd, F_FLUSHNL, YES) + + # Get the record name. + if (reclist == NULL) + Memc[record] = EOS + else if (imtgetim (reclist, Memc[record], SZ_FNAME) == EOF) + Memc[record] = EOS + + # Call procedure to get parameters and fill structure. + sx1 = NULL; sy1 = NULL; sx2 = NULL; sy2 = NULL + call geo_init_transform (dt, Memc[record], calctype, geometry, + sx1, sy1, sx2, sy2) + + # While input list is not depleted, open file and transform list. + while (fntgfnb (inlist, Memc[in_fname], SZ_FNAME) != EOF) { + + infd = open (Memc[in_fname], READ_ONLY, TEXT_FILE) + + # Transform the coordinates. + call geo_transform_file (infd, outfd, xcolumn, ycolumn, dir, + calctype, Memc[xformat], Memc[yformat], min_sigdigits, + sx1, sy1, sx2, sy2) + + # Do not get a new output file name if there is not output + # file list or if only one output file was specified. + # Otherwise fetch the new name. + if (fntlenb(outlist) > 1) { + call close (outfd) + if (fntgfnb (outlist, Memc[out_fname], SZ_FNAME) != EOF) + outfd = open (Memc[out_fname], NEW_FILE, TEXT_FILE) + if (streq (Memc[out_fname], "STDOUT") || outfd == STDOUT) + call fseti (outfd, F_FLUSHNL, YES) + } + + call close (infd) + + # Do not reset the transformation if there is no record list + # or only one record is specified. Otherwise fetch the next + # record name. + if (reclist != NULL && imtlen (reclist) > 1) { + if (imtgetim (reclist, Memc[record], SZ_FNAME) != EOF) { + call geo_free_transform (calctype, sx1, sy1, sx2, sy2) + call geo_init_transform (dt, Memc[record], calctype, + geometry, sx1, sy1, sx2, sy2) + } + } + } + + # Free the surface descriptors. + call geo_free_transform (calctype, sx1, sy1, sx2, sy2) + + # Close up file and record templates. + if (dt != NULL) + call dtunmap (dt) + call close (outfd) + call fntclsb (inlist) + call fntclsb (outlist) + if (reclist != NULL) + call imtclose (reclist) + call sfree (sp) +end + + +# GEO_INIT_TRANSFORM -- gets parameter values relevant to the +# transformation from the cl. List entries will be transformed +# in procedure rg_transform. + +procedure geo_init_transform (dt, record, calctype, geometry, sx1, sy1, + sx2, sy2) + +pointer dt #I pointer to database file produced by geomap +char record[ARB] #I the name of the database record +int calctype #I the computation data type +int geometry #I the type of geometry to be computed +pointer sx1, sy1 #O pointers to the linear x and y surfaces +pointer sx2, sy2 #O pointers to the x and y distortion surfaces + +begin + if (dt == NULL) { + + if (calctype == GEO_REAL) + call geo_linitr (sx1, sy1, sx2, sy2) + else + call geo_linitd (sx1, sy1, sx2, sy2) + + } else { + + if (calctype == GEO_REAL) + call geo_sinitr (dt, record, geometry, sx1, sy1, + sx2, sy2) + else + call geo_sinitd (dt, record, geometry, sx1, sy1, + sx2, sy2) + } +end + + +# GEO_FREE_TRANSFORM -- Free the previously defined transformation + +procedure geo_free_transform (calctype, sx1, sy1, sx2, sy2) + +int calctype #I the computation data type +pointer sx1, sy1 #O pointers to the linear x and y surfaces +pointer sx2, sy2 #O pointers to the x and y distortion surfaces + +begin + if (calctype == GEO_REAL) + call geo_sfreer (sx1, sy1, sx2, sy2) + else + call geo_sfreed (sx1, sy1, sx2, sy2) +end + + +# GEO_TRANSFORM_FILE -- This procedure is called once for each file +# in the input list. For each line in the input file that isn't +# blank or comment, the line is transformed. Blank and comment +# lines are output unaltered. + +procedure geo_transform_file (infd, outfd, xfield, yfield, dir, calctype, + xformat, yformat, min_sigdigits, sx1, sy1, sx2, sy2) + +int infd #I the input file descriptor +int outfd #I the output file descriptor +int xfield #I the x column number +int yfield #I the y column number +int dir #I transform direction +int calctype #I the computation type +char xformat[ARB] #I output format of the x coordinate +char yformat[ARB] #I output format of the y coordinate +int min_sigdigits #I the minimum number of digits to be output +pointer sx1, sy1 #I pointers to the linear x and y surfaces +pointer sx2, sy2 #I pointers to the x and y distortion surfaces + +double xd, yd, xtd, ytd +int max_fields, nline, nfields, nchars, nsdig_x, nsdig_y, offset +real xr, yr, xtr, ytr +pointer sp, inbuf, linebuf, field_pos, outbuf, ip +int getline(), li_get_numr(), li_get_numd() + +int nsx, nsy +double der[8], xmin, xmax, ymin, ymax, tol +pointer sx[2], sy[2] +double dgsgetd() + +#double x, y, xt, yt + +begin + call smark (sp) + call salloc (inbuf, SZ_LINE, TY_CHAR) + call salloc (linebuf, SZ_LINE, TY_CHAR) + call salloc (field_pos, MAX_FIELDS, TY_INT) + call salloc (outbuf, SZ_LINE, TY_CHAR) + + max_fields = MAX_FIELDS + + # Initialize for backward transform. + if (dir == 2) { + sx[1] = sx1; sy[1] = sy1; sx[2] = sx2; sy[2] = sy2 + nsx = 2; nsy = 2 + if (sx2 == NULL) + nsx = 1 + if (sy2 == NULL) + nsy = 1 + xmin = dgsgetd (sx1, GSXMIN) + xmax = dgsgetd (sx1, GSXMAX) + ymin = dgsgetd (sx1, GSYMIN) + ymax = dgsgetd (sx1, GSYMAX) + tol = abs (xmax - xmin) / 1E10 + xd = (xmin + xmax) / 2 + yd = (ymin + ymax) / 2 + call tr_init (sx, nsx, sy, nsy, xd, yd, der) + } + + for (nline=1; getline (infd, Memc[inbuf]) != EOF; nline = nline + 1) { + for (ip=inbuf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '#') { + # Pass comment lines on to the output unchanged. + call putline (outfd, Memc[inbuf]) + next + } else if (Memc[ip] == '\n' || Memc[ip] == EOS) { + # Blank lines too. + call putline (outfd, Memc[inbuf]) + next + } + + # Expand tabs into blanks, determine field offsets. + call strdetab (Memc[inbuf], Memc[linebuf], SZ_LINE, TABSIZE) + call li_find_fields (Memc[linebuf], Memi[field_pos], max_fields, + nfields) + + if (xfield > nfields || yfield > nfields) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Not enough fields in file %s line %d\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + offset = Memi[field_pos+xfield-1] + if (calctype == GEO_REAL) + nchars = li_get_numr (Memc[linebuf+offset-1], xr, nsdig_x) + else + nchars = li_get_numd (Memc[linebuf+offset-1], xd, nsdig_x) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad x value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + offset = Memi[field_pos+yfield-1] + if (calctype == GEO_REAL) + nchars = li_get_numr (Memc[linebuf+offset-1], yr, nsdig_y) + else + nchars = li_get_numd (Memc[linebuf+offset-1], yd, nsdig_y) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad y value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + if (calctype == GEO_REAL) { + call geo_do_transformr (xr, yr, xtr, ytr, + sx1, sy1, sx2, sy2) + call li_pack_liner (Memc[linebuf], Memc[outbuf], SZ_LINE, + Memi[field_pos], nfields, xfield, yfield, xtr, ytr, + xformat, yformat, nsdig_x, nsdig_y, min_sigdigits) + + } else { + if (dir == 1) + call geo_do_transformd (xd, yd, xtd, ytd, + sx1, sy1, sx2, sy2) + else + call tr_invert (sx, nsx, sy, nsy, xd, yd, xtd, ytd, + der, xmin, xmax, ymin, ymax, tol) + call li_pack_lined (Memc[linebuf], Memc[outbuf], SZ_LINE, + Memi[field_pos], nfields, xfield, yfield, xtd, ytd, + xformat, yformat, nsdig_x, nsdig_y, min_sigdigits) + } + + call putline (outfd, Memc[outbuf]) + } + + call sfree (sp) +end + diff --git a/pkg/images/immatch/src/geometry/trinvert.x b/pkg/images/immatch/src/geometry/trinvert.x new file mode 100644 index 00000000..5f75cdc2 --- /dev/null +++ b/pkg/images/immatch/src/geometry/trinvert.x @@ -0,0 +1,163 @@ +# The code here is taken from t_transform.x in the longslit package. The +# changes are to use a sum instead of an average when multiple surfaces +# are given and not to use the xgs interface. Also the convergence +# tolerance is user specified since in this application the units might +# not be pixels. + + +define MAX_ITERATE 20 +define ERROR 0.05 +define FUDGE 0.5 + +# TR_INVERT -- Given user coordinate surfaces U(X,Y) and V(X,Y) +# (if none use one-to-one mapping and if more than one sum) +# corresponding to a given U and V and also the various partial +# derivatives. This is done using a gradient following interative +# method based on evaluating the partial derivative at each point +# and solving the linear Taylor expansions simultaneously. The last +# point sampled is used as the starting point. Thus, if the +# input U and V progress smoothly then the number of iterations +# can be small. The output is returned in x and y and in the derivative array +# DER. A point outside of the surfaces is returned as the nearest +# point at the edge of the surfaces in the DER array. + +procedure tr_invert (usf, nusf, vsf, nvsf, u, v, x, y, der, + xmin, xmax, ymin, ymax, tol) + +pointer usf[ARB], vsf[ARB] # User coordinate surfaces U(X,Y) and V(X,Y) +int nusf, nvsf # Number of surfaces for each coordinate +double u, v # Input U and V to determine X and Y +double x, y # Output X and Y +double der[8] # Last result as input, new result as output + # 1=X, 2=Y, 3=U, 4=DUDX, 5=DUDY, 6=V, + # 7=DVDX, 8=DVDY +double xmin, xmax, ymin, ymax # Limits of coordinate surfaces. +double tol # Tolerance + +int i, j, nedge +double fudge, du, dv, dx, dy, tmp[3] + +begin + # Use the last result as the starting point for the next position. + # If this is near the desired value then the interation will converge + # quickly. Allow a iteration to go off the surface twice. + # Quit when DX and DY are within tol. + + nedge = 0 + do i = 1, MAX_ITERATE { + du = u - der[3] + dv = v - der[6] + dx = (der[8] * du - der[5] * dv) / + (der[8] * der[4] - der[5] * der[7]) + dy = (dv - der[7] * dx) / der[8] + fudge = 1 - FUDGE / i + x = der[1] + fudge * dx + y = der[2] + fudge * dy + der[1] = max (xmin, min (xmax, x)) + der[2] = max (ymin, min (ymax, y)) + if ((abs (dx) < tol) && (abs (dy) < tol)) + break + + if (nusf == 0) + der[3] = der[1] + else if (nusf == 1) { + call dgsder (usf[1], der[1], der[2], der[3], 1, 0, 0) + call dgsder (usf[1], der[1], der[2], der[4], 1, 1, 0) + call dgsder (usf[1], der[1], der[2], der[5], 1, 0, 1) + } else { + call dgsder (usf[1], der[1], der[2], der[3], 1, 0, 0) + call dgsder (usf[1], der[1], der[2], der[4], 1, 1, 0) + call dgsder (usf[1], der[1], der[2], der[5], 1, 0, 1) + do j = 2, nusf { + call dgsder (usf[j], der[1], der[2], tmp[1], 1, 0, 0) + call dgsder (usf[j], der[1], der[2], tmp[2], 1, 1, 0) + call dgsder (usf[j], der[1], der[2], tmp[3], 1, 0, 1) + der[3] = der[3] + tmp[1] + der[4] = der[4] + tmp[2] + der[5] = der[5] + tmp[3] + } + } + + if (nvsf == 0) + der[6] = der[2] + else if (nvsf == 1) { + call dgsder (vsf[1], der[1], der[2], der[6], 1, 0, 0) + call dgsder (vsf[1], der[1], der[2], der[7], 1, 1, 0) + call dgsder (vsf[1], der[1], der[2], der[8], 1, 0, 1) + } else { + call dgsder (vsf[1], der[1], der[2], der[6], 1, 0, 0) + call dgsder (vsf[1], der[1], der[2], der[7], 1, 1, 0) + call dgsder (vsf[1], der[1], der[2], der[8], 1, 0, 1) + do j = 2, nvsf { + call dgsder (vsf[j], der[1], der[2], tmp[1], 1, 0, 0) + call dgsder (vsf[j], der[1], der[2], tmp[2], 1, 1, 0) + call dgsder (vsf[j], der[1], der[2], tmp[3], 1, 0, 1) + der[6] = der[6] + tmp[1] + der[7] = der[7] + tmp[2] + der[8] = der[8] + tmp[3] + } + } + } +end + + +# TR_INIT -- Since the inversion iteration always begins from the last +# point we need to initialize before the first call to TR_INVERT. + +procedure tr_init (usf, nusf, vsf, nvsf, x, y, der) + +pointer usf[ARB], vsf[ARB] # User coordinate surfaces +int nusf, nvsf # Number of surfaces for each coordinate +double x, y # Starting X and Y +double der[8] # Inversion data + +int j +double tmp[3] + +begin + der[1] = x + der[2] = y + if (nusf == 0) { + der[3] = der[1] + der[4] = 1. + der[5] = 0. + } else if (nusf == 1) { + call dgsder (usf[1], der[1], der[2], der[3], 1, 0, 0) + call dgsder (usf[1], der[1], der[2], der[4], 1, 1, 0) + call dgsder (usf[1], der[1], der[2], der[5], 1, 0, 1) + } else { + call dgsder (usf[1], der[1], der[2], der[3], 1, 0, 0) + call dgsder (usf[1], der[1], der[2], der[4], 1, 1, 0) + call dgsder (usf[1], der[1], der[2], der[5], 1, 0, 1) + do j = 2, nusf { + call dgsder (usf[j], der[1], der[2], tmp[1], 1, 0, 0) + call dgsder (usf[j], der[1], der[2], tmp[2], 1, 1, 0) + call dgsder (usf[j], der[1], der[2], tmp[3], 1, 0, 1) + der[3] = der[3] + tmp[1] + der[4] = der[4] + tmp[2] + der[5] = der[5] + tmp[3] + } + } + + if (nvsf == 0) { + der[6] = der[2] + der[7] = 0. + der[8] = 1. + } else if (nvsf == 1) { + call dgsder (vsf[1], der[1], der[2], der[6], 1, 0, 0) + call dgsder (vsf[1], der[1], der[2], der[7], 1, 1, 0) + call dgsder (vsf[1], der[1], der[2], der[8], 1, 0, 1) + } else { + call dgsder (vsf[1], der[1], der[2], der[6], 1, 0, 0) + call dgsder (vsf[1], der[1], der[2], der[7], 1, 1, 0) + call dgsder (vsf[1], der[1], der[2], der[8], 1, 0, 1) + do j = 2, nvsf { + call dgsder (vsf[j], der[1], der[2], tmp[1], 1, 0, 0) + call dgsder (vsf[j], der[1], der[2], tmp[2], 1, 1, 0) + call dgsder (vsf[j], der[1], der[2], tmp[3], 1, 0, 1) + der[6] = der[6] + tmp[1] + der[7] = der[7] + tmp[2] + der[8] = der[8] + tmp[3] + } + } +end diff --git a/pkg/images/immatch/src/imcombine/imcombine.par b/pkg/images/immatch/src/imcombine/imcombine.par new file mode 100644 index 00000000..ead908e4 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/imcombine.par @@ -0,0 +1,43 @@ +# IMCOMBINE -- Image combine parameters + +input,s,a,,,,List of images to combine +output,s,a,,,,List of output images +headers,s,h,"",,,List of header files (optional) +bpmasks,s,h,"",,,List of bad pixel masks (optional) +rejmasks,s,h,"",,,List of rejection masks (optional) +nrejmasks,s,h,"",,,List of number rejected masks (optional) +expmasks,s,h,"",,,List of exposure masks (optional) +sigmas,s,h,"",,,List of sigma images (optional) +imcmb,s,h,"$I",,,Keyword for IMCMB keywords +logfile,s,h,"STDOUT",,,"Log file +" +combine,s,h,"average","average|median|lmedian|sum|quadrature|nmodel",,Type of combine operation +reject,s,h,"none","none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip",,Type of rejection +project,b,h,no,,,Project highest dimension of input images? +outtype,s,h,"real","short|ushort|integer|long|real|double",,Output image pixel datatype +outlimits,s,h,"",,,Output limits (x1 x2 y1 y2 ...) +offsets,f,h,"none",,,Input image offsets +masktype,s,h,"none","",,Mask type +maskvalue,s,h,"0",,,Mask value +blank,r,h,0.,,,"Value if there are no pixels +" +scale,s,h,"none",,,Image scaling +zero,s,h,"none",,,Image zero point offset +weight,s,h,"none",,,Image weights +statsec,s,h,"",,,Image section for computing statistics +expname,s,h,"",,,"Image header exposure time keyword +" +lthreshold,r,h,INDEF,,,Lower threshold +hthreshold,r,h,INDEF,,,Upper threshold +nlow,i,h,1,0,,minmax: Number of low pixels to reject +nhigh,i,h,1,0,,minmax: Number of high pixels to reject +nkeep,i,h,1,,,Minimum to keep (pos) or maximum to reject (neg) +mclip,b,h,yes,,,Use median in sigma clipping algorithms? +lsigma,r,h,3.,0.,,Lower sigma clipping factor +hsigma,r,h,3.,0.,,Upper sigma clipping factor +rdnoise,s,h,"0.",,,ccdclip: CCD readout noise (electrons) +gain,s,h,"1.",,,ccdclip: CCD gain (electrons/DN) +snoise,s,h,"0.",,,ccdclip: Sensitivity noise (fraction) +sigscale,r,h,0.1,0.,,Tolerance for sigma clipping scaling corrections +pclip,r,h,-0.5,,,pclip: Percentile clipping parameter +grow,r,h,0.,0.,,Radius (pixels) for neighbor rejection diff --git a/pkg/images/immatch/src/imcombine/mkpkg b/pkg/images/immatch/src/imcombine/mkpkg new file mode 100644 index 00000000..456232e8 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/mkpkg @@ -0,0 +1,20 @@ +# Make the IMCOMBINE Task. + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + +standalone: + $set LIBS1 = "src/libimc.a -lxtools -lcurfit -lsurfit -lgsurfit" + $set LIBS2 = "-liminterp -lnlfit -lslalib -lncar -lgks" + $update libimc.a@src + $update libpkg.a + $omake x_imcombine.x + $link x_imcombine.o libpkg.a $(LIBS1) $(LIBS2) -o xx_imcombine.e + ; + +libpkg.a: + t_imcombine.x src/icombine.com src/icombine.h <error.h> <mach.h> \ + <imhdr.h> + ; diff --git a/pkg/images/immatch/src/imcombine/src/Revisions b/pkg/images/immatch/src/imcombine/src/Revisions new file mode 100644 index 00000000..469f9e5c --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/Revisions @@ -0,0 +1,36 @@ +.help revisions Jul04 imcombine/src +.nf + +This directory contains generic code used in various tasks that combine +images. + +======= +V2.13 +======= + +icgdata.gx + Fixed a problem where 3-D images were closing an image in the case + of many bands leading to a slow execution (10/20/06, Valdes) + +======= +V2.12.3 +======= + +icmask.x +iclog.x +icombine.h + As a special unadvertised feature the "maskvalue" parameter may be + specified with a leading '<' or '>'. Ultimately a full expression + should be added and documented. (7/26/04, Valdes) + +icmask.x + Added a feature to allow masks specified without a path to be found + either in the current directory or the directory with the image. This + is useful when images to be combined are distributed across multiple + directories. (7/16/04, Valdes) + +======== +V2.12.2a +======== + +.endhelp diff --git a/pkg/images/immatch/src/imcombine/src/generic/icaclip.x b/pkg/images/immatch/src/imcombine/src/generic/icaclip.x new file mode 100644 index 00000000..8fb89b1b --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icaclip.x @@ -0,0 +1,2207 @@ +# 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 = max (0, n[1]) + s = 0. + n2 = 0 + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 = max (0, 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 (max (0, 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, sig, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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) + sig = sqrt (s / (n2 - 1)) + else { + call sfree (sp) + return + } + + # Compute individual sigmas and iteratively clip. + do i = 1, npts { + k = i - 1 + n1 = max (0, 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) && sig > 0.) { + if (doscale1) { + for (; nl <= nh; nl = nl + 1) { + l = Memi[m[nl]+k] + s1 = sig * 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 = sig * 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 = sig * sqrt (max (one, med)) + for (; nl <= nh; 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 == max (0, 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 (max (0, 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 = max (0, n[1]) + s = 0. + n2 = 0 + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 = max (0, 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 (max (0, 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, sig, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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) + sig = sqrt (s / (n2 - 1)) + else { + call sfree (sp) + return + } + + # Compute individual sigmas and iteratively clip. + do i = 1, npts { + k = i - 1 + n1 = max (0, 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) && sig > 0.) { + if (doscale1) { + for (; nl <= nh; nl = nl + 1) { + l = Memi[m[nl]+k] + s1 = sig * 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 = sig * 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 = sig * sqrt (max (one, med)) + for (; nl <= nh; 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 == max (0, 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 (max (0, 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 = max (0, n[1]) + s = 0. + n2 = 0 + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 = max (0, 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 (max (0, 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, sig, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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) + sig = sqrt (s / (n2 - 1)) + else { + call sfree (sp) + return + } + + # Compute individual sigmas and iteratively clip. + do i = 1, npts { + k = i - 1 + n1 = max (0, 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) && sig > 0.) { + if (doscale1) { + for (; nl <= nh; nl = nl + 1) { + l = Memi[m[nl]+k] + s1 = sig * 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 = sig * 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 = sig * sqrt (max (one, med)) + for (; nl <= nh; 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 == max (0, 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 (max (0, 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 = max (0, n[1]) + s = 0. + n2 = 0 + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 = max (0, 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 (max (0, 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, sig, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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) + sig = sqrt (s / (n2 - 1)) + else { + call sfree (sp) + return + } + + # Compute individual sigmas and iteratively clip. + do i = 1, npts { + k = i - 1 + n1 = max (0, 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) && sig > 0.) { + if (doscale1) { + for (; nl <= nh; nl = nl + 1) { + l = Memi[m[nl]+k] + s1 = sig * 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 = sig * 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 = sig * sqrt (max (one, med)) + for (; nl <= nh; 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 == max (0, 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 (max (0, 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/images/immatch/src/imcombine/src/generic/icaverage.x b/pkg/images/immatch/src/imcombine/src/generic/icaverage.x new file mode 100644 index 00000000..7167d301 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icaverage.x @@ -0,0 +1,424 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> +include "../icombine.h" +include "../icmask.h" + + +# IC_AVERAGE -- Compute the average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_averages (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real sumwt, wt +real sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum 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/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + 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] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Mems[d[1]+k] * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + Mems[d[j]+k] * wt + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sum / sumwt + else { + sum = Mems[d[1]+k] + do j = 2, n1 + sum = sum + Mems[d[j]+k] + average[i] = sum / n1 + } + } else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + sum = Mems[d[1]+k] + do j = 2, n1 + sum = sum + Mems[d[j]+k] + if (doaverage == YES) + average[i] = sum / n1 + else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_AVERAGE -- Compute the average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_averagei (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real sumwt, wt +real sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum 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/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + 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] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Memi[d[1]+k] * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + Memi[d[j]+k] * wt + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sum / sumwt + else { + sum = Memi[d[1]+k] + do j = 2, n1 + sum = sum + Memi[d[j]+k] + average[i] = sum / n1 + } + } else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + sum = Memi[d[1]+k] + do j = 2, n1 + sum = sum + Memi[d[j]+k] + if (doaverage == YES) + average[i] = sum / n1 + else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_AVERAGE -- Compute the average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_averager (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real sumwt, wt +real sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum 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/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + 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] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Memr[d[1]+k] * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + Memr[d[j]+k] * wt + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sum / sumwt + else { + sum = Memr[d[1]+k] + do j = 2, n1 + sum = sum + Memr[d[j]+k] + average[i] = sum / n1 + } + } else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + sum = Memr[d[1]+k] + do j = 2, n1 + sum = sum + Memr[d[j]+k] + if (doaverage == YES) + average[i] = sum / n1 + else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_AVERAGE -- Compute the average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_averaged (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +double average[npts] # Average (returned) + +int i, j, k, n1 +real sumwt, wt +double sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum 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/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + 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] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Memd[d[1]+k] * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + Memd[d[j]+k] * wt + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sum / sumwt + else { + sum = Memd[d[1]+k] + do j = 2, n1 + sum = sum + Memd[d[j]+k] + average[i] = sum / n1 + } + } else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + sum = Memd[d[1]+k] + do j = 2, n1 + sum = sum + Memd[d[j]+k] + if (doaverage == YES) + average[i] = sum / n1 + else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } + } +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/iccclip.x b/pkg/images/immatch/src/imcombine/src/generic/iccclip.x new file mode 100644 index 00000000..cf60c779 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/iccclip.x @@ -0,0 +1,1791 @@ +# 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, 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 (max (0, 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/images/immatch/src/imcombine/src/generic/icgdata.x b/pkg/images/immatch/src/imcombine/src/generic/icgdata.x new file mode 100644 index 00000000..774de63c --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icgdata.x @@ -0,0 +1,1531 @@ +# 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[ARB] # 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 + +short temp +int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, mtype, xt_imgnls() +real a, b +pointer buf, dp, ip, mp +errchk xt_cpix, xt_imgnls + +short max_pixel +data max_pixel/MAX_SHORT/ + +include "../icombine.com" + +begin + # Get masks and return if there is no data + call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) + if (dflag == D_NONE) { + call aclri (n, npts) + return + } + + # Close images which are not needed. + nout = IM_LEN(out[1],1) + ndim = IM_NDIM(out[1]) + if (!project && ndim < 3) { + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + call xt_cpix (i) + if (ndim > 1) { + j = v1[2] - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + } + } + + # Get data and fill data buffers. Correct for offsets if needed. + 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 = xt_imgnls (in[i], i, d[i], v2, v1[2]) + } else { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) { + lflag[i] = D_NONE + next + } + k = 1 + j - offsets[i,1] + v2[1] = k + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + if (lflag[i] == D_NONE) + next + if (project) + v2[ndim+1] = i + l = xt_imgnls (in[i], i, buf, v2, v1[2]) + call amovs (Mems[buf+k-1], Mems[dbuf[i]+j], npix) + d[i] = dbuf[i] + } + } + + # Set values to max_pixel if needed. + if (mtype == M_NOVAL) { + do i = 1, nimages { + dp = d[i]; mp = m[i] + if (lflag[i] == D_NONE || dp == NULL) + next + else if (lflag[i] == D_MIX) { + do j = 1, npts { + if (Memi[mp] == 1) + Mems[dp] = max_pixel + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + a = Mems[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + + lflag[i] = D_MIX + dflag = D_MIX + } + dp = dp + 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 + } + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) { + a = Mems[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + dflag = D_MIX + } + } + dp = dp + 1 + mp = mp + 1 + } + + # Check for completely empty lines + lflag[i] = D_NONE + mp = m[i] + n1 - 1 + do j = n1, n2 { + 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 { + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + Mems[dp] = Mems[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) + 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 + } + } + do i = nused+1, nimages + d[i] = NULL + 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] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + ip = id[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + Memi[ip] = l + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Mems[d[k]+j-1] + Mems[d[k]+j-1] = Mems[dp] + Mems[dp] = temp + Memi[ip] = Memi[id[k]+j-1] + Memi[id[k]+j-1] = l + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } else + Memi[ip] = 0 + 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 { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Mems[d[k]+j-1] + Mems[d[k]+j-1] = Mems[dp] + Mems[dp] = temp + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Sort the pixels and IDs if needed + if (mclip) { + call malloc (dp, nused, TY_SHORT) + if (keepids) { + call malloc (ip, nused, 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) + } + + # If no good pixels set the number of usable values as -n and + # shift them to lower values. + if (mtype == M_NOVAL) { + if (keepids) { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + ip = id[i] + j - 1 + if (Mems[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) { + Mems[d[k]+j-1] = Mems[dp] + Memi[id[k]+j-1] = Memi[ip] + } + } + } + } + } else { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + if (Mems[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) + Mems[d[k]+j-1] = Mems[dp] + } + } + } + } + } +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[ARB] # 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 temp +int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, mtype, xt_imgnli() +real a, b +pointer buf, dp, ip, mp +errchk xt_cpix, xt_imgnli + +int max_pixel +data max_pixel/MAX_INT/ + +include "../icombine.com" + +begin + # Get masks and return if there is no data + call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) + if (dflag == D_NONE) { + call aclri (n, npts) + return + } + + # Close images which are not needed. + nout = IM_LEN(out[1],1) + ndim = IM_NDIM(out[1]) + if (!project && ndim < 3) { + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + call xt_cpix (i) + if (ndim > 1) { + j = v1[2] - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + } + } + + # Get data and fill data buffers. Correct for offsets if needed. + 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 = xt_imgnli (in[i], i, d[i], v2, v1[2]) + } else { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) { + lflag[i] = D_NONE + next + } + k = 1 + j - offsets[i,1] + v2[1] = k + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + if (lflag[i] == D_NONE) + next + if (project) + v2[ndim+1] = i + l = xt_imgnli (in[i], i, buf, v2, v1[2]) + call amovi (Memi[buf+k-1], Memi[dbuf[i]+j], npix) + d[i] = dbuf[i] + } + } + + # Set values to max_pixel if needed. + if (mtype == M_NOVAL) { + do i = 1, nimages { + dp = d[i]; mp = m[i] + if (lflag[i] == D_NONE || dp == NULL) + next + else if (lflag[i] == D_MIX) { + do j = 1, npts { + if (Memi[mp] == 1) + Memi[dp] = max_pixel + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + a = Memi[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + + lflag[i] = D_MIX + dflag = D_MIX + } + dp = dp + 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 + } + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) { + a = Memi[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + dflag = D_MIX + } + } + dp = dp + 1 + mp = mp + 1 + } + + # Check for completely empty lines + lflag[i] = D_NONE + mp = m[i] + n1 - 1 + do j = n1, n2 { + 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 { + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + Memi[dp] = Memi[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) + 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 + } + } + do i = nused+1, nimages + d[i] = NULL + 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] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + ip = id[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + Memi[ip] = l + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Memi[d[k]+j-1] + Memi[d[k]+j-1] = Memi[dp] + Memi[dp] = temp + Memi[ip] = Memi[id[k]+j-1] + Memi[id[k]+j-1] = l + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } else + Memi[ip] = 0 + 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 { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Memi[d[k]+j-1] + Memi[d[k]+j-1] = Memi[dp] + Memi[dp] = temp + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Sort the pixels and IDs if needed + if (mclip) { + call malloc (dp, nused, TY_INT) + if (keepids) { + call malloc (ip, nused, 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) + } + + # If no good pixels set the number of usable values as -n and + # shift them to lower values. + if (mtype == M_NOVAL) { + if (keepids) { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + ip = id[i] + j - 1 + if (Memi[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) { + Memi[d[k]+j-1] = Memi[dp] + Memi[id[k]+j-1] = Memi[ip] + } + } + } + } + } else { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + if (Memi[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) + Memi[d[k]+j-1] = Memi[dp] + } + } + } + } + } +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[ARB] # 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 + +real temp +int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, mtype, xt_imgnlr() +real a, b +pointer buf, dp, ip, mp +errchk xt_cpix, xt_imgnlr + +real max_pixel +data max_pixel/MAX_REAL/ + +include "../icombine.com" + +begin + # Get masks and return if there is no data + call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) + if (dflag == D_NONE) { + call aclri (n, npts) + return + } + + # Close images which are not needed. + nout = IM_LEN(out[1],1) + ndim = IM_NDIM(out[1]) + if (!project && ndim < 3) { + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + call xt_cpix (i) + if (ndim > 1) { + j = v1[2] - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + } + } + + # Get data and fill data buffers. Correct for offsets if needed. + 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 = xt_imgnlr (in[i], i, d[i], v2, v1[2]) + } else { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) { + lflag[i] = D_NONE + next + } + k = 1 + j - offsets[i,1] + v2[1] = k + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + if (lflag[i] == D_NONE) + next + if (project) + v2[ndim+1] = i + l = xt_imgnlr (in[i], i, buf, v2, v1[2]) + call amovr (Memr[buf+k-1], Memr[dbuf[i]+j], npix) + d[i] = dbuf[i] + } + } + + # Set values to max_pixel if needed. + if (mtype == M_NOVAL) { + do i = 1, nimages { + dp = d[i]; mp = m[i] + if (lflag[i] == D_NONE || dp == NULL) + next + else if (lflag[i] == D_MIX) { + do j = 1, npts { + if (Memi[mp] == 1) + Memr[dp] = max_pixel + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + a = Memr[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + + lflag[i] = D_MIX + dflag = D_MIX + } + dp = dp + 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 + } + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) { + a = Memr[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + dflag = D_MIX + } + } + dp = dp + 1 + mp = mp + 1 + } + + # Check for completely empty lines + lflag[i] = D_NONE + mp = m[i] + n1 - 1 + do j = n1, n2 { + 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 { + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + Memr[dp] = Memr[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) + 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 + } + } + do i = nused+1, nimages + d[i] = NULL + 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] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + ip = id[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + Memi[ip] = l + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Memr[d[k]+j-1] + Memr[d[k]+j-1] = Memr[dp] + Memr[dp] = temp + Memi[ip] = Memi[id[k]+j-1] + Memi[id[k]+j-1] = l + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } else + Memi[ip] = 0 + 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 { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Memr[d[k]+j-1] + Memr[d[k]+j-1] = Memr[dp] + Memr[dp] = temp + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Sort the pixels and IDs if needed + if (mclip) { + call malloc (dp, nused, TY_REAL) + if (keepids) { + call malloc (ip, nused, 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) + } + + # If no good pixels set the number of usable values as -n and + # shift them to lower values. + if (mtype == M_NOVAL) { + if (keepids) { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + ip = id[i] + j - 1 + if (Memr[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) { + Memr[d[k]+j-1] = Memr[dp] + Memi[id[k]+j-1] = Memi[ip] + } + } + } + } + } else { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + if (Memr[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) + Memr[d[k]+j-1] = Memr[dp] + } + } + } + } + } +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[ARB] # 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 + +double temp +int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, mtype, xt_imgnld() +real a, b +pointer buf, dp, ip, mp +errchk xt_cpix, xt_imgnld + +double max_pixel +data max_pixel/MAX_DOUBLE/ + +include "../icombine.com" + +begin + # Get masks and return if there is no data + call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) + if (dflag == D_NONE) { + call aclri (n, npts) + return + } + + # Close images which are not needed. + nout = IM_LEN(out[1],1) + ndim = IM_NDIM(out[1]) + if (!project && ndim < 3) { + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + call xt_cpix (i) + if (ndim > 1) { + j = v1[2] - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + } + } + + # Get data and fill data buffers. Correct for offsets if needed. + 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 = xt_imgnld (in[i], i, d[i], v2, v1[2]) + } else { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) { + lflag[i] = D_NONE + next + } + k = 1 + j - offsets[i,1] + v2[1] = k + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + if (lflag[i] == D_NONE) + next + if (project) + v2[ndim+1] = i + l = xt_imgnld (in[i], i, buf, v2, v1[2]) + call amovd (Memd[buf+k-1], Memd[dbuf[i]+j], npix) + d[i] = dbuf[i] + } + } + + # Set values to max_pixel if needed. + if (mtype == M_NOVAL) { + do i = 1, nimages { + dp = d[i]; mp = m[i] + if (lflag[i] == D_NONE || dp == NULL) + next + else if (lflag[i] == D_MIX) { + do j = 1, npts { + if (Memi[mp] == 1) + Memd[dp] = max_pixel + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + a = Memd[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + + lflag[i] = D_MIX + dflag = D_MIX + } + dp = dp + 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 + } + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) { + a = Memd[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + dflag = D_MIX + } + } + dp = dp + 1 + mp = mp + 1 + } + + # Check for completely empty lines + lflag[i] = D_NONE + mp = m[i] + n1 - 1 + do j = n1, n2 { + 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 { + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + Memd[dp] = Memd[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) + 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 + } + } + do i = nused+1, nimages + d[i] = NULL + 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] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + ip = id[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + Memi[ip] = l + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Memd[d[k]+j-1] + Memd[d[k]+j-1] = Memd[dp] + Memd[dp] = temp + Memi[ip] = Memi[id[k]+j-1] + Memi[id[k]+j-1] = l + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } else + Memi[ip] = 0 + 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 { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Memd[d[k]+j-1] + Memd[d[k]+j-1] = Memd[dp] + Memd[dp] = temp + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Sort the pixels and IDs if needed + if (mclip) { + call malloc (dp, nused, TY_DOUBLE) + if (keepids) { + call malloc (ip, nused, 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) + } + + # If no good pixels set the number of usable values as -n and + # shift them to lower values. + if (mtype == M_NOVAL) { + if (keepids) { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + ip = id[i] + j - 1 + if (Memd[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) { + Memd[d[k]+j-1] = Memd[dp] + Memi[id[k]+j-1] = Memi[ip] + } + } + } + } + } else { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + if (Memd[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) + Memd[d[k]+j-1] = Memd[dp] + } + } + } + } + } +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icgrow.x b/pkg/images/immatch/src/imcombine/src/generic/icgrow.x new file mode 100644 index 00000000..1ccb7885 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icgrow.x @@ -0,0 +1,263 @@ +# 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, ncompress, 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) + ncompress = 0 + } + 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) + if (l > 0) { + v[2] = line + l + if (v[2] <= nl) + call pmplpi (pm, v, buf[1,i], 1, npts, rop) + } + } + } + v[2] = line + + if (ncompress > 10) { + do i = 1, nimages { + pm = Memi[pms+i-1] + call pm_compress (pm) + } + ncompress = 0 + } else + ncompress = ncompress + 1 +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/images/immatch/src/imcombine/src/generic/icmedian.x b/pkg/images/immatch/src/imcombine/src/generic/icmedian.x new file mode 100644 index 00000000..c482454b --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icmedian.x @@ -0,0 +1,753 @@ +# 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, j, k, j1, j2, n1, lo, up, lo1, up1 +bool even +real val1, val2, val3 +short temp, wtemp + +include "../icombine.com" + +begin + # If no data return after possibly setting blank values. + if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + median[i]= blank + } + return + } + + # If the data were previously sorted then directly compute the median. + if (mclip) { + if (dflag == D_ALL) { + n1 = n[1] + j1 = n1 / 2 + 1 + j2 = n1 / 2 + even = (mod(n1,2)==0 && (medtype==MEDAVG || 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] + } + return + } else { + # Check for negative n values. If found then there are + # pixels with no good values but with values we want to + # use as a substitute median. In this case ignore that + # the good pixels have been sorted. + do i = 1, npts { + if (n[i] < 0) + break + } + + if (n[i] >= 0) { + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 > 0) { + j1 = n1 / 2 + 1 + if (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) { + 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 + } + } + } + + # Compute the median. + do i = 1, npts { + k = i - 1 + n1 = abs(n[i]) + + # If there are more than 3 points use Wirth algorithm. This + # is the same as vops$amed.gx except for an even number of + # points it selects the middle two and averages. + if (n1 > 3) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Mems[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Mems[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Mems[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Mems[d[lo1]+k] + Mems[d[lo1]+k] = Mems[d[up1]+k] + Mems[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + + median[i] = Mems[d[j]+k] + + if (mod(n1,2)==0 && (medtype==MEDAVG || n1 > 2)) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)+1) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Mems[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Mems[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Mems[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Mems[d[lo1]+k] + Mems[d[lo1]+k] = Mems[d[up1]+k] + Mems[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + median[i] = (median[i] + Mems[d[j]+k]) / 2 + } + + # If 3 points find the median directly. + } else 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 + } + + # If 2 points average. + } else if (n1 == 2) { + val1 = Mems[d[1]+k] + val2 = Mems[d[2]+k] + if (medtype == MEDAVG) + median[i] = (val1 + val2) / 2 + else + median[i] = min (val1, val2) + + # If 1 point return the value. + } else if (n1 == 1) + median[i] = Mems[d[1]+k] + + # If no points return with a possibly blank value. + 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, j, k, j1, j2, n1, lo, up, lo1, up1 +bool even +real val1, val2, val3 +int temp, wtemp + +include "../icombine.com" + +begin + # If no data return after possibly setting blank values. + if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + median[i]= blank + } + return + } + + # If the data were previously sorted then directly compute the median. + if (mclip) { + if (dflag == D_ALL) { + n1 = n[1] + j1 = n1 / 2 + 1 + j2 = n1 / 2 + even = (mod(n1,2)==0 && (medtype==MEDAVG || 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] + } + return + } else { + # Check for negative n values. If found then there are + # pixels with no good values but with values we want to + # use as a substitute median. In this case ignore that + # the good pixels have been sorted. + do i = 1, npts { + if (n[i] < 0) + break + } + + if (n[i] >= 0) { + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 > 0) { + j1 = n1 / 2 + 1 + if (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) { + 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 + } + } + } + + # Compute the median. + do i = 1, npts { + k = i - 1 + n1 = abs(n[i]) + + # If there are more than 3 points use Wirth algorithm. This + # is the same as vops$amed.gx except for an even number of + # points it selects the middle two and averages. + if (n1 > 3) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memi[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memi[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memi[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memi[d[lo1]+k] + Memi[d[lo1]+k] = Memi[d[up1]+k] + Memi[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + + median[i] = Memi[d[j]+k] + + if (mod(n1,2)==0 && (medtype==MEDAVG || n1 > 2)) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)+1) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memi[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memi[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memi[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memi[d[lo1]+k] + Memi[d[lo1]+k] = Memi[d[up1]+k] + Memi[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + median[i] = (median[i] + Memi[d[j]+k]) / 2 + } + + # If 3 points find the median directly. + } else 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 + } + + # If 2 points average. + } else if (n1 == 2) { + val1 = Memi[d[1]+k] + val2 = Memi[d[2]+k] + if (medtype == MEDAVG) + median[i] = (val1 + val2) / 2 + else + median[i] = min (val1, val2) + + # If 1 point return the value. + } else if (n1 == 1) + median[i] = Memi[d[1]+k] + + # If no points return with a possibly blank value. + 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, j, k, j1, j2, n1, lo, up, lo1, up1 +bool even +real val1, val2, val3 +real temp, wtemp + +include "../icombine.com" + +begin + # If no data return after possibly setting blank values. + if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + median[i]= blank + } + return + } + + # If the data were previously sorted then directly compute the median. + if (mclip) { + if (dflag == D_ALL) { + n1 = n[1] + j1 = n1 / 2 + 1 + j2 = n1 / 2 + even = (mod(n1,2)==0 && (medtype==MEDAVG || 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] + } + return + } else { + # Check for negative n values. If found then there are + # pixels with no good values but with values we want to + # use as a substitute median. In this case ignore that + # the good pixels have been sorted. + do i = 1, npts { + if (n[i] < 0) + break + } + + if (n[i] >= 0) { + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 > 0) { + j1 = n1 / 2 + 1 + if (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) { + 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 + } + } + } + + # Compute the median. + do i = 1, npts { + k = i - 1 + n1 = abs(n[i]) + + # If there are more than 3 points use Wirth algorithm. This + # is the same as vops$amed.gx except for an even number of + # points it selects the middle two and averages. + if (n1 > 3) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memr[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memr[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memr[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memr[d[lo1]+k] + Memr[d[lo1]+k] = Memr[d[up1]+k] + Memr[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + + median[i] = Memr[d[j]+k] + + if (mod(n1,2)==0 && (medtype==MEDAVG || n1 > 2)) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)+1) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memr[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memr[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memr[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memr[d[lo1]+k] + Memr[d[lo1]+k] = Memr[d[up1]+k] + Memr[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + median[i] = (median[i] + Memr[d[j]+k]) / 2 + } + + # If 3 points find the median directly. + } else 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 + } + + # If 2 points average. + } else if (n1 == 2) { + val1 = Memr[d[1]+k] + val2 = Memr[d[2]+k] + if (medtype == MEDAVG) + median[i] = (val1 + val2) / 2 + else + median[i] = min (val1, val2) + + # If 1 point return the value. + } else if (n1 == 1) + median[i] = Memr[d[1]+k] + + # If no points return with a possibly blank value. + 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, j, k, j1, j2, n1, lo, up, lo1, up1 +bool even +double val1, val2, val3 +double temp, wtemp + +include "../icombine.com" + +begin + # If no data return after possibly setting blank values. + if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + median[i]= blank + } + return + } + + # If the data were previously sorted then directly compute the median. + if (mclip) { + if (dflag == D_ALL) { + n1 = n[1] + j1 = n1 / 2 + 1 + j2 = n1 / 2 + even = (mod(n1,2)==0 && (medtype==MEDAVG || 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] + } + return + } else { + # Check for negative n values. If found then there are + # pixels with no good values but with values we want to + # use as a substitute median. In this case ignore that + # the good pixels have been sorted. + do i = 1, npts { + if (n[i] < 0) + break + } + + if (n[i] >= 0) { + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 > 0) { + j1 = n1 / 2 + 1 + if (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) { + 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 + } + } + } + + # Compute the median. + do i = 1, npts { + k = i - 1 + n1 = abs(n[i]) + + # If there are more than 3 points use Wirth algorithm. This + # is the same as vops$amed.gx except for an even number of + # points it selects the middle two and averages. + if (n1 > 3) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memd[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memd[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memd[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memd[d[lo1]+k] + Memd[d[lo1]+k] = Memd[d[up1]+k] + Memd[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + + median[i] = Memd[d[j]+k] + + if (mod(n1,2)==0 && (medtype==MEDAVG || n1 > 2)) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)+1) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memd[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memd[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memd[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memd[d[lo1]+k] + Memd[d[lo1]+k] = Memd[d[up1]+k] + Memd[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + median[i] = (median[i] + Memd[d[j]+k]) / 2 + } + + # If 3 points find the median directly. + } else 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 + } + + # If 2 points average. + } else if (n1 == 2) { + val1 = Memd[d[1]+k] + val2 = Memd[d[2]+k] + if (medtype == MEDAVG) + median[i] = (val1 + val2) / 2 + else + median[i] = min (val1, val2) + + # If 1 point return the value. + } else if (n1 == 1) + median[i] = Memd[d[1]+k] + + # If no points return with a possibly blank value. + else if (doblank == YES) + median[i] = blank + } +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icmm.x b/pkg/images/immatch/src/imcombine/src/generic/icmm.x new file mode 100644 index 00000000..9c8274c8 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icmm.x @@ -0,0 +1,645 @@ +# 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 = max (0, 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 = max (0, 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 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } else { + Mems[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } + if (jmin < j) { + if (jmax != n1) { + Mems[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } else { + Mems[kmin] = d2 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } + } + } 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 = max (0, 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 = max (0, 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 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } else { + Memi[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } + if (jmin < j) { + if (jmax != n1) { + Memi[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } else { + Memi[kmin] = d2 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } + } + } 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 = max (0, 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 = max (0, 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 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } else { + Memr[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } + if (jmin < j) { + if (jmax != n1) { + Memr[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } else { + Memr[kmin] = d2 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } + } + } 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 = max (0, 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 = max (0, 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 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } else { + Memd[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } + if (jmin < j) { + if (jmax != n1) { + Memd[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } else { + Memd[kmin] = d2 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } + } + } 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/images/immatch/src/imcombine/src/generic/icnmodel.x b/pkg/images/immatch/src/imcombine/src/generic/icnmodel.x new file mode 100644 index 00000000..559cba73 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icnmodel.x @@ -0,0 +1,528 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> +include "../icombine.h" +include "../icmask.h" + + +# IC_NMODEL -- Compute the quadrature average (or summed) noise model. +# Options include a weighted average/sum. + +procedure ic_nmodels (d, m, n, nm, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real nm[3,nimages] # Noise model parameters +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +real sum, zero +data zero /0.0/ + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum 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/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = max (zero, Mems[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + do j = 2, n[i] { + val = max (zero, Mems[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = max (zero, Mems[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n[i] { + val = max (zero, Mems[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Mems[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + sumwt = wt + do j = 2, n1 { + val = max (zero, Mems[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = max (zero, Mems[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = Mems[d[1]+k]**2 + do j = 2, n1 { + val = max (zero, Mems[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + + (val*nm[3,j])**2 + sum = sum + val + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Mems[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n1 { + val = max (zero, Mems[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_NMODEL -- Compute the quadrature average (or summed) noise model. +# Options include a weighted average/sum. + +procedure ic_nmodeli (d, m, n, nm, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real nm[3,nimages] # Noise model parameters +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +real sum, zero +data zero /0.0/ + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum 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/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = max (zero, Memi[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + do j = 2, n[i] { + val = max (zero, Memi[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = max (zero, Memi[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n[i] { + val = max (zero, Memi[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Memi[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + sumwt = wt + do j = 2, n1 { + val = max (zero, Memi[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = max (zero, Memi[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = Memi[d[1]+k]**2 + do j = 2, n1 { + val = max (zero, Memi[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + + (val*nm[3,j])**2 + sum = sum + val + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Memi[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n1 { + val = max (zero, Memi[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_NMODEL -- Compute the quadrature average (or summed) noise model. +# Options include a weighted average/sum. + +procedure ic_nmodelr (d, m, n, nm, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real nm[3,nimages] # Noise model parameters +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +real sum, zero +data zero /0.0/ + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum 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/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = max (zero, Memr[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + do j = 2, n[i] { + val = max (zero, Memr[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = max (zero, Memr[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n[i] { + val = max (zero, Memr[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Memr[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + sumwt = wt + do j = 2, n1 { + val = max (zero, Memr[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = max (zero, Memr[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = Memr[d[1]+k]**2 + do j = 2, n1 { + val = max (zero, Memr[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + + (val*nm[3,j])**2 + sum = sum + val + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Memr[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n1 { + val = max (zero, Memr[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_NMODEL -- Compute the quadrature average (or summed) noise model. +# Options include a weighted average/sum. + +procedure ic_nmodeld (d, m, n, nm, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real nm[3,nimages] # Noise model parameters +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +double average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +double sum, zero +data zero /0.0D0/ + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum 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/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = max (zero, Memd[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + do j = 2, n[i] { + val = max (zero, Memd[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = max (zero, Memd[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n[i] { + val = max (zero, Memd[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Memd[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + sumwt = wt + do j = 2, n1 { + val = max (zero, Memd[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = max (zero, Memd[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = Memd[d[1]+k]**2 + do j = 2, n1 { + val = max (zero, Memd[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + + (val*nm[3,j])**2 + sum = sum + val + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Memd[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n1 { + val = max (zero, Memd[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icomb.x b/pkg/images/immatch/src/imcombine/src/generic/icomb.x new file mode 100644 index 00000000..3466073b --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icomb.x @@ -0,0 +1,2198 @@ +# 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" + +# The following is for compiling under V2.11. +define IM_BUFFRAC IM_BUFSIZE +include <imset.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, scales, zeros, wts, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real wts[nimages] # Weights +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, k, npts, fd, stropen(), xt_imgnls() +pointer sp, d, id, n, m, lflag, v, dbuf +pointer im, buf, xt_opix(), impl1i() +errchk stropen, xt_cpix, xt_opix, xt_imgnls, impl1i, ic_combines +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 (v, IM_MAXDIM, TY_LONG) + call amovki (D_ALL, Memi[lflag], nimages) + call amovkl (1, Meml[v], IM_MAXDIM) + + # 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) + call aclrs (Mems[Memi[dbuf+i-1]], npts) + } + } else { + do i = 1, nimages { + im = xt_opix (in[i], i, 1) + if (im != in[i]) { + call salloc (Memi[dbuf+i-1], npts, TY_SHORT) + call aclrs (Mems[Memi[dbuf+i-1]], npts) + } + } + call amovki (NULL, Memi[dbuf], nimages) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFFRAC, 0) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + 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, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + 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) + } + if (out[4] != NULL) { + buf = impl1i (out[4]) + call aclri (Memi[buf], npts) + } + if (out[5] != NULL) { + buf = impl1i (out[5]) + call aclri (Memi[buf], npts) + } + if (out[6] != NULL) { + buf = impl1i (out[6]) + call aclri (Memi[buf], npts) + } + + # Do I/O for first input image line. + if (!project) { + do i = 1, nimages { + call xt_imseti (i, "bufsize", bufsize) + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + call xt_cpix (i) + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + + do i = 1, nimages { + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + next + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + next + iferr { + Meml[v+1] = j + j = xt_imgnls (in[i], i, buf, Meml[v], 1) + } then { + call imseti (im, IM_PIXFD, NULL) + 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, scales, zeros, 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[ARB] # 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(), errcode() +real r, imgetr() +pointer sp, fname, imname, v1, v2, v3, work +pointer outdata, buf, nmod, nm, pms +pointer immap(), impnli() +pointer impnlr(), imgnlr() +errchk immap, ic_scale, imgetr, ic_grow, ic_grows, ic_rmasks, ic_emask +errchk ic_gdatas + +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, SUM, QUAD, NMODEL: + if (dowts) + keepids = true + else + keepids = false + case MEDIAN: + dowts = false + keepids = false + } + docombine = true + + # Get noise model parameters. + if (combine==NMODEL) { + call salloc (nmod, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nmod+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nmod+3*(i-1)+2] = r + } + } + } + + # 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 (out[6] != NULL) { + keepids = true + call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) + } + + 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) + } + +# This idea turns out to has a problem with masks are used with wcs offsets. +# the matching of masks to images based on WCS requires access to the WCS +# of the images. For now we drop this idea but maybe a way can be identified +# to know when this is not going to be needed. +# # Reduce header memory use. +# do i = 1, nimages +# call xt_minhdr (i) + + 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, nimages, npts, + YES, YES, Memr[outdata]) + case MEDIAN: + call ic_medians (d, n, npts, YES, Memr[outdata]) + case SUM: + call ic_averages (d, id, n, wts, nimages, npts, + YES, NO, Memr[outdata]) + case QUAD: + call ic_quads (d, id, n, wts, nimages, npts, + YES, YES, Memr[outdata]) + case NMODEL: + call ic_nmodels (d, id, n, Memr[nmod], wts, + nimages, npts, YES, 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]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 1 + } + } + + 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) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, 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, nimages, npts, + NO, YES, Memr[outdata]) + case MEDIAN: + call ic_medians (d, n, npts, NO, Memr[outdata]) + case SUM: + call ic_averages (d, id, n, wts, nimages, npts, + NO, NO, Memr[outdata]) + case QUAD: + call ic_quads (d, id, n, wts, nimages, npts, + NO, YES, Memr[outdata]) + case NMODEL: + call ic_nmodels (d, id, n, Memr[nmod], wts, + nimages, npts, NO, YES, Memr[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + 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) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, 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, scales, zeros, wts, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real wts[nimages] # Weights +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, k, npts, fd, stropen(), xt_imgnli() +pointer sp, d, id, n, m, lflag, v, dbuf +pointer im, buf, xt_opix(), impl1i() +errchk stropen, xt_cpix, xt_opix, xt_imgnli, impl1i, ic_combinei +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 (v, IM_MAXDIM, TY_LONG) + call amovki (D_ALL, Memi[lflag], nimages) + call amovkl (1, Meml[v], IM_MAXDIM) + + # 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) + call aclri (Memi[Memi[dbuf+i-1]], npts) + } + } else { + do i = 1, nimages { + im = xt_opix (in[i], i, 1) + if (im != in[i]) { + call salloc (Memi[dbuf+i-1], npts, TY_INT) + call aclri (Memi[Memi[dbuf+i-1]], npts) + } + } + call amovki (NULL, Memi[dbuf], nimages) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFFRAC, 0) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + 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, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + 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) + } + if (out[4] != NULL) { + buf = impl1i (out[4]) + call aclri (Memi[buf], npts) + } + if (out[5] != NULL) { + buf = impl1i (out[5]) + call aclri (Memi[buf], npts) + } + if (out[6] != NULL) { + buf = impl1i (out[6]) + call aclri (Memi[buf], npts) + } + + # Do I/O for first input image line. + if (!project) { + do i = 1, nimages { + call xt_imseti (i, "bufsize", bufsize) + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + call xt_cpix (i) + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + + do i = 1, nimages { + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + next + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + next + iferr { + Meml[v+1] = j + j = xt_imgnli (in[i], i, buf, Meml[v], 1) + } then { + call imseti (im, IM_PIXFD, NULL) + 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, scales, zeros, 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[ARB] # 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(), errcode() +real r, imgetr() +pointer sp, fname, imname, v1, v2, v3, work +pointer outdata, buf, nmod, nm, pms +pointer immap(), impnli() +pointer impnlr(), imgnlr() +errchk immap, ic_scale, imgetr, ic_grow, ic_growi, ic_rmasks, ic_emask +errchk ic_gdatai + +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, SUM, QUAD, NMODEL: + if (dowts) + keepids = true + else + keepids = false + case MEDIAN: + dowts = false + keepids = false + } + docombine = true + + # Get noise model parameters. + if (combine==NMODEL) { + call salloc (nmod, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nmod+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nmod+3*(i-1)+2] = r + } + } + } + + # 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 (out[6] != NULL) { + keepids = true + call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) + } + + 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) + } + +# This idea turns out to has a problem with masks are used with wcs offsets. +# the matching of masks to images based on WCS requires access to the WCS +# of the images. For now we drop this idea but maybe a way can be identified +# to know when this is not going to be needed. +# # Reduce header memory use. +# do i = 1, nimages +# call xt_minhdr (i) + + 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, nimages, npts, + YES, YES, Memr[outdata]) + case MEDIAN: + call ic_mediani (d, n, npts, YES, Memr[outdata]) + case SUM: + call ic_averagei (d, id, n, wts, nimages, npts, + YES, NO, Memr[outdata]) + case QUAD: + call ic_quadi (d, id, n, wts, nimages, npts, + YES, YES, Memr[outdata]) + case NMODEL: + call ic_nmodeli (d, id, n, Memr[nmod], wts, + nimages, npts, YES, 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]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 1 + } + } + + 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) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, 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, nimages, npts, + NO, YES, Memr[outdata]) + case MEDIAN: + call ic_mediani (d, n, npts, NO, Memr[outdata]) + case SUM: + call ic_averagei (d, id, n, wts, nimages, npts, + NO, NO, Memr[outdata]) + case QUAD: + call ic_quadi (d, id, n, wts, nimages, npts, + NO, YES, Memr[outdata]) + case NMODEL: + call ic_nmodeli (d, id, n, Memr[nmod], wts, + nimages, npts, NO, YES, Memr[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + 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) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, 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, scales, zeros, wts, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real wts[nimages] # Weights +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, k, npts, fd, stropen(), xt_imgnlr() +pointer sp, d, id, n, m, lflag, v, dbuf +pointer im, buf, xt_opix(), impl1i() +errchk stropen, xt_cpix, xt_opix, xt_imgnlr, impl1i, ic_combiner +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 (v, IM_MAXDIM, TY_LONG) + call amovki (D_ALL, Memi[lflag], nimages) + call amovkl (1, Meml[v], IM_MAXDIM) + + # 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) + call aclrr (Memr[Memi[dbuf+i-1]], npts) + } + } else { + do i = 1, nimages { + im = xt_opix (in[i], i, 1) + if (im != in[i]) { + call salloc (Memi[dbuf+i-1], npts, TY_REAL) + call aclrr (Memr[Memi[dbuf+i-1]], npts) + } + } + call amovki (NULL, Memi[dbuf], nimages) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFFRAC, 0) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + 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, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + 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) + } + if (out[4] != NULL) { + buf = impl1i (out[4]) + call aclri (Memi[buf], npts) + } + if (out[5] != NULL) { + buf = impl1i (out[5]) + call aclri (Memi[buf], npts) + } + if (out[6] != NULL) { + buf = impl1i (out[6]) + call aclri (Memi[buf], npts) + } + + # Do I/O for first input image line. + if (!project) { + do i = 1, nimages { + call xt_imseti (i, "bufsize", bufsize) + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + call xt_cpix (i) + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + + do i = 1, nimages { + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + next + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + next + iferr { + Meml[v+1] = j + j = xt_imgnlr (in[i], i, buf, Meml[v], 1) + } then { + call imseti (im, IM_PIXFD, NULL) + 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, scales, zeros, 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[ARB] # 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(), errcode() +real r, imgetr() +pointer sp, fname, imname, v1, v2, v3, work +pointer outdata, buf, nmod, nm, pms +pointer immap(), impnli() +pointer impnlr(), imgnlr +errchk immap, ic_scale, imgetr, ic_grow, ic_growr, ic_rmasks, ic_emask +errchk ic_gdatar + +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, SUM, QUAD, NMODEL: + if (dowts) + keepids = true + else + keepids = false + case MEDIAN: + dowts = false + keepids = false + } + docombine = true + + # Get noise model parameters. + if (combine==NMODEL) { + call salloc (nmod, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nmod+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nmod+3*(i-1)+2] = r + } + } + } + + # 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 (out[6] != NULL) { + keepids = true + call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) + } + + 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) + } + +# This idea turns out to has a problem with masks are used with wcs offsets. +# the matching of masks to images based on WCS requires access to the WCS +# of the images. For now we drop this idea but maybe a way can be identified +# to know when this is not going to be needed. +# # Reduce header memory use. +# do i = 1, nimages +# call xt_minhdr (i) + + 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, nimages, npts, + YES, YES, Memr[outdata]) + case MEDIAN: + call ic_medianr (d, n, npts, YES, Memr[outdata]) + case SUM: + call ic_averager (d, id, n, wts, nimages, npts, + YES, NO, Memr[outdata]) + case QUAD: + call ic_quadr (d, id, n, wts, nimages, npts, + YES, YES, Memr[outdata]) + case NMODEL: + call ic_nmodelr (d, id, n, Memr[nmod], wts, + nimages, npts, YES, 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]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + 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) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, 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, nimages, npts, + NO, YES, Memr[outdata]) + case MEDIAN: + call ic_medianr (d, n, npts, NO, Memr[outdata]) + case SUM: + call ic_averager (d, id, n, wts, nimages, npts, + NO, NO, Memr[outdata]) + case QUAD: + call ic_quadr (d, id, n, wts, nimages, npts, + NO, YES, Memr[outdata]) + case NMODEL: + call ic_nmodelr (d, id, n, Memr[nmod], wts, + nimages, npts, NO, YES, Memr[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + 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) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, 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, scales, zeros, wts, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real wts[nimages] # Weights +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, k, npts, fd, stropen(), xt_imgnld() +pointer sp, d, id, n, m, lflag, v, dbuf +pointer im, buf, xt_opix(), impl1i() +errchk stropen, xt_cpix, xt_opix, xt_imgnld, impl1i, ic_combined +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 (v, IM_MAXDIM, TY_LONG) + call amovki (D_ALL, Memi[lflag], nimages) + call amovkl (1, Meml[v], IM_MAXDIM) + + # 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) + call aclrd (Memd[Memi[dbuf+i-1]], npts) + } + } else { + do i = 1, nimages { + im = xt_opix (in[i], i, 1) + if (im != in[i]) { + call salloc (Memi[dbuf+i-1], npts, TY_DOUBLE) + call aclrd (Memd[Memi[dbuf+i-1]], npts) + } + } + call amovki (NULL, Memi[dbuf], nimages) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFFRAC, 0) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + 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, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + 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) + } + if (out[4] != NULL) { + buf = impl1i (out[4]) + call aclri (Memi[buf], npts) + } + if (out[5] != NULL) { + buf = impl1i (out[5]) + call aclri (Memi[buf], npts) + } + if (out[6] != NULL) { + buf = impl1i (out[6]) + call aclri (Memi[buf], npts) + } + + # Do I/O for first input image line. + if (!project) { + do i = 1, nimages { + call xt_imseti (i, "bufsize", bufsize) + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + call xt_cpix (i) + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + + do i = 1, nimages { + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + next + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + next + iferr { + Meml[v+1] = j + j = xt_imgnld (in[i], i, buf, Meml[v], 1) + } then { + call imseti (im, IM_PIXFD, NULL) + 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, scales, zeros, 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[ARB] # 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(), errcode() +real r, imgetr() +pointer sp, fname, imname, v1, v2, v3, work +pointer outdata, buf, nmod, nm, pms +pointer immap(), impnli() +pointer impnld(), imgnld +errchk immap, ic_scale, imgetr, ic_grow, ic_growd, ic_rmasks, ic_emask +errchk ic_gdatad + +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, SUM, QUAD, NMODEL: + if (dowts) + keepids = true + else + keepids = false + case MEDIAN: + dowts = false + keepids = false + } + docombine = true + + # Get noise model parameters. + if (combine==NMODEL) { + call salloc (nmod, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nmod+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nmod+3*(i-1)+2] = r + } + } + } + + # 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 (out[6] != NULL) { + keepids = true + call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) + } + + 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) + } + +# This idea turns out to has a problem with masks are used with wcs offsets. +# the matching of masks to images based on WCS requires access to the WCS +# of the images. For now we drop this idea but maybe a way can be identified +# to know when this is not going to be needed. +# # Reduce header memory use. +# do i = 1, nimages +# call xt_minhdr (i) + + 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, nimages, npts, + YES, YES, Memd[outdata]) + case MEDIAN: + call ic_mediand (d, n, npts, YES, Memd[outdata]) + case SUM: + call ic_averaged (d, id, n, wts, nimages, npts, + YES, NO, Memd[outdata]) + case QUAD: + call ic_quadd (d, id, n, wts, nimages, npts, + YES, YES, Memd[outdata]) + case NMODEL: + call ic_nmodeld (d, id, n, Memr[nmod], wts, + nimages, npts, YES, 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]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + 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) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, 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, nimages, npts, + NO, YES, Memd[outdata]) + case MEDIAN: + call ic_mediand (d, n, npts, NO, Memd[outdata]) + case SUM: + call ic_averaged (d, id, n, wts, nimages, npts, + NO, NO, Memd[outdata]) + case QUAD: + call ic_quadd (d, id, n, wts, nimages, npts, + NO, YES, Memd[outdata]) + case NMODEL: + call ic_nmodeld (d, id, n, Memr[nmod], wts, + nimages, npts, NO, YES, Memd[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + 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) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, 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 + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icpclip.x b/pkg/images/immatch/src/imcombine/src/generic/icpclip.x new file mode 100644 index 00000000..3dfe7f48 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icpclip.x @@ -0,0 +1,879 @@ +# 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 = max (0, 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 = max (0, 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 == max (0, 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 (max (0, 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 = max (0, 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 = max (0, 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 == max (0, 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 (max (0, 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 = max (0, 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 = max (0, 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 == max (0, 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 (max (0, 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 = max (0, 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 = max (0, 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 == max (0, 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 (max (0, 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/images/immatch/src/imcombine/src/generic/icquad.x b/pkg/images/immatch/src/imcombine/src/generic/icquad.x new file mode 100644 index 00000000..4ba5eb14 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icquad.x @@ -0,0 +1,476 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> +include "../icombine.h" +include "../icmask.h" + + +# IC_QUAD -- Compute the quadrature average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_quads (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +real sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum 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/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = Mems[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + do j = 2, n[i] { + val = Mems[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val * wt) ** 2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = Mems[d[1]+k] + sum = val**2 + do j = 2, n[i] { + val = Mems[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Mems[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + sumwt = wt + do j = 2, n1 { + val = Mems[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val* wt) ** 2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = Mems[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Mems[d[j]+k] + sum = sum + val**2 + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Mems[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Mems[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_QUAD -- Compute the quadrature average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_quadi (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +real sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum 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/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = Memi[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + do j = 2, n[i] { + val = Memi[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val * wt) ** 2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = Memi[d[1]+k] + sum = val**2 + do j = 2, n[i] { + val = Memi[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Memi[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + sumwt = wt + do j = 2, n1 { + val = Memi[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val* wt) ** 2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = Memi[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Memi[d[j]+k] + sum = sum + val**2 + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Memi[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Memi[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_QUAD -- Compute the quadrature average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_quadr (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +real sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum 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/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = Memr[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + do j = 2, n[i] { + val = Memr[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val * wt) ** 2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = Memr[d[1]+k] + sum = val**2 + do j = 2, n[i] { + val = Memr[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Memr[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + sumwt = wt + do j = 2, n1 { + val = Memr[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val* wt) ** 2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = Memr[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Memr[d[j]+k] + sum = sum + val**2 + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Memr[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Memr[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_QUAD -- Compute the quadrature average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_quadd (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +double average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +double sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum 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/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = Memd[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + do j = 2, n[i] { + val = Memd[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val * wt) ** 2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = Memd[d[1]+k] + sum = val**2 + do j = 2, n[i] { + val = Memd[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Memd[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + sumwt = wt + do j = 2, n1 { + val = Memd[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val* wt) ** 2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = Memd[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Memd[d[j]+k] + sum = sum + val**2 + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Memd[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Memd[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icsclip.x b/pkg/images/immatch/src/imcombine/src/generic/icsclip.x new file mode 100644 index 00000000..2f2ac17e --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icsclip.x @@ -0,0 +1,1923 @@ +# 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, 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 (max (0, 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/images/immatch/src/imcombine/src/generic/icsigma.x b/pkg/images/immatch/src/imcombine/src/generic/icsigma.x new file mode 100644 index 00000000..b9c9a781 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icsigma.x @@ -0,0 +1,434 @@ +# 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 + } + if (sumwt > 0) + sigma[i] = sqrt (sum / sumwt * sigcor) + else { + sum = (Mems[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Mems[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum / n1 * 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 + } + if (sumwt > 0) + sigma[i] = sqrt (sum / sumwt * sigcor) + else { + sum = (Memi[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memi[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum / n1 * 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 + } + if (sumwt > 0) + sigma[i] = sqrt (sum / sumwt * sigcor) + else { + sum = (Memr[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memr[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum / n1 * 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 + } + if (sumwt > 0) + sigma[i] = sqrt (sum / sumwt * sigcor) + else { + sum = (Memd[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memd[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum / n1 * 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/images/immatch/src/imcombine/src/generic/icsort.x b/pkg/images/immatch/src/imcombine/src/generic/icsort.x new file mode 100644 index 00000000..3ec1d27e --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/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/images/immatch/src/imcombine/src/generic/icstat.x b/pkg/images/immatch/src/imcombine/src/generic/icstat.x new file mode 100644 index 00000000..3a0ed49c --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icstat.x @@ -0,0 +1,892 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + +define NMAX 100000 # 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() + +real asums() +short ic_modes() + +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, nimages, 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) + } + + # Close mask until it is needed again. + call ic_mclose1 (image, nimages) + + 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.7 # 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() + +real asumi() +int ic_modei() + +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, nimages, 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) + } + + # Close mask until it is needed again. + call ic_mclose1 (image, nimages) + + 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.7 # 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 asumr() +real ic_moder() + +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, nimages, 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) + } + + # Close mask until it is needed again. + call ic_mclose1 (image, nimages) + + 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.7 # 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 asumd() +double ic_moded() + +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, nimages, 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) + } + + # Close mask until it is needed again. + call ic_mclose1 (image, nimages) + + 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.7 # 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/images/immatch/src/imcombine/src/generic/mkpkg b/pkg/images/immatch/src/imcombine/src/generic/mkpkg new file mode 100644 index 00000000..af2fd0a8 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/mkpkg @@ -0,0 +1,27 @@ +# Make IMCOMBINE. + +$checkout libimc.a lib$ +$update libimc.a +$checkin libimc.a lib$ +$exit + +libimc.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 + icnmodel.x ../icombine.com ../icombine.h <imhdr.h> + icomb.x ../icombine.com ../icombine.h <error.h> <imhdr.h>\ + <imset.h> <mach.h> <pmset.h> <syserr.h> + icpclip.x ../icombine.com ../icombine.h + icquad.x ../icombine.com ../icombine.h <imhdr.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> + + xtimmap.x xtimmap.com <config.h> <error.h> <imhdr.h> <imset.h> + ; diff --git a/pkg/images/immatch/src/imcombine/src/generic/xtimmap.com b/pkg/images/immatch/src/imcombine/src/generic/xtimmap.com new file mode 100644 index 00000000..57fcb8a0 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/xtimmap.com @@ -0,0 +1,9 @@ +int option +int nopen +int nopenpix +int nalloc +int last_flag +int min_open +int max_openim +pointer ims +common /xtimmapcom/ option, ims, nopen, nopenpix, nalloc, last_flag, min_open, max_openim diff --git a/pkg/images/immatch/src/imcombine/src/generic/xtimmap.x b/pkg/images/immatch/src/imcombine/src/generic/xtimmap.x new file mode 100644 index 00000000..fcc53124 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/xtimmap.x @@ -0,0 +1,1207 @@ +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imset.h> +include <config.h> + +# The following is for compiling under V2.11. +define IM_BUFFRAC IM_BUFSIZE +include <imset.h> + +define VERBOSE false + +# These routines maintain an arbitrary number of indexed "open" images which +# must be READ_ONLY. The calling program may use the returned pointer for +# header accesses but must call xt_opix before I/O. Subsequent calls to +# xt_opix may invalidate the pointer. The xt_imunmap call will free memory. + +define MAX_OPENIM (LAST_FD-16) # Maximum images kept open +define MAX_OPENPIX 45 # Maximum pixel files kept open + +define XT_SZIMNAME 299 # Size of IMNAME string +define XT_LEN 179 # Structure length +define XT_IMNAME Memc[P2C($1)] # Image name +define XT_ARG Memi[$1+150] # IMMAP header argument +define XT_IM Memi[$1+151] # IMIO pointer +define XT_HDR Memi[$1+152] # Copy of IMIO pointer +define XT_CLOSEFD Memi[$1+153] # Close FD? +define XT_FLAG Memi[$1+154] # Flag +define XT_BUFSIZE Memi[$1+155] # Buffer size +define XT_BUF Memi[$1+156] # Data buffer +define XT_BTYPE Memi[$1+157] # Data buffer type +define XT_VS Memi[$1+157+$2] # Start vector (10) +define XT_VE Memi[$1+167+$2] # End vector (10) + +# Options +define XT_MAPUNMAP 1 # Map and unmap images. + +# XT_IMMAP -- Map an image and save it as an indexed open image. +# The returned pointer may be used for header access but not I/O. +# The indexed image is closed by xt_imunmap. + +pointer procedure xt_immap (imname, acmode, hdr_arg, index, retry) + +char imname[ARB] #I Image name +int acmode #I Access mode +int hdr_arg #I Header argument +int index #I Save index +int retry #I Retry counter +pointer im #O Image pointer (returned) + +int i, envgeti() +pointer xt, xt_opix() +errchk xt_opix + +int first_time +data first_time /YES/ + +include "xtimmap.com" + +begin + if (acmode != READ_ONLY) + call error (1, "XT_IMMAP: Only READ_ONLY allowed") + + # Set maximum number of open images based on retry. + if (retry > 0) + max_openim = min (1024, MAX_OPENIM) / retry + else + max_openim = MAX_OPENIM + + # Initialize once per process. + if (first_time == YES) { + iferr (option = envgeti ("imcombine_option")) + option = 1 + min_open = 1 + nopen = 0 + nopenpix = 0 + nalloc = max_openim + call calloc (ims, nalloc, TY_POINTER) + first_time = NO + } + + # Free image if needed. + call xt_imunmap (NULL, index) + + # Allocate structure. + if (index > nalloc) { + i = nalloc + nalloc = index + max_openim + call realloc (ims, nalloc, TY_STRUCT) + call amovki (NULL, Memi[ims+i], nalloc-i) + } + call calloc (xt, XT_LEN, TY_STRUCT) + Memi[ims+index-1] = xt + + # Initialize. + call strcpy (imname, XT_IMNAME(xt), XT_SZIMNAME) + XT_ARG(xt) = hdr_arg + XT_IM(xt) = NULL + XT_HDR(xt) = NULL + + # Open image. + last_flag = 0 + im = xt_opix (NULL, index, 0) + + # Make copy of IMIO pointer for header keyword access. + call malloc (XT_HDR(xt), LEN_IMDES+IM_HDRLEN(im)+1, TY_STRUCT) + call amovi (Memi[im], Memi[XT_HDR(xt)], LEN_IMDES) + call amovi (IM_MAGIC(im), IM_MAGIC(XT_HDR(xt)), IM_HDRLEN(im)+1) + + return (XT_HDR(xt)) +end + + +# XT_OPIX -- Open the image for I/O. +# If the image has not been mapped return the default pointer. + +pointer procedure xt_opix (imdef, index, flag) + +int index #I index +pointer imdef #I Default pointer +int flag #I Flag + +int i, open(), imstati() +pointer im, xt, xt1, immap() +errchk open, immap, imunmap + +include "xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imdef) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + if (VERBOSE) { + call eprintf ("%d: xt_opix imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Return pointer for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (im) + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= max_openim) { + if (option == XT_MAPUNMAP || flag == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + if (VERBOSE) { + call eprintf ("%d: imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + if (VERBOSE) { + call eprintf ("%d: xt_opix immap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + if (!IS_INDEFI(XT_BUFSIZE(xt))) + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + else + XT_BUFSIZE(xt) = imstati (im, IM_BUFSIZE) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (im) +end + + +# XT_CPIX -- Close image. + +procedure xt_cpix (index) + +int index #I index + +pointer xt +errchk imunmap + +include "xtimmap.com" + +begin + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + if (xt == NULL) + return + + if (XT_IM(xt) != NULL) { + if (VERBOSE) { + call eprintf ("%d: xt_cpix imunmap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + call imunmap (XT_IM(xt)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt) == NO) + nopenpix = nopenpix - 1 + } + call mfree (XT_BUF(xt), XT_BTYPE(xt)) +end + + +# XT_IMSETI -- Set IMIO value. + +procedure xt_imseti (index, param, value) + +int index #I index +int param #I IMSET parameter +int value #I Value + +pointer xt +bool streq() + +include "xtimmap.com" + +begin + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + if (xt == NULL) { + if (streq (param, "option")) + option = value + } else { + if (streq (param, "bufsize")) { + XT_BUFSIZE(xt) = value + if (XT_IM(xt) != NULL) { + call imseti (XT_IM(xt), IM_BUFFRAC, 0) + call imseti (XT_IM(xt), IM_BUFSIZE, value) + } + } + } +end + + +# XT_IMUNMAP -- Unmap indexed open image. +# The header pointer is set to NULL to indicate the image has been closed. + +procedure xt_imunmap (im, index) + +int im #U IMIO header pointer +int index #I index + +pointer xt +errchk imunmap + +include "xtimmap.com" + +begin + # Check for an indexed image. If it is not unmap the pointer + # as a regular IMIO pointer. + + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + if (xt == NULL) { + if (im != NULL) + call imunmap (im) + return + } + + # Close indexed image. + if (XT_IM(xt) != NULL) { + if (VERBOSE) { + call eprintf ("%d: xt_imunmap imunmap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + iferr (call imunmap (XT_IM(xt))) { + XT_IM(xt) = NULL + call erract (EA_WARN) + } + nopen = nopen - 1 + if (XT_CLOSEFD(xt) == NO) + nopenpix = nopenpix - 1 + if (index == min_open) + min_open = 1 + } + + # Free any buffered memory. + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + + # Free header pointer. Note that if the supplied pointer is not + # header pointer then it is not set to NULL. + if (XT_HDR(xt) == im) + im = NULL + call mfree (XT_HDR(xt), TY_STRUCT) + + # Free save structure. + call mfree (Memi[ims+index-1], TY_STRUCT) + Memi[ims+index-1] = NULL +end + + +# XT_MINHDR -- Minimize header assuming keywords will not be accessed. + +procedure xt_minhdr (index) + +int index #I index + +pointer xt +errchk realloc + +include "xtimmap.com" + +begin + # Check for an indexed image. If it is not unmap the pointer + # as a regular IMIO pointer. + + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + if (xt == NULL) + return + + # Minimize header pointer. + if (VERBOSE) { + call eprintf ("%d: xt_minhdr %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + call realloc (XT_HDR(xt), IMU+1, TY_STRUCT) + if (XT_IM(xt) != NULL) + call realloc (XT_IM(xt), IMU+1, TY_STRUCT) +end + + +# XT_REINDEX -- Reindex open images. +# This is used when some images are closed by xt_imunmap. It is up to +# the calling program to reindex the header pointers and to subsequently +# use the new index values. + +procedure xt_reindex () + +int old, new + +include "xtimmap.com" + +begin + new = 0 + do old = 0, nalloc-1 { + if (Memi[ims+old] == NULL) + next + Memi[ims+new] = Memi[ims+old] + new = new + 1 + } + do old = new, nalloc-1 + Memi[ims+old] = NULL +end + + + +# XT_IMGNL -- Return the next line for the indexed image. +# Possibly unmap another image if too many files are open. +# Buffer data when an image is unmmaped to minimize the mapping of images. +# If the requested index has not been mapped use the default pointer. + +int procedure xt_imgnls (imdef, index, buf, v, flag) + +pointer imdef #I Default pointer +int index #I index +pointer buf #O Data buffer +long v[ARB] #I Line vector +int flag #I Flag (=output line) + +int i, j, nc, nl, open(), imgnls(), sizeof(), imloop() +pointer im, xt, xt1, ptr, immap(), imggss() +errchk open, immap, imgnls, imggss, imunmap + +long unit_v[IM_MAXDIM] +data unit_v /IM_MAXDIM * 1/ + +include "xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imgnls (imdef, buf, v)) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Use IMIO for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (imgnls (im, buf, v)) + } + + # If the image is not currently mapped use the stored header. + im = XT_HDR(xt) + + # Check for EOF. + i = IM_NDIM(im) + if (v[i] > IM_LEN(im,i)) + return (EOF) + + # Check for buffered data. + if (XT_BUF(xt) != NULL) { + if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { + if (XT_BTYPE(xt) != TY_SHORT) + call error (1, "Cannot mix data types") + nc = IM_LEN(im,1) + buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) + XT_FLAG(xt) = flag + if (i == 1) + v[1] = nc + 1 + else + j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) + return (nc) + } + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= max_openim) { + if (option == XT_MAPUNMAP || v[2] == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + + # Buffer some number of lines. + nl = XT_BUFSIZE(xt1) / sizeof (TY_SHORT) / IM_LEN(im,1) + if (nl > 1) { + nc = IM_LEN(im,1) + call amovl (v, XT_VS(xt1,1), IM_MAXDIM) + call amovl (v, XT_VE(xt1,1), IM_MAXDIM) + XT_VS(xt1,1) = 1 + XT_VE(xt1,1) = nc + XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) + nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 + XT_BTYPE(xt1) = TY_SHORT + call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) + ptr = imggss (im, XT_VS(xt1,1), XT_VE(xt1,1), + IM_NDIM(im)) + call amovs (Mems[ptr], Mems[XT_BUF(xt1)], nl*nc) + } + + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + if (XT_IM(xt1) == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + if (VERBOSE) { + call eprintf ("%d: xt_imgnl immap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (imgnls (im, buf, v)) +end + +# XT_IMGNL -- Return the next line for the indexed image. +# Possibly unmap another image if too many files are open. +# Buffer data when an image is unmmaped to minimize the mapping of images. +# If the requested index has not been mapped use the default pointer. + +int procedure xt_imgnli (imdef, index, buf, v, flag) + +pointer imdef #I Default pointer +int index #I index +pointer buf #O Data buffer +long v[ARB] #I Line vector +int flag #I Flag (=output line) + +int i, j, nc, nl, open(), imgnli(), sizeof(), imloop() +pointer im, xt, xt1, ptr, immap(), imggsi() +errchk open, immap, imgnli, imggsi, imunmap + +long unit_v[IM_MAXDIM] +data unit_v /IM_MAXDIM * 1/ + +include "xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imgnli (imdef, buf, v)) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Use IMIO for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (imgnli (im, buf, v)) + } + + # If the image is not currently mapped use the stored header. + im = XT_HDR(xt) + + # Check for EOF. + i = IM_NDIM(im) + if (v[i] > IM_LEN(im,i)) + return (EOF) + + # Check for buffered data. + if (XT_BUF(xt) != NULL) { + if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { + if (XT_BTYPE(xt) != TY_INT) + call error (1, "Cannot mix data types") + nc = IM_LEN(im,1) + buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) + XT_FLAG(xt) = flag + if (i == 1) + v[1] = nc + 1 + else + j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) + return (nc) + } + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= max_openim) { + if (option == XT_MAPUNMAP || v[2] == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + + # Buffer some number of lines. + nl = XT_BUFSIZE(xt1) / sizeof (TY_INT) / IM_LEN(im,1) + if (nl > 1) { + nc = IM_LEN(im,1) + call amovl (v, XT_VS(xt1,1), IM_MAXDIM) + call amovl (v, XT_VE(xt1,1), IM_MAXDIM) + XT_VS(xt1,1) = 1 + XT_VE(xt1,1) = nc + XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) + nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 + XT_BTYPE(xt1) = TY_INT + call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) + ptr = imggsi (im, XT_VS(xt1,1), XT_VE(xt1,1), + IM_NDIM(im)) + call amovi (Memi[ptr], Memi[XT_BUF(xt1)], nl*nc) + } + + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + if (XT_IM(xt1) == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + if (VERBOSE) { + call eprintf ("%d: xt_imgnl immap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (imgnli (im, buf, v)) +end + +# XT_IMGNL -- Return the next line for the indexed image. +# Possibly unmap another image if too many files are open. +# Buffer data when an image is unmmaped to minimize the mapping of images. +# If the requested index has not been mapped use the default pointer. + +int procedure xt_imgnlr (imdef, index, buf, v, flag) + +pointer imdef #I Default pointer +int index #I index +pointer buf #O Data buffer +long v[ARB] #I Line vector +int flag #I Flag (=output line) + +int i, j, nc, nl, open(), imgnlr(), sizeof(), imloop() +pointer im, xt, xt1, ptr, immap(), imggsr() +errchk open, immap, imgnlr, imggsr, imunmap + +long unit_v[IM_MAXDIM] +data unit_v /IM_MAXDIM * 1/ + +include "xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imgnlr (imdef, buf, v)) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Use IMIO for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (imgnlr (im, buf, v)) + } + + # If the image is not currently mapped use the stored header. + im = XT_HDR(xt) + + # Check for EOF. + i = IM_NDIM(im) + if (v[i] > IM_LEN(im,i)) + return (EOF) + + # Check for buffered data. + if (XT_BUF(xt) != NULL) { + if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { + if (XT_BTYPE(xt) != TY_REAL) + call error (1, "Cannot mix data types") + nc = IM_LEN(im,1) + buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) + XT_FLAG(xt) = flag + if (i == 1) + v[1] = nc + 1 + else + j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) + return (nc) + } + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= max_openim) { + if (option == XT_MAPUNMAP || v[2] == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + + # Buffer some number of lines. + nl = XT_BUFSIZE(xt1) / sizeof (TY_REAL) / IM_LEN(im,1) + if (nl > 1) { + nc = IM_LEN(im,1) + call amovl (v, XT_VS(xt1,1), IM_MAXDIM) + call amovl (v, XT_VE(xt1,1), IM_MAXDIM) + XT_VS(xt1,1) = 1 + XT_VE(xt1,1) = nc + XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) + nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 + XT_BTYPE(xt1) = TY_REAL + call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) + ptr = imggsr (im, XT_VS(xt1,1), XT_VE(xt1,1), + IM_NDIM(im)) + call amovr (Memr[ptr], Memr[XT_BUF(xt1)], nl*nc) + } + + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + if (XT_IM(xt1) == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + if (VERBOSE) { + call eprintf ("%d: xt_imgnl immap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (imgnlr (im, buf, v)) +end + +# XT_IMGNL -- Return the next line for the indexed image. +# Possibly unmap another image if too many files are open. +# Buffer data when an image is unmmaped to minimize the mapping of images. +# If the requested index has not been mapped use the default pointer. + +int procedure xt_imgnld (imdef, index, buf, v, flag) + +pointer imdef #I Default pointer +int index #I index +pointer buf #O Data buffer +long v[ARB] #I Line vector +int flag #I Flag (=output line) + +int i, j, nc, nl, open(), imgnld(), sizeof(), imloop() +pointer im, xt, xt1, ptr, immap(), imggsd() +errchk open, immap, imgnld, imggsd, imunmap + +long unit_v[IM_MAXDIM] +data unit_v /IM_MAXDIM * 1/ + +include "xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imgnld (imdef, buf, v)) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Use IMIO for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (imgnld (im, buf, v)) + } + + # If the image is not currently mapped use the stored header. + im = XT_HDR(xt) + + # Check for EOF. + i = IM_NDIM(im) + if (v[i] > IM_LEN(im,i)) + return (EOF) + + # Check for buffered data. + if (XT_BUF(xt) != NULL) { + if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { + if (XT_BTYPE(xt) != TY_DOUBLE) + call error (1, "Cannot mix data types") + nc = IM_LEN(im,1) + buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) + XT_FLAG(xt) = flag + if (i == 1) + v[1] = nc + 1 + else + j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) + return (nc) + } + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= max_openim) { + if (option == XT_MAPUNMAP || v[2] == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + + # Buffer some number of lines. + nl = XT_BUFSIZE(xt1) / sizeof (TY_DOUBLE) / IM_LEN(im,1) + if (nl > 1) { + nc = IM_LEN(im,1) + call amovl (v, XT_VS(xt1,1), IM_MAXDIM) + call amovl (v, XT_VE(xt1,1), IM_MAXDIM) + XT_VS(xt1,1) = 1 + XT_VE(xt1,1) = nc + XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) + nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 + XT_BTYPE(xt1) = TY_DOUBLE + call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) + ptr = imggsd (im, XT_VS(xt1,1), XT_VE(xt1,1), + IM_NDIM(im)) + call amovd (Memd[ptr], Memd[XT_BUF(xt1)], nl*nc) + } + + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + if (XT_IM(xt1) == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + if (VERBOSE) { + call eprintf ("%d: xt_imgnl immap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (imgnld (im, buf, v)) +end + diff --git a/pkg/images/immatch/src/imcombine/src/icaclip.gx b/pkg/images/immatch/src/imcombine/src/icaclip.gx new file mode 100644 index 00000000..de3b04d6 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icaclip.gx @@ -0,0 +1,575 @@ +# 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 = max (0, n[1]) + s = 0. + n2 = 0 + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 = max (0, 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 (max (0, 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, sig, r, s, s1, one +data one /1.0/ +$else +PIXEL med, low, high, sig, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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) + sig = sqrt (s / (n2 - 1)) + else { + call sfree (sp) + return + } + + # Compute individual sigmas and iteratively clip. + do i = 1, npts { + k = i - 1 + n1 = max (0, 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) && sig > 0.) { + if (doscale1) { + for (; nl <= nh; nl = nl + 1) { + l = Memi[m[nl]+k] + s1 = sig * 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 = sig * 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 = sig * sqrt (max (one, med)) + for (; nl <= nh; 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 == max (0, 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 (max (0, 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/images/immatch/src/imcombine/src/icaverage.gx b/pkg/images/immatch/src/imcombine/src/icaverage.gx new file mode 100644 index 00000000..a474bb9d --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icaverage.gx @@ -0,0 +1,120 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> +include "../icombine.h" +include "../icmask.h" + +$for (sird) +# IC_AVERAGE -- Compute the average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_average$t (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +$if (datatype == sil) +real average[npts] # Average (returned) +$else +PIXEL average[npts] # Average (returned) +$endif + +int i, j, k, n1 +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/sum 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/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + 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] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Mem$t[d[1]+k] * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + Mem$t[d[j]+k] * wt + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sum / sumwt + else { + sum = Mem$t[d[1]+k] + do j = 2, n1 + sum = sum + Mem$t[d[j]+k] + average[i] = sum / n1 + } + } else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + sum = Mem$t[d[1]+k] + do j = 2, n1 + sum = sum + Mem$t[d[j]+k] + if (doaverage == YES) + average[i] = sum / n1 + else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } + } +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/iccclip.gx b/pkg/images/immatch/src/imcombine/src/iccclip.gx new file mode 100644 index 00000000..5b1b724e --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, 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 (max (0, 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/images/immatch/src/imcombine/src/icemask.x b/pkg/images/immatch/src/imcombine/src/icemask.x new file mode 100644 index 00000000..e29edd5e --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icemask.x @@ -0,0 +1,115 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> + + +# IC_EMASK -- Create exposure mask. + +procedure ic_emask (pm, v, id, nimages, n, wts, npts) + +pointer pm #I Pixel mask +long v[ARB] #I Output vector +pointer id[nimages] #I Image id pointers +int nimages #I Number of images +int n[npts] #I Number of good pixels +real wts[npts] #I Weights +int npts #I Number of output pixels per line + +int i, j, k, impnli() +real exp +pointer buf +errchk impnli + +pointer exps # Exposure times +pointer ev # IMIO coordinate vector +real ezero # Integer to real zero +real escale # Integer to real scale +int einit # Initialization flag +common /emask/ exps, ev, ezero, escale, einit + +begin + # Write scaling factors to the header. + if (einit == NO) { + if (ezero != 0. || escale != 1.) { + call imaddr (pm, "MASKZERO", ezero) + call imaddr (pm, "MASKSCAL", escale) + } + einit = YES + } + + call amovl (v, Meml[ev], IM_MAXDIM) + i = impnli (pm, buf, Meml[ev]) + call aclri (Memi[buf], npts) + do i = 1, npts { + exp = 0. + do j = 1, n[i] { + k = Memi[id[j]+i-1] + if (wts[k] > 0.) + exp = exp + Memr[exps+k-1] + } + Memi[buf] = nint((exp-ezero)/escale) + buf = buf + 1 + } +end + + +# IC_EINIT -- Initialize exposure mask. + +procedure ic_einit (in, nimages, key, default, maxval) + +int in[nimages] #I Image pointers +int nimages #I Number of images +char key[ARB] #I Exposure time keyword +real default #I Default exposure time +int maxval #I Maximum mask value + +int i +real exp, emin, emax, efrac, imgetr() + +pointer exps # Exposure times +pointer ev # IMIO coordinate vector +real ezero # Integer to real zero +real escale # Integer to real scale +int einit # Initialization flag +common /emask/ exps, ev, ezero, escale, einit + +begin + call malloc (ev, IM_MAXDIM, TY_LONG) + call malloc (exps, nimages, TY_REAL) + + emax = 0. + emin = MAX_REAL + efrac = 0 + do i = 1, nimages { + iferr (exp = imgetr (in[i], key)) + exp = default + exp = max (0., exp) + emax = emax + exp + if (exp > 0.) + emin = min (exp, emin) + efrac = max (abs(exp-nint(exp)), efrac) + Memr[exps+i-1] = exp + } + + # Set scaling. + ezero = 0. + escale = 1. + if (emin < 1.) { + escale = emin + emin = emin / escale + emax = emax / escale + } else if (emin == MAX_REAL) + emin = 0. + if (efrac > 0.001 && emax-emin < 1000.) { + escale = escale / 1000. + emin = emin * 1000. + emax = emax * 1000. + } + while (emax > maxval) { + escale = escale * 10. + emin = emin / 10. + emax = emax / 10. + } + einit = NO +end diff --git a/pkg/images/immatch/src/imcombine/src/icgdata.gx b/pkg/images/immatch/src/imcombine/src/icgdata.gx new file mode 100644 index 00000000..a05f5646 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icgdata.gx @@ -0,0 +1,396 @@ +# 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[ARB] # 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 + +PIXEL temp +int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, mtype, xt_imgnl$t() +real a, b +pointer buf, dp, ip, mp +errchk xt_cpix, xt_imgnl$t + +PIXEL max_pixel +$if (datatype == s) +data max_pixel/MAX_SHORT/ +$else $if (datatype == i) +data max_pixel/MAX_INT/ +$else $if (datatype == r) +data max_pixel/MAX_REAL/ +$else +data max_pixel/MAX_DOUBLE/ +$endif $endif $endif + +include "../icombine.com" + +begin + # Get masks and return if there is no data + call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) + if (dflag == D_NONE) { + call aclri (n, npts) + return + } + + # Close images which are not needed. + nout = IM_LEN(out[1],1) + ndim = IM_NDIM(out[1]) + if (!project && ndim < 3) { + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + call xt_cpix (i) + if (ndim > 1) { + j = v1[2] - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + } + } + + # Get data and fill data buffers. Correct for offsets if needed. + 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 = xt_imgnl$t (in[i], i, d[i], v2, v1[2]) + } else { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) { + lflag[i] = D_NONE + next + } + k = 1 + j - offsets[i,1] + v2[1] = k + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + if (lflag[i] == D_NONE) + next + if (project) + v2[ndim+1] = i + l = xt_imgnl$t (in[i], i, buf, v2, v1[2]) + call amov$t (Mem$t[buf+k-1], Mem$t[dbuf[i]+j], npix) + d[i] = dbuf[i] + } + } + + # Set values to max_pixel if needed. + if (mtype == M_NOVAL) { + do i = 1, nimages { + dp = d[i]; mp = m[i] + if (lflag[i] == D_NONE || dp == NULL) + next + else if (lflag[i] == D_MIX) { + do j = 1, npts { + if (Memi[mp] == 1) + Mem$t[dp] = max_pixel + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + a = Mem$t[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + + lflag[i] = D_MIX + dflag = D_MIX + } + dp = dp + 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 + } + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) { + a = Mem$t[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + dflag = D_MIX + } + } + dp = dp + 1 + mp = mp + 1 + } + + # Check for completely empty lines + lflag[i] = D_NONE + mp = m[i] + n1 - 1 + do j = n1, n2 { + 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 { + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + Mem$t[dp] = Mem$t[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) + 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 + } + } + do i = nused+1, nimages + d[i] = NULL + 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] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + ip = id[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + Memi[ip] = l + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Mem$t[d[k]+j-1] + Mem$t[d[k]+j-1] = Mem$t[dp] + Mem$t[dp] = temp + Memi[ip] = Memi[id[k]+j-1] + Memi[id[k]+j-1] = l + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } else + Memi[ip] = 0 + 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 { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Mem$t[d[k]+j-1] + Mem$t[d[k]+j-1] = Mem$t[dp] + Mem$t[dp] = temp + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Sort the pixels and IDs if needed + if (mclip) { + call malloc (dp, nused, TY_PIXEL) + if (keepids) { + call malloc (ip, nused, 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) + } + + # If no good pixels set the number of usable values as -n and + # shift them to lower values. + if (mtype == M_NOVAL) { + if (keepids) { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + ip = id[i] + j - 1 + if (Mem$t[dp] < max_pixel) { + 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] = Memi[ip] + } + } + } + } + } else { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + if (Mem$t[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) + Mem$t[d[k]+j-1] = Mem$t[dp] + } + } + } + } + } +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icgrow.gx b/pkg/images/immatch/src/imcombine/src/icgrow.gx new file mode 100644 index 00000000..caf7dd29 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icgrow.gx @@ -0,0 +1,135 @@ +# 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, ncompress, 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) + ncompress = 0 + } + 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) + if (l > 0) { + v[2] = line + l + if (v[2] <= nl) + call pmplpi (pm, v, buf[1,i], 1, npts, rop) + } + } + } + v[2] = line + + if (ncompress > 10) { + do i = 1, nimages { + pm = Memi[pms+i-1] + call pm_compress (pm) + } + ncompress = 0 + } else + ncompress = ncompress + 1 +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/images/immatch/src/imcombine/src/icgscale.x b/pkg/images/immatch/src/imcombine/src/icgscale.x new file mode 100644 index 00000000..570697ad --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icgscale.x @@ -0,0 +1,88 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "icombine.h" + + +# IC_GSCALE -- Get scale values as directed by CL parameter. +# Only those values which are INDEF are changed. +# 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 + do i = 1, nimages + if (IS_INDEFR(values[i])) + break + if (i <= nimages) { + 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 + if (IS_INDEFR(values[i])) + 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 { + if (IS_INDEFR(values[i])) + 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 + if (IS_INDEFR(values[i])) + values[i] = max (0.001, exptime[i]) + } + + return (type) +end diff --git a/pkg/images/immatch/src/imcombine/src/ichdr.x b/pkg/images/immatch/src/imcombine/src/ichdr.x new file mode 100644 index 00000000..b4d925c1 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/ichdr.x @@ -0,0 +1,72 @@ +include <imset.h> + + +# IC_HDR -- Set output header. + +procedure ic_hdr (in, out, nimages) + +pointer in[nimages] #I Input images +pointer out[ARB] #I Output images +int nimages #I Number of images + +int i, j, imgnfn(), nowhite(), strldxs() +pointer sp, inkey, key, str, list, imofnlu() +bool streq() + +begin + call smark (sp) + call salloc (inkey, SZ_FNAME, TY_CHAR) + call salloc (key, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + call clgstr ("imcmb", Memc[inkey], SZ_FNAME) + i = nowhite (Memc[inkey], Memc[inkey], SZ_FNAME) + + if (i > 0 && streq (Memc[inkey], "$I")) { + # Set new PROCID. + call xt_procid (out) + + # Set input PROCIDs. + if (nimages < 100) { + list = imofnlu (out, "PROCID[0-9][0-9]") + while (imgnfn (list, Memc[key], SZ_LINE) != EOF) + call imdelf (out, Memc[key]) + call imcfnl (list) + do i = 1, nimages { + call sprintf (Memc[key], 8, "PROCID%02d") + call pargi (i) + iferr (call imgstr (in[i], "PROCID", Memc[str], SZ_LINE)) { + iferr (call imgstr (in[i], "OBSID", Memc[str], SZ_LINE)) + Memc[str] = EOS + } + if (Memc[str] != EOS) + call imastr (out, Memc[key], Memc[str]) + } + } + } + + if (i > 0 && nimages < 1000) { + list = imofnlu (out, "IMCMB[0-9][0-9][0-9]") + while (imgnfn (list, Memc[key], SZ_LINE) != EOF) + call imdelf (out, Memc[key]) + call imcfnl (list) + do i = 1, nimages { + if (streq (Memc[inkey], "$I")) { + call imstats (in[i], IM_IMAGENAME, Memc[str], SZ_LINE) + j = strldxs ("/$", Memc[str]) + if (j > 0) + call strcpy (Memc[str+j], Memc[str], SZ_LINE) + } else { + iferr (call imgstr (in[i], Memc[inkey], Memc[str], SZ_LINE)) + Memc[str] = EOS + } + if (Memc[str] == EOS) + next + call sprintf (Memc[key], SZ_LINE, "IMCMB%03d") + call pargi (i) + call imastr (out, Memc[key], Memc[str]) + } + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/imcombine/src/icimstack.x b/pkg/images/immatch/src/imcombine/src/icimstack.x new file mode 100644 index 00000000..d5628694 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icimstack.x @@ -0,0 +1,186 @@ +# 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, mask) + +int list #I List of images +char output[ARB] #I Name of output image +char mask[ARB] #I Name of output mask + +int i, j, npix +long line_in[IM_MAXDIM], line_out[IM_MAXDIM], line_outbpm[IM_MAXDIM] +pointer sp, input, bpmname, key, in, out, inbpm, outbpm, buf_in, buf_out, ptr + +int imtgetim(), imtlen(), errget() +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx() +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() +pointer immap(), pm_newmask() +errchk immap +errchk imgnls, imgnli, imgnll, imgnlr, imgnld, imgnlx +errchk impnls, impnli, impnll, impnlr, impnld, impnlx + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (bpmname, SZ_FNAME, TY_CHAR) + call salloc (key, SZ_FNAME, TY_CHAR) + + iferr { + # Add each input image to the output image. + out = NULL; outbpm = NULL + i = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + + i = i + 1 + in = NULL; inbpm = 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) + + if (mask[1] != EOS) { + ptr = immap (mask, NEW_COPY, in) + outbpm = ptr + IM_NDIM(outbpm) = IM_NDIM(outbpm) + 1 + IM_LEN(outbpm, IM_NDIM(outbpm)) = imtlen (list) + call amovkl (long(1), line_outbpm, 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) + } + } + + # Copy mask. + if (mask[1] != EOS) { + iferr (call imgstr (in, "bpm", Memc[bpmname], SZ_FNAME)) { + Memc[bpmname] = EOS + ptr = pm_newmask (in, 27) + } else + ptr = immap (Memc[bpmname], READ_ONLY, 0) + inbpm = ptr + + if (IM_NDIM(inbpm) != IM_NDIM(outbpm) - 1) + call error (0, "Input images not consistent") + do j = 1, IM_NDIM(inbpm) { + if (IM_LEN(inbpm, j) != IM_LEN(outbpm, j)) + call error (0, "Masks not consistent") + } + + call amovkl (long(1), line_in, IM_MAXDIM) + while (imgnli (inbpm, buf_in, line_in) != EOF) { + if (impnli (outbpm, buf_out, line_outbpm) == EOF) + call error (0, "Error writing output mask") + call amovi (Memi[buf_in], Memi[buf_out], npix) + } + + call sprintf (Memc[key], SZ_FNAME, "bpm%04d") + call pargi (i) + call imastr (out, Memc[key], Memc[bpmname]) + + call imunmap (inbpm) + } + + call imunmap (in) + } + } then { + i = errget (Memc[key], SZ_FNAME) + call erract (EA_WARN) + if (outbpm != NULL) { + call imunmap (outbpm) + iferr (call imdelete (mask)) + ; + } + if (out != NULL) { + call imunmap (out) + iferr (call imdelete (output)) + ; + } + if (inbpm != NULL) + call imunmap (inbpm) + if (in != NULL) + call imunmap (in) + call sfree (sp) + call error (i, "Can't make temporary stack images") + } + + # Finish up. + if (outbpm != NULL) { + call imunmap (outbpm) + call imastr (out, "bpm", mask) + } + call imunmap (out) + call sfree (sp) +end diff --git a/pkg/images/immatch/src/imcombine/src/iclog.x b/pkg/images/immatch/src/imcombine/src/iclog.x new file mode 100644 index 00000000..53420cd5 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/iclog.x @@ -0,0 +1,431 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <mach.h> +include "icombine.h" +include "icmask.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) + +pointer in[nimages] # Input images +pointer out[ARB] # 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 + +int i, j, stack, ctor() +real rval, imgetr() +long clktime() +bool prncombine, prexptime, prmode, prmedian, prmean, prmask +bool prrdn, prgain, prsn +pointer sp, fname, bpname, key +errchk imgetr + +include "icombine.com" + +begin + if (logfd == NULL) + return + + call smark (sp) + call salloc (fname, SZ_LINE, TY_CHAR) + call salloc (bpname, 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, ") + case SUM: + call fprintf (logfd, " combine = sum, ") + } + call fprintf (logfd, "scale = %s, zero = %s, weight = %s\n") + call pargstr (sname) + call pargstr (zname) + call pargstr (wname) + if (combine == NMODEL && reject!=CCDCLIP && reject!=CRREJECT) { + call fprintf (logfd, + " rdnoise = %s, gain = %s, snoise = %s\n") + call pargstr (Memc[rdnoise]) + call pargstr (Memc[gain]) + call pargstr (Memc[snoise]) + } + + 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) + if (Memc[statsec] != EOS) { + call fprintf (logfd, " statsec = %s\n") + call pargstr (Memc[fname]) + } + + if (ICM_TYPE(icm) != M_NONE) { + switch (ICM_TYPE(icm)) { + case M_BOOLEAN, M_GOODVAL: + call fprintf (logfd, " masktype = goodval, maskval = %d\n") + call pargi (ICM_VALUE(icm)) + case M_BADVAL: + call fprintf (logfd, " masktype = badval, maskval = %d\n") + call pargi (ICM_VALUE(icm)) + case M_NOVAL: + call fprintf (logfd, " masktype = noval, maskval = %d\n") + call pargi (ICM_VALUE(icm)) + case M_GOODBITS: + call fprintf (logfd, " masktype = goodbits, maskval = %d\n") + call pargi (ICM_VALUE(icm)) + case M_BADBITS: + call fprintf (logfd, " masktype = badbits, maskval = %d\n") + call pargi (ICM_VALUE(icm)) + case M_LTVAL: + call fprintf (logfd, " masktype = goodval, maskval < %d\n") + call pargi (ICM_VALUE(icm)) + case M_GTVAL: + call fprintf (logfd, " masktype = goodval, maskval > %d\n") + call pargi (ICM_VALUE(icm)) + } + } + + # 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 (ICM_TYPE(icm) != M_NONE) { + if (project) + bpname = Memi[ICM_NAMES(icm)] + else + bpname = Memi[ICM_NAMES(icm)+i-1] + if (Memc[bpname] != EOS) + prmask = true + } + if (combine == NMODEL || 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) { + if (stack == YES) { + call sprintf (Memc[key], SZ_FNAME, "bpm%04d") + call pargi (i) + ifnoerr (call imgstr (in[i], Memc[key], Memc[fname], + SZ_LINE)) { + call fprintf (logfd, " %s") + call pargstr (Memc[fname]) + } else { + call fprintf (logfd, " %s") + call pargstr (Memc[bpname]) + } + } else if (ICM_TYPE(icm) != M_NONE) { + if (project) + bpname = Memi[ICM_NAMES(icm)] + else + bpname = Memi[ICM_NAMES(icm)+i-1] + if (Memc[bpname] != EOS) { + call fprintf (logfd, " %s") + call pargstr (Memc[bpname]) + } + } + } + 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) + call fprintf (logfd, "\n") + + if (out[2] != NULL) { + call imstats (out[2], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " Bad pixel mask = %s\n") + call pargstr (Memc[fname]) + } + + 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[5] != NULL) { + call imstats (out[5], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " Number rejected mask = %s\n") + call pargstr (Memc[fname]) + } + + if (out[6] != NULL) { + call imstats (out[6], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " Exposure mask = %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/images/immatch/src/imcombine/src/icmask.com b/pkg/images/immatch/src/imcombine/src/icmask.com new file mode 100644 index 00000000..baba6f6a --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/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/images/immatch/src/imcombine/src/icmask.h b/pkg/images/immatch/src/imcombine/src/icmask.h new file mode 100644 index 00000000..ffb64aa9 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icmask.h @@ -0,0 +1,12 @@ +# ICMASK -- Data structure for IMCOMBINE mask interface. + +define ICM_LEN 6 # Structure length +define ICM_TYPE Memi[$1] # Mask type +define ICM_VALUE Memi[$1+1] # Mask value +define ICM_IOMODE Memi[$1+2] # I/O mode +define ICM_BUFS Memi[$1+3] # Pointer to data line buffers +define ICM_PMS Memi[$1+4] # Pointer to array of PMIO pointers +define ICM_NAMES Memi[$1+5] # Pointer to array of mask names + +define ICM_OPEN 0 # Keep masks open +define ICM_CLOSED 1 # Keep masks closed diff --git a/pkg/images/immatch/src/imcombine/src/icmask.x b/pkg/images/immatch/src/imcombine/src/icmask.x new file mode 100644 index 00000000..ca9c1d02 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icmask.x @@ -0,0 +1,685 @@ +include <imhdr.h> +include <imset.h> +include <pmset.h> +include "icombine.h" +include "icmask.h" + +# IC_MASK -- ICOMBINE mask interface +# +# IC_MOPEN -- Initialize mask interface +# 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_MCLOSE1-- Close a mask for the specified image index + + +# IC_MOPEN -- Initialize mask interface. + +procedure ic_mopen (in, out, nimages, offsets, iomode) + +pointer in[nimages] #I Input images +pointer out[ARB] #I Output images +int nimages #I Number of images +int offsets[nimages,ARB] #I Offsets to output image +int iomode #I I/O mode + +int mtype # Mask type +int mvalue # Mask value +pointer bufs # Pointer to data line buffers +pointer pms # Pointer to array of PMIO pointers +pointer names # Pointer to array of string pointers + +int i, j, k, nin, nout, npix, npms, nscan(), strdic(), ctor() +real rval +pointer sp, str, key, fname, title, image, pm, pm_open() +bool invert, pm_empty() +errchk calloc, pm_open, ic_pmload + +include "icombine.com" + +begin + icm = NULL + if (IM_NDIM(out[1]) == 0) + return + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (key, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (title, SZ_FNAME, TY_CHAR) + call salloc (image, 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 = M_NONE + call clgstr ("masktype", Memc[str], SZ_LINE) + call sscan (Memc[str]) + call gargwrd (Memc[title], SZ_FNAME) + call gargwrd (Memc[key], SZ_FNAME) + i = nscan() + if (i > 0) { + if (Memc[title] == '!') { + if (i == 1) + mtype = M_GOODVAL + else + mtype = strdic (Memc[key], Memc[key], SZ_FNAME, MASKTYPES) + call strcpy (Memc[title+1], Memc[key], SZ_FNAME) + } else { + mtype = strdic (Memc[title], Memc[title], SZ_FNAME, MASKTYPES) + call strcpy ("BPM", Memc[key], SZ_FNAME) + } + if (mtype == 0) { + call sprintf (Memc[title], SZ_FNAME, + "Invalid or ambiguous masktype (%s)") + call pargstr (Memc[str]) + call error (1, Memc[title]) + } + } + npix = IM_LEN(out[1],1) + call calloc (pms, nimages, TY_POINTER) + call calloc (bufs, nimages, TY_POINTER) + call calloc (names, 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. + + # Eventually we want to allow general expressions. For now we only + # allow a special '<' or '>' operator. + + call clgstr ("maskvalue", Memc[title], SZ_FNAME) + i = 1 + if (Memc[title] == '<') { + mtype = M_LTVAL + i = i + 1 + } else if (Memc[title] == '>') { + mtype = M_GTVAL + i = i + 1 + } + if (ctor (Memc[title], i, rval) == 0) + call error (1, "Bad mask value") + mvalue = rval + if (mvalue < 0) + call error (1, "Bad mask value") + else if (mvalue == 0 && mtype == M_NOVAL) + call error (1, "maskvalue cannot be 0 for masktype of 'novalue'") + + if (mtype == 0) + mtype = M_NONE + else if (mtype == M_BADBITS && mvalue == 0) + mtype = M_NONE + else if (mvalue == 0 && (mtype == M_GOODVAL || mtype == M_GOODBITS)) + mtype = M_BOOLEAN + else 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. + + nout = IM_LEN(out[1],1) + npms = 0 + do i = 1, nimages { + if (mtype != M_NONE) { + call malloc (Memi[names+i-1], SZ_FNAME, TY_CHAR) + fname = Memi[names+i-1] + ifnoerr (call imgstr (in[i],Memc[key],Memc[fname],SZ_FNAME)) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + Memc[fname] = EOS + else { + pm = pm_open (NULL) + call ic_pmload (in[i], pm, Memc[fname], SZ_FNAME) + call pm_seti (pm, P_REFIM, in[i]) + if (pm_empty (pm) && !invert) + Memc[fname] = EOS + else { + if (project) + npms = nimages + else + npms = npms + 1 + } + call pm_close (pm) + } + if (project) + break + } else + Memc[fname] = EOS + } + } + + # 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 + } + + # Set up mask structure. + call calloc (icm, ICM_LEN, TY_STRUCT) + ICM_TYPE(icm) = mtype + ICM_VALUE(icm) = mvalue + ICM_IOMODE(icm) = iomode + ICM_BUFS(icm) = bufs + ICM_PMS(icm) = pms + ICM_NAMES(icm) = names + + call sfree (sp) +end + + +# IC_PMLOAD -- Find and load a mask. +# This is more complicated because we want to allow a mask name specified +# without a path to be found either in the current directory or in the +# directory of the image. + +procedure ic_pmload (im, pm, fname, maxchar) + +pointer im #I Image pointer to be associated with mask +pointer pm #O Mask pointer to be returned +char fname[ARB] #U Mask name +int maxchar #I Max size of mask name + +bool match +pointer sp, str, imname, yt_pmload() +int i, fnldir(), stridxs(), envfind() + +begin + call smark (sp) + call salloc (str, SZ_PATHNAME, TY_CHAR) + + # First check if the specified file can be loaded. + match = (envfind ("pmatch", Memc[str], SZ_PATHNAME) > 0) + if (match) { + call pm_close (pm) + iferr (pm = yt_pmload (fname,im,"logical",Memc[str],SZ_PATHNAME)) + pm = NULL + if (pm != NULL) + return + } else { + ifnoerr (call pm_loadf (pm, fname, Memc[str], SZ_PATHNAME)) + return + ifnoerr (call pm_loadim (pm, fname, Memc[str], SZ_PATHNAME)) + return + } + + # Check if the file has a path in which case we return an error. + # Must deal with possible [] which is a VMS directory delimiter. + call strcpy (fname, Memc[str], SZ_PATHNAME) + i = stridxs ("[", Memc[str]) + if (i > 0) + Memc[str+i-1] = EOS + if (fnldir (Memc[str], Memc[str], SZ_PATHNAME) > 0) { + call sprintf (Memc[str], SZ_PATHNAME, + "Bad pixel mask not found (%s)") + call pargstr (fname) + call error (1, Memc[str]) + } + + # Check if the image has a path. If not return an error. + call salloc (imname, SZ_PATHNAME, TY_CHAR) + call imstats (im, IM_IMAGENAME, Memc[imname], SZ_PATHNAME) + if (fnldir (Memc[imname], Memc[str], SZ_PATHNAME) == 0) { + call sprintf (Memc[str], SZ_PATHNAME, + "Bad pixel mask not found (%s)") + call pargstr (fname) + call error (1, Memc[str]) + } + + # Try using the image path for the mask file. + call strcat (fname, Memc[str], SZ_PATHNAME) + if (match) { + iferr (pm = yt_pmload (Memc[imname], im, "logical", + Memc[str], SZ_PATHNAME)) + pm = NULL + if (pm != NULL) { + call strcpy (Memc[str], fname, maxchar) + return + } + } else { + ifnoerr (call pm_loadf (pm, Memc[str], Memc[imname], SZ_PATHNAME)) { + call strcpy (Memc[str], fname, maxchar) + return + } + } + + # No mask found. + call sprintf (Memc[str], SZ_PATHNAME, + "Bad pixel mask not found (%s)") + call pargstr (fname) + call error (1, Memc[str]) + + # This will not be reached and we let the calling program free + # the stack. We include smark/sfree for lint detectors. + call sfree (sp) +end + + + +# IC_MCLOSE -- Close the mask interface. + +procedure ic_mclose (nimages) + +int nimages # Number of images + +int i +include "icombine.com" + +begin + if (icm == NULL) + return + + do i = 1, nimages { + call mfree (Memi[ICM_NAMES(icm)+i-1], TY_CHAR) + call mfree (Memi[ICM_BUFS(icm)+i-1], TY_INT) + } + do i = 1, nimages { + if (Memi[ICM_PMS(icm)+i-1] != NULL) + call pm_close (Memi[ICM_PMS(icm)+i-1]) + if (project) + break + } + call mfree (ICM_NAMES(icm), TY_POINTER) + call mfree (ICM_BUFS(icm), TY_POINTER) + call mfree (ICM_PMS(icm), TY_POINTER) + call mfree (icm, TY_STRUCT) +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, mtype) + +pointer in[nimages] # Input image pointers +pointer out[ARB] # 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 mtype # Mask type +int mvalue # Mask value +int iomode # I/O mode +pointer bufs # Pointer to data line buffers +pointer pms # Pointer to array of PMIO pointers + +char title[1] +int i, j, k, l, ndim, nin, nout, npix, envfind() +pointer buf, pm, names, fname, pm_open(), yt_pmload() +bool match, pm_linenotempty() +errchk pm_glpi, pm_open, pm_loadf, pm_loadim, yt_pmload + +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. + + dflag = D_ALL + mtype = M_NONE + if (icm == NULL) + return + if (ICM_TYPE(icm) == M_NONE && aligned && !dothresh) + return + + mtype = ICM_TYPE(icm) + mvalue = ICM_VALUE(icm) + iomode = ICM_IOMODE(icm) + bufs = ICM_BUFS(icm) + pms = ICM_PMS(icm) + names = ICM_NAMES(icm) + match = (envfind ("pmmatch", title, 1) > 0) + + # 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 { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + + m[i] = Memi[bufs+i-1] + buf = Memi[bufs+i-1] + j + if (project) { + pm = Memi[pms] + fname = Memi[names] + } else { + pm = Memi[pms+i-1] + fname = Memi[names+i-1] + } + + if (npix < 1) + lflag[i] = D_NONE + else if (npix == nout) + lflag[i] = D_ALL + else + lflag[i] = D_MIX + + if (lflag[i] != D_NONE) { + v2[1] = 1 + j - offsets[i,1] + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + } + if (project) + v2[ndim+1] = i + + if (lflag[i] == D_NONE) { + if (pm != NULL && !project) { + call pm_close (pm) + Memi[pms+i-1] = NULL + } + call amovki (1, Memi[m[i]], nout) + next + } else if (lflag[i] == D_MIX) { + if (j > 0) + call amovki (1, Memi[m[i]], j) + if (nout-k > 0) + call amovki (1, Memi[m[i]+k], nout-k) + } + + if (fname == NULL) { + call aclri (Memi[buf], npix) + next + } else if (Memc[fname] == EOS) { + call aclri (Memi[buf], npix) + next + } + + # Do mask I/O and convert to appropriate values in order of + # expected usage. + + if (pm == NULL) { + if (match) { + pm = yt_pmload (Memc[fname], in[i], "logical", + Memc[fname], SZ_FNAME) + } else { + pm = pm_open (NULL) + iferr (call pm_loadf (pm, Memc[fname], title, 1)) + call pm_loadim (pm, Memc[fname], title, 1) + call pm_seti (pm, P_REFIM, in[i]) + } + if (project) + Memi[pms] = pm + else + Memi[pms+i-1] = pm + } + + 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_NOVAL) { + do j = 0, npix-1 { + if (Memi[buf+j] == 0) + next + if (Memi[buf+j] == mvalue) + Memi[buf+j] = 1 + else + Memi[buf+j] = 2 + } + } 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) + else if (mtype == M_LTVAL) + call abgeki (Memi[buf], mvalue, Memi[buf], npix) + else if (mtype == M_GTVAL) + call ableki (Memi[buf], mvalue, Memi[buf], npix) + + lflag[i] = D_NONE + do j = 1, npix + if (Memi[buf+j-1] != 1) { + 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_NOVAL && mvalue != 0) || + (mtype == M_GOODVAL && mvalue == 0)) { + call aclri (Memi[buf], npix) + } else if (mtype == M_LTVAL && mvalue > 0) { + call aclri (Memi[buf], npix) + } else { + call amovki (1, Memi[buf], npix) + lflag[i] = D_NONE + } + } + + if (iomode == ICM_CLOSED) + call ic_mclose1 (i, nimages) + } + + # 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, nimages, offset, v, m) + +pointer in # Input image pointer +int image # Image index +int nimages # Number of images +int offset # Column offset +long v[IM_MAXDIM] # Data vector desired +pointer m # Pointer to mask + +int mtype # Mask type +int mvalue # Mask value +pointer bufs # Pointer to data line buffers +pointer pms # Pointer to array of PMIO pointers + +char title[1] +int i, npix, envfind() +pointer buf, pm, names, fname, pm_open(), yt_pmload() +bool pm_linenotempty() +errchk pm_glpi, pm_open, pm_loadf, pm_loadim, yt_pmload + +include "icombine.com" + +begin + dflag = D_ALL + if (icm == NULL) + return + if (ICM_TYPE(icm) == M_NONE) + return + + mtype = ICM_TYPE(icm) + mvalue = ICM_VALUE(icm) + bufs = ICM_BUFS(icm) + pms = ICM_PMS(icm) + names = ICM_NAMES(icm) + + npix = IM_LEN(in,1) + m = Memi[bufs+image-1] + offset + if (project) { + pm = Memi[pms] + fname = Memi[names] + } else { + pm = Memi[pms+image-1] + fname = Memi[names+image-1] + } + + if (fname == NULL) + return + if (Memc[fname] == EOS) + return + + if (pm == NULL) { + if (envfind ("pmmatch", title, 1) > 0) { + pm = yt_pmload (Memc[fname], in, "logical", Memc[fname], + SZ_FNAME) + } else { + pm = pm_open (NULL) + iferr (call pm_loadf (pm, Memc[fname], title, 1)) + call pm_loadim (pm, Memc[fname], title, 1) + call pm_seti (pm, P_REFIM, in) + } + if (project) + Memi[pms] = pm + else + Memi[pms+image-1] = pm + } + + # 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_NOVAL) { + do i = 0, npix-1 { + if (Memi[buf+i] == 0) + next + if (Memi[buf+i] == mvalue) + Memi[buf+i] = 1 + else + Memi[buf+i] = 2 + } + } 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) + else if (mtype == M_LTVAL) + call abgeki (Memi[buf], mvalue, Memi[buf], npix) + else if (mtype == M_GTVAL) + call ableki (Memi[buf], mvalue, Memi[buf], npix) + + dflag = D_NONE + do i = 1, npix + if (Memi[buf+i-1] != 1) { + dflag = D_MIX + break + } + } else { + if (mtype == M_BOOLEAN || mtype == M_BADBITS) { + ; + } else if ((mtype == M_BADVAL && mvalue != 0) || + (mtype == M_NOVAL && mvalue != 0) || + (mtype == M_GOODVAL && mvalue == 0)) { + ; + } else if (mtype == M_LTVAL && mvalue > 0) { + ; + } else + dflag = D_NONE + } +end + + +# IC_MCLOSE1 -- Close mask by index. + +procedure ic_mclose1 (image, nimages) + +int image # Image index +int nimages # Number of images + +pointer pms, names, pm, fname +include "icombine.com" + +begin + if (icm == NULL) + return + + pms = ICM_PMS(icm) + names = ICM_NAMES(icm) + + if (project) { + pm = Memi[pms] + fname = Memi[names] + } else { + pm = Memi[pms+image-1] + fname = Memi[names+image-1] + } + + if (fname == NULL || pm == NULL) + return + if (Memc[fname] == EOS || pm == NULL) + return + + call pm_close (pm) + if (project) + Memi[pms] = NULL + else + Memi[pms+image-1] = NULL +end + + +# YT_PMLOAD -- This is like yt_mappm except it returns the mask pointer. + +pointer procedure yt_pmload (pmname, refim, match, mname, sz_mname) + +char pmname[ARB] #I Pixel mask name +pointer refim #I Reference image pointer +char match[ARB] #I Match by physical coordinates? +char mname[ARB] #O Expanded mask name +int sz_mname #O Size of expanded mask name +pointer pm #R Pixel mask pointer + +int imstati() +pointer im, yt_mappm() +errchk yt_mappm + +begin + im = yt_mappm (pmname, refim, match, mname, sz_mname) + if (im != NULL) { + pm = imstati (im, IM_PMDES) + call imseti (im, IM_PMDES, NULL) + call imunmap (im) + } else + pm = NULL + return (pm) +end diff --git a/pkg/images/immatch/src/imcombine/src/icmedian.gx b/pkg/images/immatch/src/imcombine/src/icmedian.gx new file mode 100644 index 00000000..164140a1 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icmedian.gx @@ -0,0 +1,246 @@ +# 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, j, k, j1, j2, n1, lo, up, lo1, up1 +bool even +$if (datatype == silx) +real val1, val2, val3 +$else +PIXEL val1, val2, val3 +$endif +PIXEL temp, wtemp +$if (datatype == x) +real abs_temp +$endif + +include "../icombine.com" + +begin + # If no data return after possibly setting blank values. + if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + median[i]= blank + } + return + } + + # If the data were previously sorted then directly compute the median. + if (mclip) { + if (dflag == D_ALL) { + n1 = n[1] + j1 = n1 / 2 + 1 + j2 = n1 / 2 + even = (mod(n1,2)==0 && (medtype==MEDAVG || 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] + } + return + } else { + # Check for negative n values. If found then there are + # pixels with no good values but with values we want to + # use as a substitute median. In this case ignore that + # the good pixels have been sorted. + do i = 1, npts { + if (n[i] < 0) + break + } + + if (n[i] >= 0) { + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 > 0) { + j1 = n1 / 2 + 1 + if (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) { + 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 + } + } + } + + # Compute the median. + do i = 1, npts { + k = i - 1 + n1 = abs(n[i]) + + # If there are more than 3 points use Wirth algorithm. This + # is the same as vops$amed.gx except for an even number of + # points it selects the middle two and averages. + if (n1 > 3) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Mem$t[d[j]+k]; lo1 = lo; up1 = up + $if (datatype == x) + abs_temp = abs (temp) + $endif + + repeat { + $if (datatype == x) + while (abs (Mem$t[d[lo1]+k]) < abs_temp) + $else + while (Mem$t[d[lo1]+k] < temp) + $endif + lo1 = lo1 + 1 + $if (datatype == x) + while (abs_temp < abs (Mem$t[d[up1]+k])) + $else + while (temp < Mem$t[d[up1]+k]) + $endif + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Mem$t[d[lo1]+k] + Mem$t[d[lo1]+k] = Mem$t[d[up1]+k] + Mem$t[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + + median[i] = Mem$t[d[j]+k] + + if (mod(n1,2)==0 && (medtype==MEDAVG || n1 > 2)) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)+1) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Mem$t[d[j]+k]; lo1 = lo; up1 = up + $if (datatype == x) + abs_temp = abs (temp) + $endif + + repeat { + $if (datatype == x) + while (abs (Mem$t[d[lo1]+k]) < abs_temp) + $else + while (Mem$t[d[lo1]+k] < temp) + $endif + lo1 = lo1 + 1 + $if (datatype == x) + while (abs_temp < abs (Mem$t[d[up1]+k])) + $else + while (temp < Mem$t[d[up1]+k]) + $endif + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Mem$t[d[lo1]+k] + Mem$t[d[lo1]+k] = Mem$t[d[up1]+k] + Mem$t[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + median[i] = (median[i] + Mem$t[d[j]+k]) / 2 + } + + # If 3 points find the median directly. + } else 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 + + # If 2 points average. + } else if (n1 == 2) { + val1 = Mem$t[d[1]+k] + val2 = Mem$t[d[2]+k] + if (medtype == MEDAVG) + median[i] = (val1 + val2) / 2 + else + median[i] = min (val1, val2) + + # If 1 point return the value. + } else if (n1 == 1) + median[i] = Mem$t[d[1]+k] + + # If no points return with a possibly blank value. + else if (doblank == YES) + median[i] = blank + } +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icmm.gx b/pkg/images/immatch/src/imcombine/src/icmm.gx new file mode 100644 index 00000000..860cb512 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icmm.gx @@ -0,0 +1,189 @@ +# 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 = max (0, 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 = max (0, 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 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } else { + Mem$t[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } + if (jmin < j) { + if (jmax != n1) { + Mem$t[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } else { + Mem$t[kmin] = d2 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } + } + } 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/images/immatch/src/imcombine/src/icnmodel.gx b/pkg/images/immatch/src/imcombine/src/icnmodel.gx new file mode 100644 index 00000000..0e020dc9 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icnmodel.gx @@ -0,0 +1,147 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> +include "../icombine.h" +include "../icmask.h" + +$for (sird) +# IC_NMODEL -- Compute the quadrature average (or summed) noise model. +# Options include a weighted average/sum. + +procedure ic_nmodel$t (d, m, n, nm, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real nm[3,nimages] # Noise model parameters +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +$if (datatype == sil) +real average[npts] # Average (returned) +$else +PIXEL average[npts] # Average (returned) +$endif + +int i, j, k, n1 +real val, wt, sumwt +$if (datatype == sil) +real sum, zero +data zero /0.0/ +$else +PIXEL sum, zero +data zero /0$f/ +$endif + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum 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/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = max (zero, Mem$t[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + do j = 2, n[i] { + val = max (zero, Mem$t[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = max (zero, Mem$t[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n[i] { + val = max (zero, Mem$t[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Mem$t[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + sumwt = wt + do j = 2, n1 { + val = max (zero, Mem$t[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = max (zero, Mem$t[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = Mem$t[d[1]+k]**2 + do j = 2, n1 { + val = max (zero, Mem$t[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + + (val*nm[3,j])**2 + sum = sum + val + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Mem$t[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n1 { + val = max (zero, Mem$t[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icomb.gx b/pkg/images/immatch/src/imcombine/src/icomb.gx new file mode 100644 index 00000000..ae489158 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icomb.gx @@ -0,0 +1,761 @@ +# 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" + +# The following is for compiling under V2.11. +define IM_BUFFRAC IM_BUFSIZE +include <imset.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, scales, zeros, wts, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real wts[nimages] # Weights +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, k, npts, fd, stropen(), xt_imgnl$t() +pointer sp, d, id, n, m, lflag, v, dbuf +pointer im, buf, xt_opix(), impl1i() +errchk stropen, xt_cpix, xt_opix, xt_imgnl$t, impl1i, ic_combine$t +$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 (v, IM_MAXDIM, TY_LONG) + call amovki (D_ALL, Memi[lflag], nimages) + call amovkl (1, Meml[v], IM_MAXDIM) + + # 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) + call aclr$t (Mem$t[Memi[dbuf+i-1]], npts) + } + } else { + do i = 1, nimages { + im = xt_opix (in[i], i, 1) + if (im != in[i]) { + call salloc (Memi[dbuf+i-1], npts, TY_PIXEL) + call aclr$t (Mem$t[Memi[dbuf+i-1]], npts) + } + } + call amovki (NULL, Memi[dbuf], nimages) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFFRAC, 0) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + 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, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + 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) + } + if (out[4] != NULL) { + buf = impl1i (out[4]) + call aclri (Memi[buf], npts) + } + if (out[5] != NULL) { + buf = impl1i (out[5]) + call aclri (Memi[buf], npts) + } + if (out[6] != NULL) { + buf = impl1i (out[6]) + call aclri (Memi[buf], npts) + } + + # Do I/O for first input image line. + if (!project) { + do i = 1, nimages { + call xt_imseti (i, "bufsize", bufsize) + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + call xt_cpix (i) + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + + do i = 1, nimages { + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + next + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + next + iferr { + Meml[v+1] = j + j = xt_imgnl$t (in[i], i, buf, Meml[v], 1) + } then { + call imseti (im, IM_PIXFD, NULL) + 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, scales, zeros, 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[ARB] # 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(), errcode() +real r, imgetr() +pointer sp, fname, imname, v1, v2, v3, work +pointer outdata, buf, nmod, 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, ic_emask +errchk ic_gdata$t + +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, SUM, QUAD, NMODEL: + if (dowts) + keepids = true + else + keepids = false + case MEDIAN: + dowts = false + keepids = false + } + docombine = true + + # Get noise model parameters. + if (combine==NMODEL) { + call salloc (nmod, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nmod+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nmod+3*(i-1)+2] = r + } + } + } + + # 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 (out[6] != NULL) { + keepids = true + call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) + } + + 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) + } + +# This idea turns out to has a problem with masks are used with wcs offsets. +# the matching of masks to images based on WCS requires access to the WCS +# of the images. For now we drop this idea but maybe a way can be identified +# to know when this is not going to be needed. +# # Reduce header memory use. +# do i = 1, nimages +# call xt_minhdr (i) + + $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, nimages, npts, + YES, YES, Memr[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, YES, Memr[outdata]) + case SUM: + call ic_average$t (d, id, n, wts, nimages, npts, + YES, NO, Memr[outdata]) + case QUAD: + call ic_quad$t (d, id, n, wts, nimages, npts, + YES, YES, Memr[outdata]) + case NMODEL: + call ic_nmodel$t (d, id, n, Memr[nmod], wts, + nimages, npts, YES, 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]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 1 + } + } + + 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) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, 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, nimages, npts, + YES, YES, Mem$t[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, YES, Mem$t[outdata]) + case SUM: + call ic_average$t (d, id, n, wts, nimages, npts, + YES, NO, Mem$t[outdata]) + case QUAD: + call ic_quad$t (d, id, n, wts, nimages, npts, + YES, YES, Mem$t[outdata]) + case NMODEL: + call ic_nmodel$t (d, id, n, Memr[nmod], wts, + nimages, npts, YES, 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]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + 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) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, 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, nimages, npts, + NO, YES, Memr[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, NO, Memr[outdata]) + case SUM: + call ic_average$t (d, id, n, wts, nimages, npts, + NO, NO, Memr[outdata]) + case QUAD: + call ic_quad$t (d, id, n, wts, nimages, npts, + NO, YES, Memr[outdata]) + case NMODEL: + call ic_nmodel$t (d, id, n, Memr[nmod], wts, + nimages, npts, NO, YES, Memr[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + 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) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, 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, nimages, npts, + NO, YES, Mem$t[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, NO, Mem$t[outdata]) + case SUM: + call ic_average$t (d, id, n, wts, nimages, npts, + NO, NO, Mem$t[outdata]) + case QUAD: + call ic_quad$t (d, id, n, wts, nimages, npts, + NO, YES, Mem$t[outdata]) + case NMODEL: + call ic_nmodel$t (d, id, n, Memr[nmod], wts, + nimages, npts, NO, YES, Mem$t[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + 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) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, 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 diff --git a/pkg/images/immatch/src/imcombine/src/icombine.com b/pkg/images/immatch/src/imcombine/src/icombine.com new file mode 100644 index 00000000..55ad308b --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icombine.com @@ -0,0 +1,45 @@ +# ICOMBINE Common + +int combine # Combine algorithm +int medtype # Median type +int reject # Rejection algorithm +bool project # Combine across the highest dimension? +real blank # Blank value +pointer expkeyword # Exposure time keyword +pointer statsec # Statistics section +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? +bool verbose # Verbose? + +pointer icm # Mask data structure + +common /imccom/ combine, medtype, reject, blank, expkeyword, statsec, 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, verbose, icm diff --git a/pkg/images/immatch/src/imcombine/src/icombine.h b/pkg/images/immatch/src/imcombine/src/icombine.h new file mode 100644 index 00000000..51f60887 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icombine.h @@ -0,0 +1,63 @@ +# ICOMBINE Definitions + +# Memory management parameters; +define MAXMEMORY 500000000 # maximum memory +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|lmedian|sum|quadrature|nmodel|" +define AVERAGE 1 +define MEDIAN 2 +define LMEDIAN 3 +define SUM 4 +define QUAD 5 +define NMODEL 6 + +# Median types: +define MEDAVG 1 # Central average for even N +define MEDLOW 2 # Lower value for even N + +# 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|novalue|" +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_NOVAL 6 # Value selecting no value (good = 0) +define M_LTVAL 7 # Values less than specified are good +define M_GTVAL 8 # Values greater than specified are good +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/images/immatch/src/imcombine/src/icombine.x b/pkg/images/immatch/src/imcombine/src/icombine.x new file mode 100644 index 00000000..b6e5ddd4 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icombine.x @@ -0,0 +1,520 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <error.h> +include <syserr.h> +include "icombine.h" + + +# ICOMBINE -- 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, output, headers, bmask, rmask, nrmask, emask, + sigma, logfile, scales, zeros, wts, stack, delete, listonly) + +int list #I List of input images +char output[ARB] #I Output image +char headers[ARB] #I Output header rootname +char bmask[ARB] #I Bad pixel mask +char rmask[ARB] #I Rejection mask +char nrmask[ARB] #I Nreject mask +char emask[ARB] #I Exposure mask +char sigma[ARB] #I Sigma image (optional) +char logfile[ARB] #I Logfile (optional) +real scales[ARB] #I Scale factors +real zeros[ARB] #I Offset factors +real wts[ARB] #I Weights +int stack #I Stack input images? +int delete #I Delete input images? +int listonly #I List images to combine? + +bool proj +char input[SZ_FNAME], errstr[SZ_LINE] +int i, j, nimages, intype, bufsize, oldsize, stack1, err, retry +int maxsize, maxmemory, memory +pointer sp, im, in1, in, out[6], offsets, key, tmp, bpmstack + +char clgetc() +int clgwrd(), imtlen(), imtgetim(), imtrgetim(), getdatatype(), envgeti() +int begmem(), errget(), open(), ty_max(), sizeof(), strmatch() +pointer immap(), xt_immap(), ic_pmmap() +errchk ic_imstack, immap, imunmap, xt_immap, ic_pmmap, ic_setout + +include "icombine.com" + +define retry_ 98 +define err_ 99 + +begin + if (listonly == YES) { + # Write the output list. + if (output[1] == EOS) { + call imtrew (list) + while (imtgetim (list, input, SZ_FNAME)!=EOF) { + i = strmatch (input, "[0]") - 3 + if (i > 0) + call strcpy (input[i+3], input[i], SZ_FNAME) + call printf ("%s\n") + call pargstr (input) + } + } else { + call sprintf (errstr, SZ_LINE, "%s.list") + call pargstr (output) + iferr (logfd = open (errstr, APPEND, TEXT_FILE)) + call erract (EA_WARN) + call imtrew (list) + while (imtgetim (list, input, SZ_FNAME)!=EOF) { + i = strmatch (input, "[0]") - 3 + if (i > 0) + call strcpy (input[i+3], input[i], SZ_FNAME) + call printf ("%s -> %s\n") + call pargstr (input) + call pargstr (errstr) + call fprintf (logfd, "%s\n") + call pargstr (input) + } + call close (logfd) + } + return + } + + nimages = imtlen (list) + if (nimages == 0) + call error (1, "No images to combine") + + if (project) { + if (imtgetim (list, input, SZ_FNAME) == EOF) + call error (1, "No image to project") + } + + bufsize = 0 +# if (nimages > LAST_FD - 15) +# stack1 = YES +# else + stack1 = stack + + retry = 0 + +retry_ + iferr { + call smark (sp) + call salloc (in, 1, TY_POINTER) + + nimages = 0 + in1 = NULL; Memi[in] = NULL; logfd = NULL + out[1] = NULL; out[2] = NULL; out[3] = NULL + out[4] = NULL; out[5] = NULL; out[6] = NULL + + # Stack the input images. + if (stack1 == YES) { + proj = project + project = true + call salloc (bpmstack, SZ_FNAME, TY_CHAR) + i = clgwrd ("masktype", Memc[bpmstack], SZ_FNAME, MASKTYPES) + if (i == M_NONE) + Memc[bpmstack] = EOS + else { + call mktemp ("tmp", Memc[bpmstack], SZ_FNAME) + call strcat (".pl", Memc[bpmstack], SZ_FNAME) + } + call mktemp ("tmp", input, SZ_FNAME) + call imtrew (list) + call ic_imstack (list, input, Memc[bpmstack]) + } + + # Open the input image(s). + 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) { + nimages = nimages + 1 + tmp = xt_immap (input, READ_ONLY, 0, nimages, retry) + Memi[in+nimages-1] = tmp + } + + # Check sizes and set I/O option. + intype = 0 + tmp = Memi[in] + do i = 2, nimages { + do j = 1, IM_NDIM(tmp) { + if (IM_LEN(tmp,j) != IM_LEN(Memi[in+i-1],j)) + intype = 1 + } + if (intype == 1) + break + } + if (intype == 1) + call xt_imseti (0, "option", intype) + } + + # Check if there are no images. + if (nimages == 0) + call error (1, "No 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 / 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. + if (stack1 == YES) { + call imtrew (list) + i = imtgetim (list, errstr, SZ_LINE) + in1 = immap (errstr, READ_ONLY, 0) + tmp = immap (output, NEW_COPY, in1); out[1] = tmp + call salloc (key, SZ_FNAME, TY_CHAR) + do i = 1, nimages { + call sprintf (Memc[key], SZ_FNAME, "stck%04d") + call pargi (i) + iferr (call imdelf (out[1], Memc[key])) + ; + if (Memc[bpmstack] != EOS) { + call sprintf (Memc[key], SZ_FNAME, "bpm%04d") + call pargi (i) + iferr (call imdelf (out[1], Memc[key])) + ; + } + } + } else { + tmp = immap (output, NEW_COPY, Memi[in]); out[1] = tmp + if (project) { + IM_LEN(out[1],IM_NDIM(out[1])) = 1 + IM_NDIM(out[1]) = IM_NDIM(out[1]) - 1 + } + } + call salloc (offsets, nimages*IM_NDIM(out[1]), TY_INT) + iferr (call ic_setout (Memi[in], out, Memi[offsets], nimages)) { + call erract (EA_WARN) + call error (1, "Can't set output geometry") + } + call ic_hdr (Memi[in], out, nimages) + iferr (call imdelf (out, "BPM")) + ; + + # 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 = 100, nimages { + j = imtrgetim (list, i, input, SZ_FNAME) + if (i < 999) + call sprintf (Memc[key], SZ_FNAME, "imcmb%d") + else if (i < 9999) + call sprintf (Memc[key], SZ_FNAME, "imcm%d") + else + call sprintf (Memc[key], SZ_FNAME, "imc%d") + call pargi (i) + call imastr (out[4], Memc[key], input) + } + } + } else + out[4] = NULL + + # Open bad pixel pixel list file if given. + if (bmask[1] != EOS) { + tmp = ic_pmmap (bmask, NEW_COPY, out[1]); out[2] = tmp + } else + out[2] = NULL + + # Open nreject pixel list file if given. + if (nrmask[1] != EOS) { + tmp = ic_pmmap (nrmask, NEW_COPY, out[1]); out[5] = tmp + } else + out[5] = NULL + + # Open exposure mask if given. + if (emask[1] != EOS) { + tmp = ic_pmmap (emask, NEW_COPY, out[1]); out[6] = tmp + } else + out[6] = 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, Memi[offsets], + min(retry,1)) + + # 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. + + iferr (maxmemory = envgeti ("imcombine_maxmemory")) + maxmemory = MAXMEMORY + memory = begmem (0, oldsize, maxsize) + memory = min (memory, maxsize, maxmemory) + bufsize = FUDGE * memory / (nimages + 1) / sizeof (intype) + } + + # 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. + + switch (ty_max (intype, IM_PIXTYPE(out[1]))) { + case TY_SHORT: + call icombines (Memi[in], out, scales, zeros, + wts, Memi[offsets], nimages, bufsize) + case TY_USHORT, TY_INT, TY_LONG: + call icombinei (Memi[in], out, scales, zeros, + wts, Memi[offsets], nimages, bufsize) + case TY_DOUBLE: + call icombined (Memi[in], out, scales, zeros, + wts, Memi[offsets], nimages, bufsize) + case TY_COMPLEX: + call error (1, "Complex images not allowed") + default: + call icombiner (Memi[in], out, scales, zeros, + wts, Memi[offsets], nimages, bufsize) + } + } then { + err = errget (errstr, SZ_LINE) + if (err == SYS_IKIOPIX && nimages < 250) + err = SYS_MFULL + call ic_mclose (nimages) + if (!project) { + do j = 2, nimages { + if (Memi[in+j-1] != NULL) + call xt_imunmap (Memi[in+j-1], j) + } + } + if (out[2] != NULL) { + iferr (call imunmap (out[2])) + ; + iferr (call imdelete (bmask)) + ; + } + if (out[3] != NULL) { + iferr (call imunmap (out[3])) + ; + iferr (call imdelete (sigma)) + ; + } + if (out[4] != NULL) { + iferr (call imunmap (out[4])) + ; + iferr (call imdelete (rmask)) + ; + } + if (out[5] != NULL) { + iferr (call imunmap (out[5])) + ; + iferr (call imdelete (nrmask)) + ; + } + if (out[6] != NULL) { + iferr (call imunmap (out[6])) + ; + iferr (call imdelete (emask)) + ; + } + if (out[1] != NULL) { + iferr (call imunmap (out[1])) + ; + iferr (call imdelete (output)) + ; + } + if (Memi[in] != NULL) + call xt_imunmap (Memi[in], 1) + if (in1 != NULL) + call imunmap (in1) + if (logfd != NULL) + call close (logfd) + + switch (err) { + case SYS_MFULL: + if (project) + goto err_ + + if (bufsize < 10000 && retry > 2) { + call strcat ("- Maybe min_lenuserarea is too large", + errstr, SZ_LINE) + goto err_ + } + + bufsize = bufsize / 2 + retry = retry + 1 + call sfree (sp) + goto retry_ + case SYS_FTOOMANYFILES, SYS_IKIOPEN, SYS_IKIOPIX, SYS_FOPEN, SYS_FWTNOACC: + if (project) + goto err_ + stack1 = YES + call sfree (sp) + goto retry_ + default: +err_ + if (stack1 == YES) { + iferr (call imdelete (input)) + ; + if (Memc[bpmstack] != EOS) { + iferr (call imdelete (Memc[bpmstack])) + ; + } + } + call fixmem (oldsize) + while (imtgetim (list, input, SZ_FNAME)!=EOF) + ; + call sfree (sp) + call error (err, errstr) + } + } + + # Unmap all the images, close the log file, and restore memory. + if (out[2] != NULL) + iferr (call imunmap (out[2])) + call erract (EA_WARN) + if (out[3] != NULL) + iferr (call imunmap (out[3])) + call erract (EA_WARN) + if (out[4] != NULL) { + # Close the output first so that there is no confusion with + # inheriting the output header. Then update the WCS for the + # extra dimension. Note that this may not be correct with + # axis reduced WCS. + iferr { + call imunmap (out[4]) + out[4] = immap (rmask, READ_WRITE, 0) + i = IM_NDIM(out[4]) + call imaddi (out[4], "WCSDIM", i) + call sprintf (errstr, SZ_LINE, "LTM%d_%d") + call pargi (i) + call pargi (i) + call imaddr (out[4], errstr, 1.) + call sprintf (errstr, SZ_LINE, "CD%d_%d") + call pargi (i) + call pargi (i) + call imaddr (out[4], errstr, 1.) + call imunmap (out[4]) + } then + call erract (EA_WARN) + } + if (out[5] != NULL) + iferr (call imunmap (out[5])) + call erract (EA_WARN) + if (out[6] != NULL) + iferr (call imunmap (out[6])) + call erract (EA_WARN) + if (out[1] != NULL) { + call imunmap (out[1]) + if (headers[1] != EOS) { + # Write input headers to a multiextension file if desired. + # This might be the same as the output image. + iferr { + do i = 1, nimages { + im = Memi[in+i-1] + call imstats (im, IM_IMAGENAME, input, SZ_FNAME) + if (strmatch (headers, ".fits$") == 0) { + call sprintf (errstr, SZ_LINE, "%s.fits[append]") + call pargstr (headers) + } else { + call sprintf (errstr, SZ_LINE, "%s[append]") + call pargstr (headers) + } + tmp = immap (errstr, NEW_COPY, im) + IM_NDIM(tmp) = 0 + do j = 1, IM_NDIM(im) { + call sprintf (errstr, SZ_LINE, "AXLEN%d") + call pargi (j) + call imaddi (tmp, errstr, IM_LEN(im,j)) + } + call imastr (tmp, "INIMAGE", input) + call imastr (tmp, "OUTIMAGE", output) + call imastr (tmp, "EXTNAME", input) + call imunmap (tmp) + } + if (logfd != NULL) { + call eprintf (" Headers = %s\n") + call pargstr (headers) + } + } then + call erract (EA_WARN) + } + } + if (!project) { + do i = 2, nimages { + if (Memi[in+i-1] != NULL) + call xt_imunmap (Memi[in+i-1], i) + } + } + if (Memi[in] != NULL) + call xt_imunmap (Memi[in], 1) + if (in1 != NULL) + call imunmap (in1) + if (stack1 == YES) { + call imdelete (input) + if (Memc[bpmstack] != EOS) + call imdelete (Memc[bpmstack]) + project = proj + } + if (logfd != NULL) + call close (logfd) + call ic_mclose (nimages) + call fixmem (oldsize) + call sfree (sp) +end diff --git a/pkg/images/immatch/src/imcombine/src/icpclip.gx b/pkg/images/immatch/src/imcombine/src/icpclip.gx new file mode 100644 index 00000000..628dca0d --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/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 = max (0, 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 = max (0, 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 == max (0, 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 (max (0, 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/images/immatch/src/imcombine/src/icpmmap.x b/pkg/images/immatch/src/imcombine/src/icpmmap.x new file mode 100644 index 00000000..1afeedd7 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icpmmap.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pmset.h> + + +# 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 diff --git a/pkg/images/immatch/src/imcombine/src/icquad.gx b/pkg/images/immatch/src/imcombine/src/icquad.gx new file mode 100644 index 00000000..4ecf3aa0 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icquad.gx @@ -0,0 +1,133 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> +include "../icombine.h" +include "../icmask.h" + +$for (sird) +# IC_QUAD -- Compute the quadrature average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_quad$t (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +$if (datatype == sil) +real average[npts] # Average (returned) +$else +PIXEL average[npts] # Average (returned) +$endif + +int i, j, k, n1 +real val, wt, sumwt +$if (datatype == sil) +real sum +$else +PIXEL sum +$endif + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum 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/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = Mem$t[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + do j = 2, n[i] { + val = Mem$t[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val * wt) ** 2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = Mem$t[d[1]+k] + sum = val**2 + do j = 2, n[i] { + val = Mem$t[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Mem$t[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + sumwt = wt + do j = 2, n1 { + val = Mem$t[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val* wt) ** 2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = Mem$t[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Mem$t[d[j]+k] + sum = sum + val**2 + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Mem$t[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Mem$t[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icrmasks.x b/pkg/images/immatch/src/imcombine/src/icrmasks.x new file mode 100644 index 00000000..8b9a0c3d --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/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/images/immatch/src/imcombine/src/icscale.x b/pkg/images/immatch/src/imcombine/src/icscale.x new file mode 100644 index 00000000..42d62f8d --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icscale.x @@ -0,0 +1,351 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include "icombine.h" + + +# IC_SCALE -- Get and set the scaling factors. +# +# If the scaling parameters have been set earlier then this routine +# just normalizes the factors and writes the log output. +# When dealing with individual images using image statistics for scaling +# factors this routine determines the image statistics rather than being +# done earlier since the input images have all been mapped at this stage. + +procedure ic_scale (in, out, offsets, scales, zeros, wts, nimages) + +pointer in[nimages] # Input images +pointer out[ARB] # 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, sumwts +pointer sp, ncombine, exptime, modes, medians, means +pointer section, str, sname, zname, wname, im, imref +bool domode, domedian, domean, dozero, dos, doz, dow, snorm, znorm, wflag + +int imgeti(), strdic(), ic_gscale() +real imgetr(), asumr(), asumi() +pointer xt_opix() +errchk ic_gscale, xt_opix, 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 (section, SZ_LINE, 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) + + # Get the number of images previously combined and the exposure times. + # The default combine number is 1 and the default exposure is 0. + + do i = 1, nimages { + iferr (Memi[ncombine+i-1] = imgeti (in[i], "ncombine")) + Memi[ncombine+i-1] = 1 + if (Memc[expkeyword] != EOS) { + iferr (Memr[exptime+i-1] = imgetr (in[i], Memc[expkeyword])) + Memr[exptime+i-1] = 0. + } else + Memr[exptime+i-1] = 0. + if (project) { + call amovki (Memi[ncombine], Memi[ncombine], nimages) + call amovkr (Memr[exptime], Memr[exptime], nimages) + break + } + } + + # Set scaling type and 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 if needed. + dos = ((stype==S_MODE)||(stype==S_MEDIAN)||(stype==S_MEAN)) + doz = ((ztype==S_MODE)||(ztype==S_MEDIAN)||(ztype==S_MEAN)) + dow = ((wtype==S_MODE)||(wtype==S_MEDIAN)||(wtype==S_MEAN)) + if (dos) { + dos = false + do i = 1, nimages + if (IS_INDEFR(scales[i])) { + dos = true + break + } + } + if (doz) { + doz = false + do i = 1, nimages + if (IS_INDEFR(zeros[i])) { + doz = true + break + } + } + if (dow) { + dow = false + do i = 1, nimages + if (IS_INDEFR(wts[i])) { + dow = true + break + } + } + + if (dos || doz || dow) { + 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)) + + Memc[section] = EOS + Memc[str] = EOS + call sscan (Memc[statsec]) + 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 { + im = xt_opix (in[i], i, 0) + if (imref != out[1]) + imref = im + if ((dos && IS_INDEFR(scales[i])) || + (doz && IS_INDEFR(zeros[i])) || + (dow && IS_INDEFR(wts[i]))) { + call ic_statr (im, imref, Memc[section], offsets, i, + nimages, domode, domedian, domean, mode, median, mean) + if (domode) { + if (stype == S_MODE && IS_INDEFR(scales[i])) + scales[i] = mode + if (ztype == S_MODE && IS_INDEFR(zeros[i])) + zeros[i] = mode + if (wtype == S_MODE && IS_INDEFR(wts[i])) + wts[i] = mode + } + if (domedian) { + if (stype == S_MEDIAN && IS_INDEFR(scales[i])) + scales[i] = median + if (ztype == S_MEDIAN && IS_INDEFR(zeros[i])) + zeros[i] = median + if (wtype == S_MEDIAN && IS_INDEFR(wts[i])) + wts[i] = median + } + if (domean) { + if (stype == S_MEAN && IS_INDEFR(scales[i])) + scales[i] = mean + if (ztype == S_MEAN && IS_INDEFR(zeros[i])) + zeros[i] = mean + if (wtype == S_MEAN && IS_INDEFR(wts[i])) + wts[i] = mean + } + } + } + } + + # Save the image statistics if computed. + call amovkr (INDEFR, Memr[modes], nimages) + call amovkr (INDEFR, Memr[medians], nimages) + call amovkr (INDEFR, Memr[means], nimages) + if (stype == S_MODE) + call amovr (scales, Memr[modes], nimages) + if (stype == S_MEDIAN) + call amovr (scales, Memr[medians], nimages) + if (stype == S_MEAN) + call amovr (scales, Memr[means], nimages) + if (ztype == S_MODE) + call amovr (zeros, Memr[modes], nimages) + if (ztype == S_MEDIAN) + call amovr (zeros, Memr[medians], nimages) + if (ztype == S_MEAN) + call amovr (zeros, Memr[means], nimages) + if (wtype == S_MODE) + call amovr (wts, Memr[modes], nimages) + if (wtype == S_MEDIAN) + call amovr (wts, Memr[medians], nimages) + if (wtype == S_MEAN) + call amovr (wts, Memr[means], nimages) + + # If nothing else has set the scaling factors set them to defaults. + do i = 1, nimages { + if (IS_INDEFR(scales[i])) + scales[i] = 1. + if (IS_INDEFR(zeros[i])) + zeros[i] = 0. + if (IS_INDEFR(wts[i])) + wts[i] = 1. + } + + 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 factors relative to the first image. + 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) + mean = scales[1] + call adivkr (scales, mean, scales, nimages) + call adivr (zeros, scales, zeros, 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] * zeros[1] / 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. + + mean = zeros[1] + call asubkr (zeros, mean, 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) + if (mean > 0.) + call adivkr (wts, mean, wts, nimages) + else { + call eprintf ("WARNING: Mean weight is zero -- using no weights\n") + call amovkr (1., wts, nimages) + mean = 1. + } + + # 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 + } + } + } + + # Set the output header parameters. + nout = asumi (Memi[ncombine], nimages) + call imaddi (out[1], "ncombine", nout) + mean = 0. + sumwts = 0. + do i = 1, nimages { + ifnoerr (mode = imgetr (in[i], "ccdmean")) { + mean = mean + wts[i] * mode / scales[i] + sumwts = sumwts + wts[i] + } + } + if (sumwts > 0.) { + mean = mean / sumwts + ifnoerr (mode = imgetr (out[1], "ccdmean")) { + call imaddr (out[1], "ccdmean", mean) + iferr (call imdelf (out[1], "ccdmeant")) + ; + } + } + if (out[2] != NULL) { + call imstats (out[2], IM_IMAGENAME, Memc[str], SZ_FNAME) + call imastr (out[1], "BPM", Memc[str]) + } + + # Start the log here since much of the info is only available here. + if (verbose) { + i = logfd + logfd = STDOUT + 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) + + logfd = i + } + 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) + + doscale = (doscale || dozero) + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/imcombine/src/icsclip.gx b/pkg/images/immatch/src/imcombine/src/icsclip.gx new file mode 100644 index 00000000..e4d8f027 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 (max (0, 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 = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, 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 (max (0, 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/images/immatch/src/imcombine/src/icsection.x b/pkg/images/immatch/src/imcombine/src/icsection.x new file mode 100644 index 00000000..746c1f51 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/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/images/immatch/src/imcombine/src/icsetout.x b/pkg/images/immatch/src/imcombine/src/icsetout.x new file mode 100644 index 00000000..efe55681 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icsetout.x @@ -0,0 +1,332 @@ +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[ARB] # Output images +int offsets[nimages,ARB] # Offsets +int nimages # Number of images + +int i, j, indim, outdim, mwdim, a, b, amin, bmax, fd, offtype, npix +real val +bool proj, reloff, flip, streq(), fp_equald() +pointer sp, str, fname +pointer ltv, lref, wref, cd, ltm, coord, shift, axno, axval, section +pointer mw, ct, mw_openim(), mw_sctran(), xt_immap() +int open(), fscan(), nscan(), mw_stati(), strlen(), strdic() +errchk mw_openim, mw_gwtermd, mw_gltermd, mw_gaxmap +errchk mw_sctran, mw_ctrand, open, xt_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 (ltv, IM_MAXDIM, TY_DOUBLE) + call salloc (ltm, IM_MAXDIM*IM_MAXDIM, TY_DOUBLE) + 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]) + proj = (indim != outdim) + if (!proj) { + 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]) + call mw_seti (mw, MW_USEAXMAP, NO) + mwdim = mw_stati (mw, MW_NPHYSDIM) + call mw_gwtermd (mw, Memd[lref], Memd[wref], Memd[cd], mwdim) + ct = mw_sctran (mw, "world", "logical", 0) + call mw_ctrand (ct, Memd[wref], Memd[lref], mwdim) + call mw_ctfree (ct) + if (proj) + 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 (proj) { + 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 { + ct = mw_sctran (mw, "world", "logical", 0) + call mw_ctrand (ct, Memd[wref], Memd[lref], indim) + 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 (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 xt_imunmap (in[i], i) + in[i] = xt_immap (Memc[fname], READ_ONLY, TY_CHAR, i, 0) + 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[ltv], indim) + call mw_ctfree (ct) + do j = 1, outdim + offsets[1,j] = 0 + if (proj) { + ct = mw_sctran (mw, "physical", "logical", 0) + do i = 2, nimages { + Memd[ltv+outdim] = i + call mw_ctrand (ct, Memd[ltv], 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[ltv], 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) { + a = 1 + b = 0 + } + 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 + } + } + + # Get the output limits. + call clgstr ("outlimits", Memc[fname], SZ_FNAME) + call sscan (Memc[fname]) + do j = 1, outdim { + call gargi (a) + call gargi (b) + if (nscan() < 2*j) + break + if (!IS_INDEFI(a)) { + do i = 1, nimages { + offsets[i,j] = offsets[i,j] - a + 1 + if (offsets[i,j] != 0) + aligned = false + } + IM_LEN(out[1],j) = IM_LEN(out[1],j) - a + 1 + } + if (!IS_INDEFI(a) && !IS_INDEFI(b)) + IM_LEN(out[1],j) = min (IM_LEN(out[1],j), b - a + 1) + } + + # Update the WCS. + if (proj || !aligned || !reloff) { + call mw_close (mw) + mw = mw_openim (out[1]) + mwdim = mw_stati (mw, MW_NPHYSDIM) + call mw_gaxmap (mw, Memi[axno], Memi[axval], mwdim) + if (!aligned || !reloff) { + call mw_gltermd (mw, Memd[cd], Memd[lref], mwdim) + do i = 1, mwdim { + j = Memi[axno+i-1] + if (j > 0 && j <= indim) + Memd[lref+i-1] = Memd[lref+i-1] + offsets[1,j] + } + if (proj) + Memd[lref+mwdim-1] = 0. + call mw_sltermd (mw, Memd[cd], Memd[lref], mwdim) + } + if (proj) { + # Apply dimensional reduction. + do i = 1, mwdim { + j = Memi[axno+i-1] + if (j <= outdim) + next + else if (j > outdim+1) + Memi[axno+i-1] = j - 1 + else { + Memi[axno+i-1] = 0 + Memi[axval+i-1] = 0 + } + } + call mw_saxmap (mw, Memi[axno], Memi[axval], mwdim) + } + + # Reset physical coordinates. + if (offtype == WCS || offtype == WORLD) { + call mw_gltermd (mw, Memd[ltm], Memd[ltv], mwdim) + call mw_gwtermd (mw, Memd[lref], Memd[wref], Memd[cd], mwdim) + call mwvmuld (Memd[ltm], Memd[lref], Memd[lref], mwdim) + call aaddd (Memd[lref], Memd[ltv], Memd[lref], mwdim) + call mwinvertd (Memd[ltm], Memd[ltm], mwdim) + call mwmmuld (Memd[cd], Memd[ltm], Memd[cd], mwdim) + call mw_swtermd (mw, Memd[lref], Memd[wref], Memd[cd], mwdim) + call aclrd (Memd[ltv], mwdim) + call aclrd (Memd[ltm], mwdim*mwdim) + do i = 1, mwdim + Memd[ltm+(i-1)*(mwdim+1)] = 1. + call mw_sltermd (mw, Memd[ltm], Memd[ltv], mwdim) + } + call mw_saveim (mw, out) + } + call mw_close (mw) + + # Throw an error if the output size is too large. + if (offtype != NONE) { + npix = IM_LEN(out[1],1) + do i = 2, outdim + npix = npix * IM_LEN(out[1],i) + npix = npix / 1000000000 + if (npix > 100) + call error (1, "Output has more than 100 Gpixels (check offsets)") + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/imcombine/src/icsigma.gx b/pkg/images/immatch/src/imcombine/src/icsigma.gx new file mode 100644 index 00000000..1304d940 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icsigma.gx @@ -0,0 +1,122 @@ +# 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 + } + if (sumwt > 0) + sigma[i] = sqrt (sum / sumwt * sigcor) + else { + 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 / n1 * 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/images/immatch/src/imcombine/src/icsort.gx b/pkg/images/immatch/src/imcombine/src/icsort.gx new file mode 100644 index 00000000..e124da15 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/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/images/immatch/src/imcombine/src/icstat.gx b/pkg/images/immatch/src/imcombine/src/icstat.gx new file mode 100644 index 00000000..c594182b --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icstat.gx @@ -0,0 +1,238 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + +define NMAX 100000 # 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() + +$if (datatype == csir) +real asum$t() +$else $if (datatype == ld) +double asum$t() +$else +PIXEL asum$t() +$endif $endif +PIXEL ic_mode$t() + +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, nimages, 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) + } + + # Close mask until it is needed again. + call ic_mclose1 (image, nimages) + + 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.7 # 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/images/immatch/src/imcombine/src/mkpkg b/pkg/images/immatch/src/imcombine/src/mkpkg new file mode 100644 index 00000000..5f53d4b8 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/mkpkg @@ -0,0 +1,67 @@ +# Make the IMCOMBINE library. + +update: + $checkout libimc.a lib$ + $update libimc.a + $checkin libimc.a lib$ + ; + +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/icquad.x, icquad.gx) + $(GEN) icquad.gx -o generic/icquad.x $endif + $ifolder (generic/icnmodel.x, icnmodel.gx) + $(GEN) icnmodel.gx -o generic/icnmodel.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/icomb.x, icomb.gx) + $(GEN) icomb.gx -o generic/icomb.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 + + $ifolder (generic/xtimmap.x, xtimmap.gx) + $(GEN) xtimmap.gx -o generic/xtimmap.x $endif + ; + +libimc.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + @generic + + icemask.x <imhdr.h> <mach.h> + icgscale.x icombine.com icombine.h + ichdr.x <imset.h> + icimstack.x <error.h> <imhdr.h> + iclog.x icmask.h icombine.com icombine.h <imhdr.h> <imset.h>\ + <mach.h> + icmask.x icmask.h icombine.com icombine.h <imhdr.h> <pmset.h> + icombine.x icombine.com icombine.h <error.h> <imhdr.h> <imset.h> + icpmmap.x <pmset.h> + icrmasks.x <imhdr.h> + icscale.x icombine.com icombine.h <imhdr.h> <imset.h> + icsection.x <ctype.h> + icsetout.x icombine.com <imhdr.h> <imset.h> <mwset.h> + tymax.x <mach.h> + xtprocid.x + ; diff --git a/pkg/images/immatch/src/imcombine/src/tymax.x b/pkg/images/immatch/src/imcombine/src/tymax.x new file mode 100644 index 00000000..a7f4f469 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/tymax.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + + +# 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 diff --git a/pkg/images/immatch/src/imcombine/src/xtimmap.gx b/pkg/images/immatch/src/imcombine/src/xtimmap.gx new file mode 100644 index 00000000..2e6cfb1e --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/xtimmap.gx @@ -0,0 +1,634 @@ +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imset.h> +include <config.h> + +# The following is for compiling under V2.11. +define IM_BUFFRAC IM_BUFSIZE +include <imset.h> + +define VERBOSE false + +# These routines maintain an arbitrary number of indexed "open" images which +# must be READ_ONLY. The calling program may use the returned pointer for +# header accesses but must call xt_opix before I/O. Subsequent calls to +# xt_opix may invalidate the pointer. The xt_imunmap call will free memory. + +define MAX_OPENIM (LAST_FD-16) # Maximum images kept open +define MAX_OPENPIX 45 # Maximum pixel files kept open + +define XT_SZIMNAME 299 # Size of IMNAME string +define XT_LEN 179 # Structure length +define XT_IMNAME Memc[P2C($1)] # Image name +define XT_ARG Memi[$1+150] # IMMAP header argument +define XT_IM Memi[$1+151] # IMIO pointer +define XT_HDR Memi[$1+152] # Copy of IMIO pointer +define XT_CLOSEFD Memi[$1+153] # Close FD? +define XT_FLAG Memi[$1+154] # Flag +define XT_BUFSIZE Memi[$1+155] # Buffer size +define XT_BUF Memi[$1+156] # Data buffer +define XT_BTYPE Memi[$1+157] # Data buffer type +define XT_VS Memi[$1+157+$2] # Start vector (10) +define XT_VE Memi[$1+167+$2] # End vector (10) + +# Options +define XT_MAPUNMAP 1 # Map and unmap images. + +# XT_IMMAP -- Map an image and save it as an indexed open image. +# The returned pointer may be used for header access but not I/O. +# The indexed image is closed by xt_imunmap. + +pointer procedure xt_immap (imname, acmode, hdr_arg, index, retry) + +char imname[ARB] #I Image name +int acmode #I Access mode +int hdr_arg #I Header argument +int index #I Save index +int retry #I Retry counter +pointer im #O Image pointer (returned) + +int i, envgeti() +pointer xt, xt_opix() +errchk xt_opix + +int first_time +data first_time /YES/ + +include "xtimmap.com" + +begin + if (acmode != READ_ONLY) + call error (1, "XT_IMMAP: Only READ_ONLY allowed") + + # Set maximum number of open images based on retry. + if (retry > 0) + max_openim = min (1024, MAX_OPENIM) / retry + else + max_openim = MAX_OPENIM + + # Initialize once per process. + if (first_time == YES) { + iferr (option = envgeti ("imcombine_option")) + option = 1 + min_open = 1 + nopen = 0 + nopenpix = 0 + nalloc = max_openim + call calloc (ims, nalloc, TY_POINTER) + first_time = NO + } + + # Free image if needed. + call xt_imunmap (NULL, index) + + # Allocate structure. + if (index > nalloc) { + i = nalloc + nalloc = index + max_openim + call realloc (ims, nalloc, TY_STRUCT) + call amovki (NULL, Memi[ims+i], nalloc-i) + } + call calloc (xt, XT_LEN, TY_STRUCT) + Memi[ims+index-1] = xt + + # Initialize. + call strcpy (imname, XT_IMNAME(xt), XT_SZIMNAME) + XT_ARG(xt) = hdr_arg + XT_IM(xt) = NULL + XT_HDR(xt) = NULL + + # Open image. + last_flag = 0 + im = xt_opix (NULL, index, 0) + + # Make copy of IMIO pointer for header keyword access. + call malloc (XT_HDR(xt), LEN_IMDES+IM_HDRLEN(im)+1, TY_STRUCT) + call amovi (Memi[im], Memi[XT_HDR(xt)], LEN_IMDES) + call amovi (IM_MAGIC(im), IM_MAGIC(XT_HDR(xt)), IM_HDRLEN(im)+1) + + return (XT_HDR(xt)) +end + + +# XT_OPIX -- Open the image for I/O. +# If the image has not been mapped return the default pointer. + +pointer procedure xt_opix (imdef, index, flag) + +int index #I index +pointer imdef #I Default pointer +int flag #I Flag + +int i, open(), imstati() +pointer im, xt, xt1, immap() +errchk open, immap, imunmap + +include "xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imdef) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + if (VERBOSE) { + call eprintf ("%d: xt_opix imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Return pointer for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (im) + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= max_openim) { + if (option == XT_MAPUNMAP || flag == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + if (VERBOSE) { + call eprintf ("%d: imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + if (VERBOSE) { + call eprintf ("%d: xt_opix immap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + if (!IS_INDEFI(XT_BUFSIZE(xt))) + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + else + XT_BUFSIZE(xt) = imstati (im, IM_BUFSIZE) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (im) +end + + +# XT_CPIX -- Close image. + +procedure xt_cpix (index) + +int index #I index + +pointer xt +errchk imunmap + +include "xtimmap.com" + +begin + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + if (xt == NULL) + return + + if (XT_IM(xt) != NULL) { + if (VERBOSE) { + call eprintf ("%d: xt_cpix imunmap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + call imunmap (XT_IM(xt)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt) == NO) + nopenpix = nopenpix - 1 + } + call mfree (XT_BUF(xt), XT_BTYPE(xt)) +end + + +# XT_IMSETI -- Set IMIO value. + +procedure xt_imseti (index, param, value) + +int index #I index +int param #I IMSET parameter +int value #I Value + +pointer xt +bool streq() + +include "xtimmap.com" + +begin + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + if (xt == NULL) { + if (streq (param, "option")) + option = value + } else { + if (streq (param, "bufsize")) { + XT_BUFSIZE(xt) = value + if (XT_IM(xt) != NULL) { + call imseti (XT_IM(xt), IM_BUFFRAC, 0) + call imseti (XT_IM(xt), IM_BUFSIZE, value) + } + } + } +end + + +# XT_IMUNMAP -- Unmap indexed open image. +# The header pointer is set to NULL to indicate the image has been closed. + +procedure xt_imunmap (im, index) + +int im #U IMIO header pointer +int index #I index + +pointer xt +errchk imunmap + +include "xtimmap.com" + +begin + # Check for an indexed image. If it is not unmap the pointer + # as a regular IMIO pointer. + + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + if (xt == NULL) { + if (im != NULL) + call imunmap (im) + return + } + + # Close indexed image. + if (XT_IM(xt) != NULL) { + if (VERBOSE) { + call eprintf ("%d: xt_imunmap imunmap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + iferr (call imunmap (XT_IM(xt))) { + XT_IM(xt) = NULL + call erract (EA_WARN) + } + nopen = nopen - 1 + if (XT_CLOSEFD(xt) == NO) + nopenpix = nopenpix - 1 + if (index == min_open) + min_open = 1 + } + + # Free any buffered memory. + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + + # Free header pointer. Note that if the supplied pointer is not + # header pointer then it is not set to NULL. + if (XT_HDR(xt) == im) + im = NULL + call mfree (XT_HDR(xt), TY_STRUCT) + + # Free save structure. + call mfree (Memi[ims+index-1], TY_STRUCT) + Memi[ims+index-1] = NULL +end + + +# XT_MINHDR -- Minimize header assuming keywords will not be accessed. + +procedure xt_minhdr (index) + +int index #I index + +pointer xt +errchk realloc + +include "xtimmap.com" + +begin + # Check for an indexed image. If it is not unmap the pointer + # as a regular IMIO pointer. + + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + if (xt == NULL) + return + + # Minimize header pointer. + if (VERBOSE) { + call eprintf ("%d: xt_minhdr %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + call realloc (XT_HDR(xt), IMU+1, TY_STRUCT) + if (XT_IM(xt) != NULL) + call realloc (XT_IM(xt), IMU+1, TY_STRUCT) +end + + +# XT_REINDEX -- Reindex open images. +# This is used when some images are closed by xt_imunmap. It is up to +# the calling program to reindex the header pointers and to subsequently +# use the new index values. + +procedure xt_reindex () + +int old, new + +include "xtimmap.com" + +begin + new = 0 + do old = 0, nalloc-1 { + if (Memi[ims+old] == NULL) + next + Memi[ims+new] = Memi[ims+old] + new = new + 1 + } + do old = new, nalloc-1 + Memi[ims+old] = NULL +end + + +$for(sird) +# XT_IMGNL -- Return the next line for the indexed image. +# Possibly unmap another image if too many files are open. +# Buffer data when an image is unmmaped to minimize the mapping of images. +# If the requested index has not been mapped use the default pointer. + +int procedure xt_imgnl$t (imdef, index, buf, v, flag) + +pointer imdef #I Default pointer +int index #I index +pointer buf #O Data buffer +long v[ARB] #I Line vector +int flag #I Flag (=output line) + +int i, j, nc, nl, open(), imgnl$t(), sizeof(), imloop() +pointer im, xt, xt1, ptr, immap(), imggs$t() +errchk open, immap, imgnl$t, imggs$t, imunmap + +long unit_v[IM_MAXDIM] +data unit_v /IM_MAXDIM * 1/ + +include "xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imgnl$t (imdef, buf, v)) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Use IMIO for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (imgnl$t (im, buf, v)) + } + + # If the image is not currently mapped use the stored header. + im = XT_HDR(xt) + + # Check for EOF. + i = IM_NDIM(im) + if (v[i] > IM_LEN(im,i)) + return (EOF) + + # Check for buffered data. + if (XT_BUF(xt) != NULL) { + if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { + if (XT_BTYPE(xt) != TY_PIXEL) + call error (1, "Cannot mix data types") + nc = IM_LEN(im,1) + buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) + XT_FLAG(xt) = flag + if (i == 1) + v[1] = nc + 1 + else + j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) + return (nc) + } + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= max_openim) { + if (option == XT_MAPUNMAP || v[2] == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + + # Buffer some number of lines. + nl = XT_BUFSIZE(xt1) / sizeof (TY_PIXEL) / IM_LEN(im,1) + if (nl > 1) { + nc = IM_LEN(im,1) + call amovl (v, XT_VS(xt1,1), IM_MAXDIM) + call amovl (v, XT_VE(xt1,1), IM_MAXDIM) + XT_VS(xt1,1) = 1 + XT_VE(xt1,1) = nc + XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) + nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 + XT_BTYPE(xt1) = TY_PIXEL + call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) + ptr = imggs$t (im, XT_VS(xt1,1), XT_VE(xt1,1), + IM_NDIM(im)) + call amov$t (Mem$t[ptr], Mem$t[XT_BUF(xt1)], nl*nc) + } + + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + if (XT_IM(xt1) == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + if (VERBOSE) { + call eprintf ("%d: xt_imgnl immap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (imgnl$t (im, buf, v)) +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/xtprocid.x b/pkg/images/immatch/src/imcombine/src/xtprocid.x new file mode 100644 index 00000000..0a82d81b --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/xtprocid.x @@ -0,0 +1,38 @@ +# XT_PROCID -- Set or ppdate PROCID keyword. + +procedure xt_procid (im) + +pointer im #I Image header + +int i, j, ver, patmake(), gpatmatch(), strlen(), ctoi() +pointer sp, pat, str + +begin + call smark (sp) + call salloc (pat, SZ_LINE, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Get current ID. + iferr (call imgstr (im, "PROCID", Memc[str], SZ_LINE)) { + iferr (call imgstr (im, "OBSID", Memc[str], SZ_LINE)) { + call sfree (sp) + return + } + } + + # Set new PROCID. + ver = 0 + i = patmake ("V[0-9]*$", Memc[pat], SZ_LINE) + if (gpatmatch (Memc[str], Memc[pat], i, j) == 0) + ; + if (j > 0) { + j = i+1 + if (ctoi (Memc[str], j, ver) == 0) + ver = 0 + i = i - 1 + } else + i = strlen (Memc[str]) + call sprintf (Memc[str+i], SZ_LINE, "V%d") + call pargi (ver+1) + call imastr (im, "PROCID", Memc[str]) +end diff --git a/pkg/images/immatch/src/imcombine/t_imcombine.x b/pkg/images/immatch/src/imcombine/t_imcombine.x new file mode 100644 index 00000000..d3774958 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/t_imcombine.x @@ -0,0 +1,230 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <mach.h> +include <imhdr.h> +include "src/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, fname, output, headers, bmask, rmask, sigma, nrmask, emask, logfile +pointer scales, zeros, wts, im +int n, input, ilist, olist, hlist, blist, rlist, slist, nrlist, elist + +bool clgetb() +real clgetr() +int clgwrd(), clgeti(), imtopenp(), imtopen(), imtgetim(), imtlen() +pointer immap() +errchk immap, icombine + +include "src/icombine.com" + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (headers, SZ_FNAME, TY_CHAR) + call salloc (bmask, SZ_FNAME, TY_CHAR) + call salloc (rmask, SZ_FNAME, TY_CHAR) + call salloc (nrmask, SZ_FNAME, TY_CHAR) + call salloc (emask, SZ_FNAME, TY_CHAR) + call salloc (sigma, SZ_FNAME, TY_CHAR) + call salloc (expkeyword, SZ_FNAME, TY_CHAR) + call salloc (statsec, 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") + hlist = imtopenp ("headers") + blist = imtopenp ("bpmasks") + rlist = imtopenp ("rejmasks") + nrlist = imtopenp ("nrejmasks") + elist = imtopenp ("expmasks") + slist = imtopenp ("sigmas") + call clgstr ("logfile", Memc[logfile], SZ_FNAME) + + project = clgetb ("project") + combine = clgwrd ("combine", Memc[fname], SZ_FNAME, COMBINE) + if (combine == MEDIAN || combine == LMEDIAN) { + if (combine == MEDIAN) + medtype = MEDAVG + else { + medtype = MEDLOW + combine = MEDIAN + } + } + reject = clgwrd ("reject", Memc[fname], SZ_FNAME, REJECT) + blank = clgetr ("blank") + call clgstr ("expname", Memc[expkeyword], SZ_FNAME) + call clgstr ("statsec", Memc[statsec], SZ_FNAME) + 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") + verbose = false + + # 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 output images") + if (imtlen (hlist) != 0 && imtlen (hlist) != n) + call error (1, "Wrong number of header files") + if (imtlen (blist) != 0 && imtlen (blist) != n) + call error (1, "Wrong number of bad pixel masks") + if (imtlen (rlist) != 0 && imtlen (rlist) != n) + call error (1, "Wrong number of rejection masks") + if (imtlen (nrlist) > 0 && imtlen (nrlist) != n) + call error (1, "Wrong number of number rejected masks") + if (imtlen (elist) > 0 && imtlen (elist) != n) + call error (1, "Wrong number of exposure masks") + if (imtlen (slist) > 0 && imtlen (slist) != n) + call error (1, "Wrong number of sigma images") + } else { + if (imtlen (olist) != 1) + call error (1, "Wrong number of output images") + if (imtlen (hlist) > 1) + call error (1, "Wrong number of header files") + if (imtlen (blist) > 1) + call error (1, "Wrong number of bad pixel masks") + if (imtlen (rlist) > 1) + call error (1, "Wrong number of rejection masks") + if (imtlen (nrlist) > 1) + call error (1, "Wrong number of number rejected masks") + if (imtlen (elist) > 1) + call error (1, "Wrong number of exposure masks") + if (imtlen (slist) > 1) + call error (1, "Wrong number of sigma images") + } + + # 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. + while (imtgetim (ilist, Memc[fname], SZ_FNAME) != EOF) { + iferr { + scales = NULL; input = ilist + + if (imtgetim (olist, Memc[output], SZ_FNAME) == EOF) { + if (project) { + call sprintf (Memc[output], SZ_FNAME, + "IMCOMBINE: No output image for %s") + call pargstr (Memc[fname]) + call error (1, Memc[output]) + } else + call error (1, "IMCOMBINE: No output image") + } + if (imtgetim (hlist, Memc[headers], SZ_FNAME) == EOF) + Memc[headers] = EOS + if (imtgetim (blist, Memc[bmask], SZ_FNAME) == EOF) + Memc[bmask] = EOS + if (imtgetim (rlist, Memc[rmask], SZ_FNAME) == EOF) + Memc[rmask] = EOS + if (imtgetim (nrlist, Memc[nrmask], SZ_FNAME) == EOF) + Memc[nrmask] = EOS + if (imtgetim (elist, Memc[emask], SZ_FNAME) == EOF) + Memc[emask] = EOS + if (imtgetim (slist, Memc[sigma], SZ_FNAME) == EOF) + Memc[sigma] = EOS + + # Set the input list and initialize the scaling factors. + if (project) { + im = immap (Memc[fname], READ_ONLY, 0) + if (IM_NDIM(im) == 1) + n = 0 + else + n = IM_LEN(im,IM_NDIM(im)) + call imunmap (im) + if (n == 0) { + call sprintf (Memc[output], SZ_FNAME, + "IMCOMBINE: Can't project one dimensional image %s") + call pargstr (Memc[fname]) + call error (1, Memc[output]) + } + input = imtopen (Memc[fname]) + } else { + call imtrew (ilist) + n = imtlen (ilist) + input = ilist + } + + # Allocate and initialize scaling factors. + call malloc (scales, 3*n, TY_REAL) + zeros = scales + n + wts = scales + 2 * n + call amovkr (INDEFR, Memr[scales], 3*n) + + call icombine (input, Memc[output], Memc[headers], Memc[bmask], + Memc[rmask], Memc[nrmask], Memc[emask], Memc[sigma], + Memc[logfile], Memr[scales], Memr[zeros], Memr[wts], + NO, NO, NO) + + } then + call erract (EA_WARN) + + if (input != ilist) + call imtclose (input) + call mfree (scales, TY_REAL) + if (!project) + break + } + + call imtclose (ilist) + call imtclose (olist) + call imtclose (hlist) + call imtclose (blist) + call imtclose (rlist) + call imtclose (nrlist) + call imtclose (elist) + call imtclose (slist) + call sfree (sp) +end diff --git a/pkg/images/immatch/src/imcombine/x_imcombine.x b/pkg/images/immatch/src/imcombine/x_imcombine.x new file mode 100644 index 00000000..a85e34f6 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/x_imcombine.x @@ -0,0 +1 @@ +task imcombine = t_imcombine diff --git a/pkg/images/immatch/src/linmatch/linmatch.h b/pkg/images/immatch/src/linmatch/linmatch.h new file mode 100644 index 00000000..0f776901 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/linmatch.h @@ -0,0 +1,298 @@ +# Header file for LINSCALE + +define LEN_LSSTRUCT (70 + 12 * SZ_FNAME + 12) + +# Quantities that define the current region and the number of regions + +define LS_CNREGION Memi[$1] # the current region +define LS_NREGIONS Memi[$1+1] # the number of regions +define LS_MAXNREGIONS Memi[$1+2] # the maximum number of regions + +# Quantities that are dependent on the number of regions + +define LS_RC1 Memi[$1+3] # pointers to first columns of regions +define LS_RC2 Memi[$1+4] # pointers to last columns of regions +define LS_RL1 Memi[$1+5] # pointer to first lines of regions +define LS_RL2 Memi[$1+6] # pointers to last lines of regions +define LS_RXSTEP Memi[$1+7] # pointers to the x step sizes +define LS_RYSTEP Memi[$1+8] # pointers to the y step sizes +define LS_XSHIFT Memr[P2R($1+9)] # the x shift from image to reference +define LS_YSHIFT Memr[P2R($1+10)] # the y shift from image to reference +define LS_SXSHIFT Memr[P2R($1+11)] # the x shift from image to reference +define LS_SYSHIFT Memr[P2R($1+12)] # the y shift from image to reference + +define LS_RBUF Memi[$1+14] # pointer to the reference image data +define LS_RGAIN Memr[P2R($1+15)] # the reference image gain +define LS_RREADNOISE Memr[P2R($1+16)] # the reference image readout noise +define LS_RMEAN Memi[$1+17] # pointers to means of ref regions +define LS_RMEDIAN Memi[$1+18] # pointers to medians of ref regions +define LS_RMODE Memi[$1+19] # pointers to modes of ref regions +define LS_RSIGMA Memi[$1+20] # pointers to stdevs of ref regions +define LS_RSKY Memi[$1+21] # pointers to sky values of ref regions +define LS_RSKYERR Memi[$1+22] # pointers to sky errors of ref regions +define LS_RMAG Memi[$1+23] # pointers to magnitudes of ref regions +define LS_RMAGERR Memi[$1+24] # pointers to mag errors of ref regions +define LS_RNPTS Memi[$1+25] # pointers to npts of ref regions + +define LS_IBUF Memi[$1+27] # pointer to the input image data +define LS_IGAIN Memr[P2R($1+28)] # the input image gain +define LS_IREADNOISE Memr[P2R($1+29)] # the input image readout noise +define LS_IMEAN Memi[$1+30] # pointers to means of image regions +define LS_IMEDIAN Memi[$1+31] # pointers to medians of image regions +define LS_IMODE Memi[$1+32] # pointers to modes of image regions +define LS_ISIGMA Memi[$1+33] # pointers to stdevs of image regions +define LS_ISKY Memi[$1+34] # pointers to sky values of image regions +define LS_ISKYERR Memi[$1+35] # pointers to sky errors of image regions +define LS_IMAG Memi[$1+36] # pointers to magnitudes of image regions +define LS_IMAGERR Memi[$1+37] # pointers to mag errors of image regions +define LS_INPTS Memi[$1+38] # pointers to npts of image regions + +define LS_RBSCALE Memi[$1+39] # pointers to bscales of regions +define LS_RBSCALEERR Memi[$1+40] # pointers to bscale errors of regions +define LS_RBZERO Memi[$1+41] # pointers to bzero errors of regions +define LS_RBZEROERR Memi[$1+42] # pointers to bzero errors of regions +define LS_RDELETE Memi[$1+43] # pointer to the delete array +define LS_RCHI Memi[$1+44] # pointer to the resid array + +# Quantities that affect the fitting algorithms + +define LS_BSALGORITHM Memi[$1+45] # bscale fitting algorithm +define LS_BZALGORITHM Memi[$1+46] # bzero fitting algorithm +define LS_CBZERO Memr[P2R($1+47)] # constant bzero +define LS_CBSCALE Memr[P2R($1+48)] # constant bscale +define LS_DNX Memi[$1+49] # x width of data region to extract +define LS_DNY Memi[$1+50] # y width of data region to extract +#define LS_PNX Memi[$1+51] # x width of photometry region +#define LS_PNY Memi[$1+52] # y widht of photometry region +define LS_DATAMIN Memr[P2R($1+51)] # the minimum good data value +define LS_DATAMAX Memr[P2R($1+52)] # the maximum good data value +define LS_MAXITER Memi[$1+53] # maximum number of iterations +define LS_NREJECT Memi[$1+54] # maximum number of rejections cycles +define LS_LOREJECT Memr[P2R($1+55)] # low-side sigma rejection criterion +define LS_HIREJECT Memr[P2R($1+56)] # high-side sigma rejection criterion +define LS_GAIN Memr[P2R($1+57)] # the constant gain value in e-/adu +define LS_READNOISE Memr[P2R($1+58)] # the constant readout noise value in e- + +# Quantities that define the answers + +define LS_TBSCALE Memr[P2R($1+59)] # bzero value +define LS_TBSCALEERR Memr[P2R($1+60)] # bscale error estimate +define LS_TBZERO Memr[P2R($1+61)] # bzero value +define LS_TBZEROERR Memr[P2R($1+62)] # bzero error estimate + +# String quantities + +define LS_BSSTRING Memc[P2C($1+65)] # bscale string +define LS_BZSTRING Memc[P2C($1+65+SZ_FNAME+1)] # bzero string +define LS_CCDGAIN Memc[P2C($1+65+2*SZ_FNAME+2)] # gain keyword +define LS_CCDREAD Memc[P2C($1+65+3*SZ_FNAME+3)] # readout noise keyword +define LS_IMAGE Memc[P2C($1+65+4*SZ_FNAME+4)] # input image +define LS_REFIMAGE Memc[P2C($1+65+5*SZ_FNAME+5)] # reference image +define LS_REGIONS Memc[P2C($1+65+6*SZ_FNAME+6)] # regions list +define LS_DATABASE Memc[P2C($1+65+7*SZ_FNAME+7)] # database file +define LS_OUTIMAGE Memc[P2C($1+65+8*SZ_FNAME+8)] # output image +define LS_SHIFTSFILE Memc[P2C($1+65+9*SZ_FNAME+9)] # shifts file +define LS_PHOTFILE Memc[P2C($1+65+10*SZ_FNAME+10)] # shifts file +define LS_RECORD Memc[P2C($1+65+11*SZ_FNAME+11)] # the record name + + +# Define the bzero and bscale fitting algorithms + +define LS_MEAN 1 +define LS_MEDIAN 2 +define LS_MODE 3 +define LS_FIT 4 +define LS_PHOTOMETRY 5 +define LS_FILE 6 +define LS_NUMBER 7 + +define LS_SCALING "|mean|median|mode|fit|photometry|file|" + +# Define the parameters + +define CNREGION 1 +define NREGIONS 2 +define MAXNREGIONS 3 + +define RC1 4 +define RC2 5 +define RL1 6 +define RL2 7 +define RXSTEP 8 +define RYSTEP 9 +define XSHIFT 10 +define YSHIFT 11 +define SXSHIFT 12 +define SYSHIFT 13 + +define RBUF 14 +define RGAIN 15 +define RREADNOISE 16 +define RMEAN 17 +define RMEDIAN 18 +define RMODE 19 +define RSIGMA 20 +define RSKY 21 +define RSKYERR 22 +define RMAG 23 +define RMAGERR 24 +define RNPTS 25 + +define IBUF 26 +define IGAIN 27 +define IREADNOISE 28 +define IMEAN 29 +define IMEDIAN 30 +define IMODE 31 +define ISIGMA 32 +define ISKY 33 +define ISKYERR 34 +define IMAG 35 +define IMAGERR 36 +define INPTS 37 + +define RBSCALE 38 +define RBSCALEERR 39 +define RBZERO 40 +define RBZEROERR 41 +define RDELETE 42 +define RCHI 43 + +define BZALGORITHM 44 +define BSALGORITHM 45 +define CBZERO 46 +define CBSCALE 47 +define DNX 48 +define DNY 49 +#define PNX 50 +#define PNY 51 +define DATAMIN 50 +define DATAMAX 51 +define MAXITER 52 + +define NREJECT 53 +define LOREJECT 54 +define HIREJECT 55 +define GAIN 56 +define READNOISE 57 + +define TBZERO 58 +define TBZEROERR 59 +define TBSCALE 60 +define TBSCALEERR 61 + +define BSSTRING 62 +define BZSTRING 63 +define CCDGAIN 64 +define CCDREAD 65 + +define IMAGE 66 +define REFIMAGE 67 +define REGIONS 68 +define DATABASE 69 +define OUTIMAGE 70 +define RECORD 71 +define SHIFTSFILE 72 +define PHOTFILE 73 + +# Set some default values + +define DEF_MAXNREGIONS 100 +define DEF_BZALGORITHM LS_FIT +define DEF_BSALGORITHM LS_FIT +define DEF_CBZERO 0.0 +define DEF_CBSCALE 1.0 +define DEF_DNX 31 +define DEF_DNY 31 +define DEF_MAXITER 10 +define DEF_DATAMIN INDEFR +define DEF_DATAMAX INDEFR +define DEF_NREJECT 0 +define DEF_LOREJECT INDEFR +define DEF_HIREJECT INDEFR +define DEF_GAIN INDEFR +define DEF_READNOISE INDEFR + +# The mode computation parameters. + +define LMODE_NMIN 10 +define LMODE_ZRANGE 1.0 +define LMODE_ZBIN 0.1 +define LMODE_ZSTEP 0.01 +define LMODE_HWIDTH 3.0 + +# The default plot types. + +define LS_MMHIST 1 +define LS_MMFIT 2 +define LS_MMRESID 3 +define LS_RIFIT 4 +define LS_RIRESID 5 +define LS_BSZFIT 6 +define LS_BSZRESID 7 +define LS_MAGSKYFIT 8 +define LS_MAGSKYRESID 9 + +# The bad point deletions code. + +define LS_NO 0 +define LS_BADREGION 1 +define LS_BADSIGMA 2 +define LS_DELETED 3 + +# Commands + +define LSCMDS "|input|reference|regions|lintransform|output|photfile|\ +shifts|records|xshift|yshift|dnx|dny|maxnregions|datamin|datamax|\ +maxiter|nreject|loreject|hireject|gain|readnoise|show|markcoords|marksections|" + +define LSCMD_IMAGE 1 +define LSCMD_REFIMAGE 2 +define LSCMD_REGIONS 3 +define LSCMD_DATABASE 4 +define LSCMD_OUTIMAGE 5 +define LSCMD_PHOTFILE 6 +define LSCMD_SHIFTSFILE 7 +define LSCMD_RECORD 8 +define LSCMD_XSHIFT 9 +define LSCMD_YSHIFT 10 +define LSCMD_DNX 11 +define LSCMD_DNY 12 +define LSCMD_MAXNREGIONS 13 +define LSCMD_DATAMIN 14 +define LSCMD_DATAMAX 15 +define LSCMD_MAXITER 16 +define LSCMD_NREJECT 17 +define LSCMD_LOREJECT 18 +define LSCMD_HIREJECT 19 +define LSCMD_GAIN 20 +define LSCMD_READNOISE 21 +define LSCMD_SHOW 22 +define LSCMD_MARKCOORDS 23 +define LSCMD_MARKSECTIONS 24 + +# Keywords + +define KY_REFIMAGE "reference" +define KY_IMAGE "input" +define KY_REGIONS "regions" +define KY_DATABASE "lintransform" +define KY_OUTIMAGE "output" +define KY_PHOTFILE "photfile" +define KY_SHIFTSFILE "shifts" +define KY_RECORD "records" +define KY_XSHIFT "xshift" +define KY_YSHIFT "yshift" +define KY_DNX "dnx" +define KY_DNY "dny" +define KY_MAXNREGIONS "maxnregions" +define KY_DATAMIN "datamin" +define KY_DATAMAX "datamax" +define KY_MAXITER "maxiter" +define KY_NREJECT "nreject" +define KY_LOREJECT "loreject" +define KY_HIREJECT "hireject" +define KY_GAIN "gain" +define KY_READNOISE "readnoise" +define KY_NREGIONS "nregions" + diff --git a/pkg/images/immatch/src/linmatch/linmatch.key b/pkg/images/immatch/src/linmatch/linmatch.key new file mode 100644 index 00000000..824f6b26 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/linmatch.key @@ -0,0 +1,51 @@ + Interactive Keystroke Commands + +? Print help +: Colon commands + +g Draw a plot of the current fit +i Draw the residuals plot for the current fit +p Draw a plot of current photometry +s Draw histograms for the image region nearest the cursor +l Draw the least squares fit for the image region nearest the cursor +h Draw histogram plot of each image region in turn +l Draw least squares fits plot of each image region in turn +r Redraw the current plot +d Delete the image region nearest the cursor +u Undelete the image region nearest the cursor +f Recompute the intensity matching function +w Update the task parameters +q Exit + + + Colon Commands + +:markcoords Mark objects on the display +:marksections Mark image sections on the display +:show Show current values of all the parameters + + Show/set Parameters + +:input [string] Show/set the current input image +:reference [string] Show/set the current reference image / phot file +:regions [string] Show/set the current image regions +:photfile [string] Show/set the current input photometry file +:lintransform [string] Show/set the linear transform database file name +:dnx [value] Show/set the default x size of an image region +:dny [value] Show/set the default y size of an image region +:shifts [string] Show/set the current shifts file +:xshift [value] Show/set the input image x shift +:yshift [value] Show/set the input image y shift +:output [string] Show/set the current output image name +:maxnregions Show the maximum number of objects / regions +:gain [string] Show/set the gain value / image header keyword +:readnoise [string] Show/set the readout noise value / image header + keyword + +:scaling Show the current scaling algorithm +:datamin [value] Show/set the minimum good data value +:datamax [value] Show/set the maximum good data value +:nreject [value] Show/set the maximum number of rejection cycles +:loreject [value] Show/set low side k-sigma rejection parameter +:hireject [value] Show/set high side k-sigma rejection parameter + diff --git a/pkg/images/immatch/src/linmatch/lsqfit.h b/pkg/images/immatch/src/linmatch/lsqfit.h new file mode 100644 index 00000000..69691935 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/lsqfit.h @@ -0,0 +1,18 @@ +# The definitions file for the least squares fitting routines. + +define MAX_NFITPARS 7 # number of parameters following + +define YINCPT $1[1] # y-intercept +define EYINCPT $1[2] # error in y-intercept +define SLOPE $1[3] # slope of fit +define ESLOPE $1[4] # error in slope +define CHI $1[5] # mean error of unit weight +define RMS $1[6] # mean error of unit weight + +#define ME1 $1[1] # mean error of unit weight +#define OFFSET $1[2] # intercept +#define EOFFSET $1[3] # error in intercept +#define SLOPE1 $1[4] # slope of fit to first variable +#define ESLOPE1 $1[5] # error in slope1 +#define SLOPE2 $1[6] # slope of fit to second variable +#define ESLOPE2 $1[7] # error in slope2 diff --git a/pkg/images/immatch/src/linmatch/mkpkg b/pkg/images/immatch/src/linmatch/mkpkg new file mode 100644 index 00000000..5a8894f2 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/mkpkg @@ -0,0 +1,21 @@ +# Make the LINMATCH task + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + +libpkg.a: + rglcolon.x <imhdr.h> <error.h> linmatch.h + rgldbio.x linmatch.h + rgldelete.x <gset.h> <mach.h> linmatch.h + rgliscale.x <imhdr.h> <gset.h> <ctype.h> linmatch.h + rglpars.x <lexnum.h> linmatch.h + rglplot.x <mach.h> <gset.h> linmatch.h + rglregions.x <fset.h> <imhdr.h> <ctype.h> linmatch.h + rglscale.x <mach.h> <imhdr.h> linmatch.h lsqfit.h + rglshow.x linmatch.h + rglsqfit.x <mach.h> lsqfit.h + rgltools.x linmatch.h + t_linmatch.x <fset.h> <imhdr.h> <imset.h> <error.h> linmatch.h + ; diff --git a/pkg/images/immatch/src/linmatch/rglcolon.x b/pkg/images/immatch/src/linmatch/rglcolon.x new file mode 100644 index 00000000..8c1d48ef --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rglcolon.x @@ -0,0 +1,564 @@ +include <imhdr.h> +include <error.h> +include "linmatch.h" + +# RG_LCOLON -- Show/set the linmatch task algorithm parameters. + +procedure rg_lcolon (gd, ls, imr, im1, im2, db, dformat, reglist, rpfd, ipfd, + sfd, cmdstr, newref, newimage, newfit, newavg) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to linmatch structure +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer im2 #I pointer to the output image +pointer db #I pointer to the databas file +int dformat #I the database file format +int reglist #I the regions / photometry file descriptor +int rpfd #I the reference photometry file descriptor +int ipfd #I the input photometry file descriptor +int sfd #I the shifts file descriptor +char cmdstr[ARB] #I command string +int newref #I/O new reference image +int newimage #I/O new input image +int newfit #I/O new fit +int newavg #I/O new averages + +int ncmd, nref, nim, ival, fd +pointer sp, cmd, str +real rval +bool streq() +int strdic(), rg_lstati(), rg_lregions(), open(), fntopnb(), nscan() +int rg_lrphot(), access(), rg_lmkxy(), rg_lmkregions() +pointer immap(), dtmap() +real rg_lstatr() +errchk immap(), open(), fntopnb() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the command. + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call sfree (sp) + return + } + + # Process the command. + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, LSCMDS) + + switch (ncmd) { + + case LSCMD_REFIMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_lstats (ls, REFIMAGE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str]) + } else if (rg_lstati(ls, BSALGORITHM) == LS_PHOTOMETRY || + rg_lstati(ls, BZALGORITHM) == LS_PHOTOMETRY) { + if (rpfd != NULL) { + call close (rpfd) + rpfd = NULL + } + iferr { + rpfd = open (Memc[cmd], READ_ONLY, TEXT_FILE) + } then { + call erract (EA_WARN) + rpfd = open (Memc[str], READ_ONLY, TEXT_FILE) + if (rg_lrphot (rpfd, ls, 1, rg_lstati(ls, MAXNREGIONS), + YES) <= 0) + ; + call seek (ipfd, BOF) + if (rg_lrphot (ipfd, ls, 1, rg_lstati(ls, NREGIONS), + NO) <= 0) + ; + } else { + nref = rg_lrphot (rpfd, ls, 1, rg_lstati(ls, MAXNREGIONS), + YES) + if (nref > 0) { + call seek (ipfd, BOF) + nim = rg_lrphot (ipfd, ls, 1, rg_lstati(ls, NREGIONS), + NO) + if (nim < nref) + call printf ("There are too few input points\n") + } else { + call close (rpfd) + rpfd = open (Memc[str], READ_ONLY, TEXT_FILE) + if (rg_lrphot (rpfd, ls, 1, rg_lstati(ls, MAXNREGIONS), + YES) <= 0) + ; + call seek (ipfd, BOF) + if (rg_lrphot (ipfd, ls, 1, rg_lstati(ls, NREGIONS), + NO) <= 0) + ; + call printf ( + "The new reference photometry file is empty\n") + } + call rg_lsets (ls, REFIMAGE, Memc[cmd]) + newref = YES; newimage = YES; newfit = YES; newavg = YES + } + } else { + if (imr != NULL) { + call imunmap (imr) + imr = NULL + } + iferr { + imr = immap (Memc[cmd], READ_ONLY, 0) + } then { + call erract (EA_WARN) + imr = immap (Memc[str], READ_ONLY, 0) + } else if (IM_NDIM(imr) > 2 || IM_NDIM(imr) != IM_NDIM(im1)) { + call printf ( + "Reference image has the wrong number of dimensions\n") + call imunmap (imr) + imr = immap (Memc[str], READ_ONLY, 0) + } else { + call rg_lgain (imr, ls) + if (!IS_INDEFR(rg_lstatr(ls,GAIN))) + call rg_lsetr (ls, RGAIN, rg_lstatr (ls,GAIN)) + call rg_lrdnoise (imr, ls) + if (!IS_INDEFR(rg_lstatr(ls,READNOISE))) + call rg_lsetr (ls, RREADNOISE, rg_lstatr (ls,READNOISE)) + call rg_lsets (ls, REFIMAGE, Memc[cmd]) + newref = YES; newimage = YES; newfit = YES; newavg = YES + } + } + + case LSCMD_IMAGE: + + call gargwrd (Memc[cmd], SZ_LINE) + call rg_lstats (ls, IMAGE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + } else { + if (im1 != NULL) { + call imunmap (im1) + im1 = NULL + } + iferr { + im1 = immap (Memc[cmd], READ_ONLY, 0) + } then { + call erract (EA_WARN) + im1 = immap (Memc[str], READ_ONLY, 0) + } else if (IM_NDIM(im1) > 2 || IM_NDIM(im1) != IM_NDIM(imr)) { + call printf ( + "Reference image has the wrong number of dimensions\n") + call imunmap (im1) + im1 = immap (Memc[str], READ_ONLY, 0) + } else { + call rg_lgain (im1, ls) + if (!IS_INDEFR(rg_lstatr(ls,GAIN))) + call rg_lsetr (ls, IGAIN, rg_lstatr (ls,GAIN)) + call rg_lrdnoise (im1, ls) + if (!IS_INDEFR(rg_lstatr(ls,READNOISE))) + call rg_lsetr (ls, IREADNOISE, rg_lstatr (ls,READNOISE)) + call rg_lsets (ls, IMAGE, Memc[cmd]) + newimage = YES; newref = YES; newfit = YES; newavg = YES + } + } + + case LSCMD_REGIONS: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_lstats (ls, REGIONS, Memc[str], SZ_FNAME) + if (reglist == NULL || nscan() == 1 || (streq (Memc[cmd], + Memc[str]) && Memc[cmd] != EOS)) { + call printf ("%s [string/file]: %s\n") + call pargstr (KY_REGIONS) + call pargstr (Memc[str]) + } else if (rg_lstati(ls, BSALGORITHM) != LS_PHOTOMETRY && + rg_lstati(ls, BZALGORITHM) != LS_PHOTOMETRY) { + call fntclsb (reglist) + iferr { + reglist = fntopnb (Memc[cmd], NO) + } then { + reglist = fntopnb (Memc[str], NO) + } else { + if (rg_lregions (reglist, imr, ls, 1, NO) > 0) + ; + call rg_lsets (ls, REGIONS, Memc[cmd]) + newimage = YES; newref = YES; newfit = YES; newavg = YES + } + } + + case LSCMD_PHOTFILE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_lstats (ls, PHOTFILE, Memc[str], SZ_FNAME) + if (ipfd == NULL || Memc[cmd] == EOS || streq (Memc[cmd], + Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_PHOTFILE) + call pargstr (Memc[str]) + } else { + if (ipfd != NULL) { + call close (ipfd) + ipfd = NULL + } + iferr { + ipfd = open (Memc[cmd], READ_ONLY, TEXT_FILE) + } then { + call erract (EA_WARN) + ipfd = open (Memc[str], READ_ONLY, TEXT_FILE) + } else { + nim = rg_lrphot (ipfd, ls, 1, rg_lstati(ls, NREGIONS), + NO) + if (nim > 0) { + call rg_lsets (ls, PHOTFILE, Memc[cmd]) + newref = YES; newimage = YES + newfit = YES; newavg = YES + } else { + call close (ipfd) + ipfd = open (Memc[str], READ_ONLY, TEXT_FILE) + nim = rg_lrphot (ipfd, ls, 1, rg_lstati(ls, NREGIONS), + NO) + } + } + } + + case LSCMD_SHIFTSFILE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_lstats (ls, SHIFTSFILE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], + Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_SHIFTSFILE) + call pargstr (Memc[str]) + } else { + if (sfd != NULL) { + call close (sfd) + sfd = NULL + } + iferr { + sfd = open (Memc[cmd], READ_ONLY, TEXT_FILE) + } then { + call erract (EA_WARN) + sfd = open (Memc[str], READ_ONLY, sfd) + } else { + call rg_lgshift (sfd, ls) + call rg_lstats (ls, SHIFTSFILE, Memc[cmd], SZ_FNAME) + } + } + + case LSCMD_OUTIMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_lstats (ls, OUTIMAGE, Memc[str], SZ_FNAME) + if (im2 == NULL || Memc[cmd] == EOS || streq (Memc[cmd], + Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_OUTIMAGE) + call pargstr (Memc[str]) + } else { + if (im2 != NULL) { + call imunmap (im2) + im2 = NULL + } + iferr { + im2 = immap (Memc[cmd], NEW_COPY, im1) + } then { + call erract (EA_WARN) + im2 = immap (Memc[str], NEW_COPY, im1) + } else { + call rg_lsets (ls, OUTIMAGE, Memc[cmd]) + } + } + + case LSCMD_DATABASE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_lstats (ls, DATABASE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_DATABASE) + call pargstr (Memc[str]) + } else { + if (db != NULL) { + if (dformat == YES) + call dtunmap (db) + else + call close (db) + db = NULL + } + iferr { + if (dformat == YES) + db = dtmap (Memc[cmd], APPEND) + else + db = open (Memc[cmd], NEW_FILE, TEXT_FILE) + } then { + call erract (EA_WARN) + if (dformat == YES) + db = dtmap (Memc[str], APPEND) + else + db = open (Memc[str], APPEND, TEXT_FILE) + } else { + call rg_lsets (ls, DATABASE, Memc[cmd]) + } + } + + CASE LSCMD_RECORD: + call gargstr (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_lstats (ls, RECORD, Memc[str], SZ_FNAME) + call printf ("%s: %s\n") + call pargstr (KY_RECORD) + call pargstr (Memc[str]) + } else + call rg_lsets (ls, RECORD, Memc[cmd]) + + case LSCMD_XSHIFT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_XSHIFT) + call pargr (rg_lstatr (ls, XSHIFT)) + } else { + call rg_lsetr (ls, XSHIFT, rval) + if (sfd == NULL) { + call rg_lsetr (ls, SXSHIFT, rg_lstatr (ls, XSHIFT)) + call rg_lsetr (ls, SYSHIFT, rg_lstatr (ls, YSHIFT)) + } + newref = YES; newimage = YES; newfit = YES; newavg = YES + } + + case LSCMD_YSHIFT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_YSHIFT) + call pargr (rg_lstatr (ls, YSHIFT)) + } else { + call rg_lsetr (ls, YSHIFT, rval) + if (sfd == NULL) { + call rg_lsetr (ls, SXSHIFT, rg_lstatr (ls, XSHIFT)) + call rg_lsetr (ls, SYSHIFT, rg_lstatr (ls, YSHIFT)) + } + newref = YES; newimage = YES; newfit = YES; newavg = YES + } + + case LSCMD_DNX: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_DNX) + call pargi (rg_lstati (ls, DNX)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_lseti (ls, DNX, ival) + newref = YES; newimage = YES; newfit = YES; newavg = YES + } + + case LSCMD_DNY: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_DNY) + call pargi (rg_lstati (ls, DNY)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_lseti (ls, DNY, ival) + newref = YES; newimage = YES; newfit = YES; newavg = YES + } + + case LSCMD_MAXNREGIONS: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_MAXNREGIONS) + call pargi (rg_lstati (ls, MAXNREGIONS)) + } + + case LSCMD_DATAMIN: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_DATAMIN) + call pargr (rg_lstatr (ls, DATAMIN)) + } else { + call rg_lsetr (ls, DATAMIN, rval) + if (rg_lstati(ls,BSALGORITHM) != LS_PHOTOMETRY && + rg_lstati(ls,BZALGORITHM) != LS_PHOTOMETRY) + newfit = YES; newavg = YES + } + + case LSCMD_DATAMAX: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_DATAMAX) + call pargr (rg_lstatr (ls, DATAMAX)) + } else { + call rg_lsetr (ls, DATAMAX, rval) + if (rg_lstati(ls,BSALGORITHM) != LS_PHOTOMETRY && + rg_lstati(ls,BZALGORITHM) != LS_PHOTOMETRY) + newfit = YES; newavg = YES + } + + case LSCMD_MAXITER: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_MAXITER) + call pargi (rg_lstati (ls, MAXITER)) + } else { + call rg_lseti (ls, MAXITER, ival) + if (rg_lstati(ls,BSALGORITHM) != LS_PHOTOMETRY && + rg_lstati(ls,BZALGORITHM) != LS_PHOTOMETRY) { + if (rg_lstati(ls,BSALGORITHM) == LS_FIT && + rg_lstati(ls,BZALGORITHM) == LS_FIT) { + newfit = YES; newavg = YES + } else + newavg = YES + } + } + + case LSCMD_NREJECT: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_NREJECT) + call pargi (rg_lstati (ls, NREJECT)) + } else { + call rg_lseti (ls, NREJECT, ival) + newfit = YES; newavg = YES + if (rg_lstati(ls,BSALGORITHM) == LS_FIT || + rg_lstati(ls,BZALGORITHM) == LS_FIT) + newfit = YES + newavg = YES + } + + case LSCMD_LOREJECT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_LOREJECT) + call pargr (rg_lstatr (ls, LOREJECT)) + } else { + call rg_lsetr (ls, LOREJECT, rval) + if (rg_lstati(ls,BSALGORITHM) == LS_FIT || + rg_lstati(ls,BZALGORITHM) == LS_FIT) + newfit = YES + newavg = YES + } + + case LSCMD_HIREJECT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_HIREJECT) + call pargr (rg_lstatr (ls, HIREJECT)) + } else { + call rg_lsetr (ls, HIREJECT, rval) + if (rg_lstati(ls,BSALGORITHM) == LS_FIT || + rg_lstati(ls,BZALGORITHM) == LS_FIT) + newfit = YES + newavg = YES + } + + case LSCMD_GAIN: + call gargstr (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_lstats (ls, CCDGAIN, Memc[str], SZ_LINE) + call printf ("%s: %s\n") + call pargstr (KY_GAIN) + call pargstr (Memc[str]) + } else { + call rg_lsets (ls, CCDGAIN, Memc[cmd]) + if (imr != NULL) { + call rg_lgain (imr, ls) + if (!IS_INDEFR(rg_lstatr(ls,GAIN))) + call rg_lsetr (ls, RGAIN, rg_lstatr(ls,GAIN)) + } + if (im1 != NULL) { + call rg_lgain (im1, ls) + if (!IS_INDEFR(rg_lstatr(ls,GAIN))) + call rg_lsetr (ls, IGAIN, rg_lstatr(ls,GAIN)) + } + newfit = YES; newavg = YES + } + + case LSCMD_READNOISE: + call gargstr (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_lstats (ls, CCDREAD, Memc[str], SZ_LINE) + call printf ("%s: %s\n") + call pargstr (KY_READNOISE) + call pargstr (Memc[str]) + } else { + call rg_lsets (ls, CCDREAD, Memc[cmd]) + if (imr != NULL) { + call rg_lrdnoise (imr, ls) + if (!IS_INDEFR(rg_lstatr(ls,READNOISE))) + call rg_lsetr (ls, RREADNOISE, rg_lstatr(ls,READNOISE)) + } + if (im1 != NULL) { + call rg_lrdnoise (im1, ls) + if (!IS_INDEFR(rg_lstatr(ls,READNOISE))) + call rg_lsetr (ls, IREADNOISE, rg_lstatr(ls,READNOISE)) + } + newfit = YES; newavg = YES + } + + case LSCMD_SHOW: + call gdeactivate (gd, 0) + call rg_lshow (ls) + call greactivate (gd, 0) + + case LSCMD_MARKCOORDS, LSCMD_MARKSECTIONS: + call gdeactivate (gd, 0) + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + fd = NULL + } else if (access (Memc[cmd], 0, 0) == YES) { + call printf ("Warning: file %s already exists\n") + call pargstr (Memc[cmd]) + fd = NULL + } else { + fd = open (Memc[cmd], NEW_FILE, TEXT_FILE) + } + call printf ("\n") + if (imr == NULL || im1 == NULL) { + call printf ("The reference or input image is undefined.\n") + } else { + if (reglist != NULL) { + call fntclsb (reglist) + reglist = NULL + } + if (ncmd == LSCMD_MARKCOORDS) { + nref = rg_lmkxy (fd, imr, ls, 1, rg_lstati (ls, + MAXNREGIONS)) + } else { + nref = rg_lmkregions (fd, imr, ls, 1, rg_lstati (ls, + MAXNREGIONS), Memc[str], SZ_LINE) + } + if (nref <= 0) { + call rg_lstats (ls, REGIONS, Memc[str], SZ_LINE) + iferr (reglist = fntopnb (Memc[str], NO)) + reglist = NULL + if (rg_lregions (reglist, imr, ls, 1, 1) > 0) + ; + call rg_lsets (ls, REGIONS, Memc[str]) + call rg_lseti (ls, CNREGION, 1) + } else { + call rg_lseti (ls, CNREGION, 1) + call rg_lsets (ls, REGIONS, Memc[str]) + newref = YES; newimage = YES + newfit = YES; newavg = YES + } + } + call printf ("\n") + if (fd != NULL) + call close (fd) + call greactivate (gd, 0) + + default: + call printf ("Unknown or ambiguous colon command\7\n") + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/linmatch/rgldbio.x b/pkg/images/immatch/src/linmatch/rgldbio.x new file mode 100644 index 00000000..63876985 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rgldbio.x @@ -0,0 +1,225 @@ +include "linmatch.h" + +# RG_LWREC -- Procedure to write out the entire record. + +procedure rg_lwrec (db, dformat, ls) + +pointer db #I pointer to the database file +int dformat #I is the scaling file in database format +pointer ls #I pointer to the linmatch structure + +pointer sp, image +real rg_lstatr() + +begin + # Allocate working space. + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + + if (dformat == YES) { + call rg_ldbparams (db, ls) + call rg_lwreg (db, ls) + call rg_ldbtscale (db, ls) + } else { + call rg_lstats (ls, IMAGE, Memc[image], SZ_FNAME) + call fprintf (db, "%s %g %g %g %g") + call pargstr (Memc[image]) + call pargr (rg_lstatr(ls, TBSCALE)) + call pargr (rg_lstatr(ls, TBZERO)) + call pargr (rg_lstatr(ls, TBSCALEERR)) + call pargr (rg_lstatr(ls, TBZEROERR)) + } + + call sfree (sp) +end + + +# RG_LWREG -- Write out the results for each region. + +procedure rg_lwreg (db, ls) + +pointer db #I pointer to the database file +pointer ls #I pointer to the intensity matching structure + +int i, nregions, rc1, rc2, rl1, rl2, c1, c2, l1, l2, del +real xshift, yshift, bscale, bzero, bserr, bzerr +int rg_lstati() +pointer rg_lstatp() +real rg_lstatr() + +begin + xshift = rg_lstatr (ls, SXSHIFT) + yshift = rg_lstatr (ls, SYSHIFT) + + nregions = rg_lstati (ls, NREGIONS) + do i = 1, nregions { + + rc1 = Memi[rg_lstatp (ls, RC1)+i-1] + rc2 = Memi[rg_lstatp (ls, RC2)+i-1] + rl1 = Memi[rg_lstatp (ls, RL1)+i-1] + rl2 = Memi[rg_lstatp (ls, RL2)+i-1] + if (IS_INDEFI(rc1)) + c1 = INDEFI + else + c1 = rc1 + xshift + if (IS_INDEFI(rc2)) + c2 = INDEFI + else + c2 = rc2 + xshift + if (IS_INDEFI(rl1)) + l1 = INDEFI + else + l1 = rl1 + yshift + if (IS_INDEFI(rl2)) + l2 = INDEFI + else + l2 = rl2 + yshift + + bscale = Memr[rg_lstatp(ls,RBSCALE)+i-1] + bzero = Memr[rg_lstatp(ls,RBZERO)+i-1] + bserr = Memr[rg_lstatp(ls,RBSCALEERR)+i-1] + bzerr = Memr[rg_lstatp(ls,RBZEROERR)+i-1] + del = Memi[rg_lstatp(ls,RDELETE)+i-1] + + call rg_ldbscaler (db, rc1, rc2, rl1, rl2, c1, c2, l1, l2, + bscale, bzero, bserr, bzerr, del) + } +end + + +# RG_LDBPARAMS -- Write the intensity matching parameters to the database file. + +procedure rg_ldbparams (db, ls) + +pointer db #I pointer to the database file +pointer ls #I pointer to the intensity matching structure + +pointer sp, str +int rg_lstati() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Write out the time record was written. + call dtput (db, "\n") + call dtptime (db) + + # Write out the record name. + call rg_lstats (ls, RECORD, Memc[str], SZ_FNAME) + call dtput (db, "begin\t%s\n") + call pargstr (Memc[str]) + + # Write the image names. + call rg_lstats (ls, IMAGE, Memc[str], SZ_FNAME) + call dtput (db, "\t%s\t\t%s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + call rg_lstats (ls, REFIMAGE, Memc[str], SZ_FNAME) + call dtput (db, "\t%s\t%s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str]) + + call dtput (db, "\t%s\t%d\n") + call pargstr (KY_NREGIONS) + call pargi (rg_lstati(ls, NREGIONS)) + + call sfree (sp) +end + + +# RG_LDBSCALER -- Write the scaling parameters for each region + +procedure rg_ldbscaler (db, rc1, rc2, rl1, rl2, c1, c2, l1, l2, bscale, + bzero, bserr, bzerr, del) + +pointer db # pointer to the database file +int rc1, rc2 # reference image region column limits +int rl1, rl2 # reference image region line limits +int c1, c2 # image region column limits +int l1, l2 # image region line limits +real bscale # the scaling parameter +real bzero # the offset parameter +real bserr # the error in the scaling parameter +real bzerr # the error in the offset parameter +int del # the deletions index + +begin + if (IS_INDEFI(rc1) || IS_INDEFI(c1)) { + call dtput (db,"\t[INDEF] [INDEF] %g %g %g %g %s\n") + } else { + call dtput (db,"\t[%d:%d,%d:%d] [%d:%d,%d:%d] %g %g %g %g %s\n") + call pargi (rc1) + call pargi (rc2) + call pargi (rl1) + call pargi (rl2) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + } + + call pargr (bscale) + call pargr (bzero) + call pargr (bserr) + call pargr (bzerr) + if (del == NO) + call pargstr ("") + else + call pargstr ("[Rejected/Deleted]") +end + + +# RG_LDBTSCALE -- Write the final scaling parameters and their errors. + +procedure rg_ldbtscale (db, ls) + +pointer db #I pointer to the text database file +pointer ls #I pointer to the linmatch structure + +real rg_lstatr() + +begin + call dtput (db, "\tbscale\t\t%g\n") + call pargr (rg_lstatr(ls, TBSCALE)) + call dtput (db, "\tbzero\t\t%g\n") + call pargr (rg_lstatr (ls, TBZERO)) + call dtput (db, "\tbserr\t\t%g\n") + call pargr (rg_lstatr (ls, TBSCALEERR)) + call dtput (db, "\tbzerr\t\t%g\n") + call pargr (rg_lstatr (ls, TBZEROERR)) +end + + +# RG_LPWREC -- Print the computed scaling factors for the region. + +procedure rg_lpwrec (ls, i) + +pointer ls #I pointer to the linmatch structure +int i #I the current region + +pointer rg_lstatp() +real rg_lstatr() + +begin + if (i == 0) { + call printf ( + "Results: bscale = %g +/- %g bzero = %g +/- %g\n") + call pargr (rg_lstatr (ls, TBSCALE)) + call pargr (rg_lstatr (ls, TBSCALEERR)) + call pargr (rg_lstatr (ls, TBZERO)) + call pargr (rg_lstatr (ls, TBZEROERR)) + } else { + call printf ( + "Region %d: [%d:%d,%d:%d] bscale = %g +/- %g bzero = %g +/- %g\n") + call pargi (i) + call pargi (Memi[rg_lstatp(ls,RC1)+i-1]) + call pargi (Memi[rg_lstatp(ls,RC2)+i-1]) + call pargi (Memi[rg_lstatp(ls,RL1)+i-1]) + call pargi (Memi[rg_lstatp(ls,RL2)+i-1]) + call pargr (Memr[rg_lstatp(ls,RBSCALE)+i-1]) + call pargr (Memr[rg_lstatp(ls,RBSCALEERR)+i-1]) + call pargr (Memr[rg_lstatp(ls,RBZERO)+i-1]) + call pargr (Memr[rg_lstatp(ls,RBZEROERR)+i-1]) + } +end diff --git a/pkg/images/immatch/src/linmatch/rgldelete.x b/pkg/images/immatch/src/linmatch/rgldelete.x new file mode 100644 index 00000000..2e16923a --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rgldelete.x @@ -0,0 +1,993 @@ +include <gset.h> +include <mach.h> +include "linmatch.h" + +# RG_LFIND -- Find the point nearest the cursor regardless of whether it +# has been deleted or not. + +int procedure rg_lfind (gd, ls, wcs, wx, wy, bscale, bzero, plot_type) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int wcs #I the wcs of the point +real wx #I the x coordinate of point to be deleted +real wy #I the y coordinate of point to be deleted +real bscale #I the computed bscale value +real bzero #I the computed bzero value +int plot_type #I the current plot type + +int region +int rg_mmffind(), rg_mmrfind(), rg_bzffind(), rg_bzrfind() +int rg_msffind(), rg_msrfind() + +begin + switch (plot_type) { + case LS_MMFIT: + region = rg_mmffind (gd, ls, wx, wy) + case LS_MMRESID: + region = rg_mmrfind (gd, ls, wx, wy, bscale, bzero) + case LS_BSZFIT: + region = rg_bzffind (gd, ls, wcs, wx, wy) + case LS_BSZRESID: + region = rg_bzrfind (gd, ls, wcs, wx, wy, bscale, bzero) + case LS_MAGSKYFIT: + region = rg_msffind (gd, ls, wcs, wx, wy) + case LS_MAGSKYRESID: + region = rg_msrfind (gd, ls, wcs, wx, wy, bscale, bzero) + default: + region = 0 + } + + return (region) +end + + +# RG_LDELETE -- Delete or undelete regions from the data. + +int procedure rg_ldelete (gd, ls, udelete, wcs, wx, wy, bscale, bzero, + plot_type, delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +int wcs #I the wcs for multi-wcs plots +real wx #I the x coordinate of point to be deleted +real wy #I the y coordinate of point to be deleted +real bscale #I the computed bscale value +real bzero #I the computed bzero value +int plot_type #I the current plot type +int delete #I delete the point + +int region +int rg_rdelete(), rg_mmfdelete(), rg_mmrdelete(), rg_bzfdelete() +int rg_bzrdelete(), rg_msfdelete(), rg_msrdelete() + +begin + switch (plot_type) { + case LS_MMHIST: + region = rg_rdelete (gd, ls, udelete, delete) + case LS_MMFIT: + region = rg_mmfdelete (gd, ls, udelete, wx, wy, delete) + case LS_MMRESID: + region = rg_mmrdelete (gd, ls, udelete, wx, wy, bscale, + bzero, delete) + case LS_RIFIT: + region = rg_rdelete (gd, ls, udelete, delete) + case LS_RIRESID: + region = rg_rdelete (gd, ls, udelete, delete) + case LS_BSZFIT: + region = rg_bzfdelete (gd, ls, udelete, wcs, wx, wy, delete) + case LS_BSZRESID: + region = rg_bzrdelete (gd, ls, udelete, wcs, wx, wy, bscale, + bzero, delete) + case LS_MAGSKYFIT: + region = rg_msfdelete (gd, ls, udelete, wcs, wx, wy, delete) + case LS_MAGSKYRESID: + region = rg_msrdelete (gd, ls, udelete, wcs, wx, wy, bscale, + bzero, delete) + default: + region = 0 + } + + return (region) +end + + +# RG_RDELETE -- Delete or undelete a particular region from the data using +# a histogram or fit plot. + +int procedure rg_rdelete (gd, ls, udelete, delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +int delete #I delete the point + +int region +int rg_lstati() +pointer rg_lstatp() + +begin + # Get the current region. + region = rg_lstati (ls, CNREGION) + if (region < 1 || region > rg_lstati (ls, NREGIONS)) + return (0) + + # Delete or undelete the region. + if (delete == YES) { + if (Memi[rg_lstatp(ls,RDELETE)+region-1] == LS_NO) { + udelete[region] = YES + return (region) + } else + return (0) + } else { + if (Memi[rg_lstatp(ls,RDELETE)+region-1] != LS_NO) { + udelete[region] = NO + return (region) + } else + return (0) + } +end + + +# RG_MMFDELETE -- Delete or undelete a point computed from the mean, median, +# or mode. + +int procedure rg_mmfdelete (gd, ls, udelete, wx, wy, delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +real wx #I the input x coordinate +real wy #I the input y coordinate +int delete #I delete the input object + +int nregions, region, mtype +pointer sp, xdata, ydata +int rg_lstati(), rg_lpdelete(), rg_lpundelete() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + # Determine the type of data to plot. + mtype = 0 + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + if (mtype <= 0) + return (0) + + # Allocate working space. + call smark (sp) + call salloc (xdata, nregions, TY_REAL) + call salloc (ydata, nregions, TY_REAL) + + # Get the data. + switch (mtype) { + case LS_MEAN: + call amovr (Memr[rg_lstatp(ls,IMEAN)], Memr[xdata], nregions) + call amovr (Memr[rg_lstatp(ls,RMEAN)], Memr[ydata], nregions) + case LS_MEDIAN: + call amovr (Memr[rg_lstatp(ls,IMEDIAN)], Memr[xdata], nregions) + call amovr (Memr[rg_lstatp(ls,RMEDIAN)], Memr[ydata], nregions) + case LS_MODE: + call amovr (Memr[rg_lstatp(ls,IMODE)], Memr[xdata], nregions) + call amovr (Memr[rg_lstatp(ls,RMODE)], Memr[ydata], nregions) + } + + # Delete or undelete the point. + if (delete == YES) + region = rg_lpdelete (gd, 1, wx, wy, Memr[xdata], Memr[ydata], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + else + region = rg_lpundelete (gd, 1, wx, wy, Memr[xdata], Memr[ydata], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + + call sfree (sp) + + return (region) +end + + +# RG_MMRDELETE -- Delete or undelete a point computed from the mean, median, +# or mode residuals plots. + +int procedure rg_mmrdelete (gd, ls, udelete, wx, wy, bscale, bzero, delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +real wx #I the input x coordinate +real wy #I the input y coordinate +real bscale #I the computed bscale factor +real bzero #I the computed bzero factor +int delete #I delete the input object + +int nregions, region, mtype +pointer sp, xdata, ydata +int rg_lstati(), rg_lpdelete(), rg_lpundelete() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + # Determine the type of data to plot. + mtype = 0 + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + if (mtype <= 0) + return (0) + + # Allocate working space. + call smark (sp) + call salloc (xdata, nregions, TY_REAL) + call salloc (ydata, nregions, TY_REAL) + + switch (mtype) { + case LS_MEAN: + call amovr (Memr[rg_lstatp(ls,IMEAN)], Memr[xdata], nregions) + call altmr (Memr[rg_lstatp(ls,IMEAN)], Memr[ydata], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMEAN)], Memr[ydata], Memr[ydata], + nregions) + case LS_MEDIAN: + call amovr (Memr[rg_lstatp(ls,IMEDIAN)], Memr[xdata], nregions) + call altmr (Memr[rg_lstatp(ls,IMEDIAN)], Memr[ydata], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMEDIAN)], Memr[ydata], Memr[ydata], + nregions) + case LS_MODE: + call amovr (Memr[rg_lstatp(ls,IMODE)], Memr[xdata], nregions) + call altmr (Memr[rg_lstatp(ls,IMODE)], Memr[ydata], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMODE)], Memr[ydata], Memr[ydata], + nregions) + } + + # Delete or undelete the point. + if (delete == YES) + region = rg_lpdelete (gd, 1, wx, wy, Memr[xdata], Memr[ydata], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + else + region = rg_lpundelete (gd, 1, wx, wy, Memr[xdata], Memr[ydata], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + + call sfree (sp) + + return (region) +end + + +# RG_BZFDELETE -- Delete or undelete a point computed from the average +# of the fitted bscale or bzeros. + +int procedure rg_bzfdelete (gd, ls, udelete, wcs, wx, wy, delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +int wcs #I the wcs number +real wx #I the input x coordinate +real wy #I the input y coordinate +int delete #I delete the input object + +int i, nregions, region +pointer sp, xreg +int rg_lstati(), rg_lpdelete(), rg_lpundelete() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + call smark (sp) + call salloc (xreg, nregions, TY_REAL) + do i = 1, nregions + Memr[xreg+i-1] = i + + # Delete or undelete the point. + if (delete == YES) { + if (wcs == 1) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[xreg], + Memr[rg_lstatp(ls,RBSCALE)], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else if (wcs == 2) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[xreg], + Memr[rg_lstatp(ls,RBZERO)], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else + region = 0 + } else { + if (wcs == 1) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[xreg], + Memr[rg_lstatp(ls,RBSCALE)], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else if (wcs == 2) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[xreg], + Memr[rg_lstatp(ls,RBZERO)], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else + region = 0 + } + + call sfree (sp) + + return (region) +end + + +# RG_BZRDELETE -- Delete or undelete a point computed from the average +# of the fitted bscale or bzero residuals. + +int procedure rg_bzrdelete (gd, ls, udelete, wcs, wx, wy, bscale, bzero, + delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +int wcs #I the wcs number +real wx #I the input x coordinate +real wy #I the input y coordinate +real bscale #I the input bscale value +real bzero #I the input bzero value +int delete #I delete the input object + +int i, nregions, region +pointer sp, xreg, yreg +int rg_lstati(), rg_lpdelete(), rg_lpundelete() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + call smark (sp) + call salloc (xreg, nregions, TY_REAL) + call salloc (yreg, nregions, TY_REAL) + do i = 1, nregions + Memr[xreg+i-1] = i + + # Delete or undelete the point. + if (delete == YES) { + if (wcs == 1) { + call asubkr (Memr[rg_lstatp(ls,RBSCALE)], bscale, Memr[yreg], + nregions) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[xreg], Memr[yreg], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + } else if (wcs == 2) { + call asubkr (Memr[rg_lstatp(ls,RBZERO)], bzero, Memr[yreg], + nregions) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[xreg], + Memr[yreg], Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + } else + region = 0 + } else { + if (wcs == 1) { + call asubkr (Memr[rg_lstatp(ls,RBSCALE)], bscale, Memr[yreg], + nregions) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[xreg], + Memr[yreg], Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + } else if (wcs == 2) { + call asubkr (Memr[rg_lstatp(ls,RBZERO)], bzero, Memr[yreg], + nregions) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[xreg], + Memr[yreg], Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + } else + region = 0 + } + + call sfree (sp) + + return (region) +end + + +# RG_MSFDELETE -- Delete or undelete a point computed from the average +# of the fitted bscale or bzeros. + +int procedure rg_msfdelete (gd, ls, udelete, wcs, wx, wy, delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +int wcs #I the wcs number +real wx #I the input x coordinate +real wy #I the input y coordinate +int delete #I delete the input object + +int nregions, region +int rg_lstati(), rg_lpdelete(), rg_lpundelete() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + # Delete or undelete the point. + if (delete == YES) { + if (wcs == 1) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + IMAG)], Memr[rg_lstatp(ls,RMAG)], Memi[rg_lstatp(ls, + RDELETE)], udelete, nregions) + else if (wcs == 2) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + ISKY)], Memr[rg_lstatp(ls,RSKY)], Memi[rg_lstatp(ls, + RDELETE)], udelete, nregions) + else + region = 0 + } else { + if (wcs == 1) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + IMAG)], Memr[rg_lstatp(ls,RMAG)], Memi[rg_lstatp(ls, + RDELETE)], udelete, nregions) + else if (wcs == 2) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + ISKY)], Memr[rg_lstatp(ls,RSKY)], Memi[rg_lstatp(ls, + RDELETE)], udelete, nregions) + else + region = 0 + } + + return (region) +end + + +# RG_MSRDELETE -- Delete or undelete a point computed from the average +# of the fitted bscale or bzeros. + +int procedure rg_msrdelete (gd, ls, udelete, wcs, wx, wy, bscale, bzero, delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +int wcs #I the wcs number +real wx #I the input x coordinate +real wy #I the input y coordinate +real bscale #I the input bscale value +real bzero #I the input bzero value +int delete #I delete the input object + +int nregions, region +pointer sp, resid +int rg_lstati(), rg_lpdelete(), rg_lpundelete() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + call smark (sp) + call salloc (resid, nregions, TY_REAL) + + if (wcs == 1) { + if (bscale > 0.0) { + call aaddkr (Memr[rg_lstatp(ls,IMAG)], -2.5*log10(bscale), + Memr[resid], nregions) + call asubr (Memr[rg_lstatp(ls,RMAG)], Memr[resid], + Memr[resid], nregions) + } else + call asubr (Memr[rg_lstatp(ls,RMAG)], Memr[rg_lstatp(ls, + IMAG)], Memr[resid], nregions) + } else { + call altmr (Memr[rg_lstatp(ls,ISKY)], Memr[resid], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RSKY)], Memr[resid], Memr[resid], + nregions) + } + + # Delete or undelete the point. + if (delete == YES) { + if (wcs == 1) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + IMAG)], Memr[resid], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else if (wcs == 2) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + ISKY)], Memr[resid], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else + region = 0 + } else { + if (wcs == 1) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + IMAG)], Memr[resid], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else if (wcs == 2) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + ISKY)], Memr[resid], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else + region = 0 + } + + call sfree (sp) + + return (region) +end + +# RG_MMFFIND -- Find a point computed from the mean, median, or mode. + +int procedure rg_mmffind (gd, ls, wx, wy) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +real wx #I the input x coordinate +real wy #I the input y coordinate + +int nregions, mtype, region +pointer sp, xdata, ydata +int rg_lstati(), rg_lpfind() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + # Determine the type of data to plot. + mtype = 0 + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + if (mtype <= 0) + return (0) + + # Allocate working space. + call smark (sp) + call salloc (xdata, nregions, TY_REAL) + call salloc (ydata, nregions, TY_REAL) + + # Get the data. + switch (mtype) { + case LS_MEAN: + call amovr (Memr[rg_lstatp(ls,IMEAN)], Memr[xdata], nregions) + call amovr (Memr[rg_lstatp(ls,RMEAN)], Memr[ydata], nregions) + case LS_MEDIAN: + call amovr (Memr[rg_lstatp(ls,IMEDIAN)], Memr[xdata], nregions) + call amovr (Memr[rg_lstatp(ls,RMEDIAN)], Memr[ydata], nregions) + case LS_MODE: + call amovr (Memr[rg_lstatp(ls,IMODE)], Memr[xdata], nregions) + call amovr (Memr[rg_lstatp(ls,RMODE)], Memr[ydata], nregions) + } + + region = rg_lpfind (gd, 1, wx, wy, Memr[xdata], Memr[ydata], nregions) + + call sfree (sp) + + return (region) +end + + +# RG_MMRFIND -- Find a point computed from the mean, median, or mode. + +int procedure rg_mmrfind (gd, ls, wx, wy, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +real wx #I the input x coordinate +real wy #I the input y coordinate +real bscale #I the input bscale factor +real bzero #I the input bzero factor + +int nregions, mtype, region +pointer sp, xdata, ydata +int rg_lstati(), rg_lpfind() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + # Determine the type of data to plot. + mtype = 0 + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + if (mtype <= 0) + return (0) + + # Allocate working space. + call smark (sp) + call salloc (xdata, nregions, TY_REAL) + call salloc (ydata, nregions, TY_REAL) + + switch (mtype) { + case LS_MEAN: + call amovr (Memr[rg_lstatp(ls,IMEAN)], Memr[xdata], nregions) + call altmr (Memr[rg_lstatp(ls,IMEAN)], Memr[ydata], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMEAN)], Memr[ydata], Memr[ydata], + nregions) + case LS_MEDIAN: + call amovr (Memr[rg_lstatp(ls,IMEDIAN)], Memr[xdata], nregions) + call altmr (Memr[rg_lstatp(ls,IMEDIAN)], Memr[ydata], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMEDIAN)], Memr[ydata], Memr[ydata], + nregions) + case LS_MODE: + call amovr (Memr[rg_lstatp(ls,IMODE)], Memr[xdata], nregions) + call altmr (Memr[rg_lstatp(ls,IMODE)], Memr[ydata], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMODE)], Memr[ydata], Memr[ydata], + nregions) + } + + region = rg_lpfind (gd, 1, wx, wy, Memr[xdata], Memr[ydata], nregions) + + call sfree (sp) + + return (region) +end + + +# RG_BZFFIND -- Find a point computed from the bscale and bzero fits +# to all the regions. + +int procedure rg_bzffind (gd, ls, wcs, wx, wy) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int wcs #I the input wcs +real wx #I the input x coordinate +real wy #I the input y coordinate + +int i, nregions, region +pointer sp, xreg +int rg_lstati(), rg_lpfind() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + call smark (sp) + call salloc (xreg, nregions, TY_REAL) + do i = 1, nregions + Memr[xreg+i-1] = i + + if (wcs == 1) + region = rg_lpfind (gd, 1, wx, wy, Memr[xreg], Memr[rg_lstatp(ls, + RBSCALE)], nregions) + else if (wcs == 2) + region = rg_lpfind (gd, 2, wx, wy, Memr[xreg], Memr[rg_lstatp(ls, + RBZERO)], nregions) + else + region = 0 + + call sfree (sp) + + return (region) +end + + +# RG_BZRFIND -- Find a point computed from the bscale and bzero fit +# residuals to all the regions. + +int procedure rg_bzrfind (gd, ls, wcs, wx, wy, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int wcs #I the input wcs +real wx #I the input x coordinate +real wy #I the input y coordinate +real bscale #I the input bscale value +real bzero #I the input bscale value + +int i, nregions, region +pointer sp, xreg, yreg +int rg_lstati(), rg_lpfind() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + call smark (sp) + call salloc (xreg, nregions, TY_REAL) + call salloc (yreg, nregions, TY_REAL) + + do i = 1, nregions + Memr[xreg+i-1] = i + + if (wcs == 1) { + call asubkr (Memr[rg_lstatp(ls,RBSCALE)], bscale, Memr[yreg], + nregions) + region = rg_lpfind (gd, 1, wx, wy, Memr[xreg], Memr[yreg], + nregions) + } else if (wcs == 2) { + call asubkr (Memr[rg_lstatp(ls,RBZERO)], bzero, Memr[yreg], + nregions) + region = rg_lpfind (gd, 2, wx, wy, Memr[xreg], Memr[yreg], + nregions) + } else + region = 0 + + call sfree (sp) + + return (region) +end + + +# RG_MSFFIND -- Find a point computed from the bscale and bzero fits +# to all the regions. + +int procedure rg_msffind (gd, ls, wcs, wx, wy) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int wcs #I the input wcs +real wx #I the input x coordinate +real wy #I the input y coordinate + +int nregions, region +int rg_lstati(), rg_lpfind() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + if (wcs == 1) + region = rg_lpfind (gd, 1, wx, wy, Memr[rg_lstatp(ls,IMAG)], + Memr[rg_lstatp(ls,RMAG)], nregions) + else if (wcs == 2) + region = rg_lpfind (gd, 2, wx, wy, Memr[rg_lstatp(ls,ISKY)], + Memr[rg_lstatp(ls,RSKY)], nregions) + else + region = 0 + + return (region) +end + + +# RG_MSRFIND -- Find a point computed from the bscale and bzero fits +# to all the regions. + +int procedure rg_msrfind (gd, ls, wcs, wx, wy, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int wcs #I the input wcs +real wx #I the input x coordinate +real wy #I the input y coordinate +real bscale #I the input bscale value +real bzero #I the input bzero value + +int nregions, region +pointer sp, resid +int rg_lstati(), rg_lpfind() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + call smark (sp) + call salloc (resid, nregions, TY_REAL) + + if (wcs == 1) { + if (bscale > 0.0) { + call aaddkr (Memr[rg_lstatp(ls,IMAG)], -2.5*log10(bscale), + Memr[resid], nregions) + call asubr (Memr[rg_lstatp(ls,RMAG)], Memr[resid], Memr[resid], + nregions) + } else + call asubr (Memr[rg_lstatp(ls,RMAG)], Memr[rg_lstatp(ls,IMAG)], + Memr[resid], nregions) + region = rg_lpfind (gd, 1, wx, wy, Memr[rg_lstatp(ls,IMAG)], + Memr[resid], nregions) + } else if (wcs == 2) { + call altmr (Memr[rg_lstatp(ls,ISKY)], Memr[resid], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RSKY)], Memr[resid], Memr[resid], + nregions) + region = rg_lpfind (gd, 2, wx, wy, Memr[rg_lstatp(ls,ISKY)], + Memr[resid], nregions) + } else + region = 0 + + call sfree (sp) + + return (region) +end + + +# RG_LPDELETE -- Delete a point from the plot. + +int procedure rg_lpdelete (gd, wcs, wx, wy, xdata, ydata, delete, udelete, npts) + +pointer gd #I the graphics stream descriptor +int wcs #I the input wcs +real wx, wy #I the point to be deleted. +real xdata[ARB] #I the input x data array +real ydata[ARB] #I the input y data array +int delete[ARB] #I the deletions array +int udelete[ARB] #I/O the user deletions array +int npts #I the number of points + +int i, region +real wx0, wy0, r2min, r2, x0, y0 + +begin + call gctran (gd, wx, wy, wx0, wy0, wcs, 0) + r2min = MAX_REAL + region = 0 + + # Find the point to be deleted. + do i = 1, npts { + if (delete[i] != LS_NO) + next + call gctran (gd, xdata[i], ydata[i], x0, y0, wcs, 0) + r2 = (x0 - wx0) ** 2 + (y0 - wy0) ** 2 + if (r2 < r2min) { + r2min = r2 + region = i + } + } + + if (region > 0) { + call gseti (gd, G_WCS, wcs) + call gscur (gd, xdata[region], ydata[region]) + call gmark (gd, xdata[region], ydata[region], GM_CROSS, 2.0, 2.0) + udelete[region] = YES + } + + return (region) +end + + +# RG_LPUNDELETE -- Undelete a point from the plot. + +int procedure rg_lpundelete (gd, wcs, wx, wy, xdata, ydata, delete, + udelete, npts) + +pointer gd #I the graphics stream descriptor +int wcs #I the input wcs +real wx, wy #I the point to be deleted. +real xdata[ARB] #I the input x data array +real ydata[ARB] #I the input y data array +int delete[ARB] #I the deletions array +int udelete[ARB] #I/O the user deletions array +int npts #I the number of points + +int i, region +real wx0, wy0, r2min, r2, x0, y0 + +begin + call gctran (gd, wx, wy, wx0, wy0, wcs, 0) + r2min = MAX_REAL + region = 0 + + # Find the point to be deleted. + do i = 1, npts { + if (udelete[i] == NO) + next + call gctran (gd, xdata[i], ydata[i], x0, y0, wcs, 0) + r2 = (x0 - wx0) ** 2 + (y0 - wy0) ** 2 + if (r2 < r2min) { + r2min = r2 + region = i + } + } + + if (region > 0) { + call gseti (gd, G_WCS, wcs) + call gscur (gd, xdata[region], ydata[region]) + call gseti (gd, G_PMLTYPE, GL_CLEAR) + call gmark (gd, xdata[region], ydata[region], GM_CROSS, 2.0, 2.0) + call gseti (gd, G_PMLTYPE, GL_SOLID) + call gmark (gd, xdata[region], ydata[region], GM_BOX, 2.0, 2.0) + udelete[region] = NO + } + + return (region) +end + + +# RG_LPFIND -- Find a point in the plot. + +int procedure rg_lpfind (gd, wcs, wx, wy, xdata, ydata, npts) + +pointer gd #I the graphics stream descriptor +int wcs #I the input wcs +real wx, wy #I the point to be deleted. +real xdata[ARB] #I the input x data array +real ydata[ARB] #I the input y data array +int npts #I the number of points + +int i, region +real wx0, wy0, r2min, x0, y0, r2 + +begin + call gctran (gd, wx, wy, wx0, wy0, wcs, 0) + r2min = MAX_REAL + region = 0 + + # Find the point to be deleted. + do i = 1, npts { + call gctran (gd, xdata[i], ydata[i], x0, y0, wcs, 0) + r2 = (x0 - wx0) ** 2 + (y0 - wy0) ** 2 + if (r2 < r2min) { + r2min = r2 + region = i + } + } + + return (region) +end + diff --git a/pkg/images/immatch/src/linmatch/rgliscale.x b/pkg/images/immatch/src/linmatch/rgliscale.x new file mode 100644 index 00000000..e760c7f8 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rgliscale.x @@ -0,0 +1,593 @@ +include <gset.h> +include <imhdr.h> +include <ctype.h> +include "linmatch.h" + +# Define the help files. +define HELPFILE "immatch$src/linmatch/linmatch.key" + +# RG_LISCALE -- Scale the output image interactively. + +int procedure rg_liscale (imr, im1, im2, db, dformat, reglist, rpfd, ipfd, sfd, + ls, gd, id) + +pointer imr #I/O pointer to the reference image +pointer im1 #I/O pointer to the input image +pointer im2 #I/O pointer to the output image +pointer db #I/O pointer to the database file +int dformat #I is the scale file in database format +pointer reglist #I/O the regions list descriptor +int rpfd #I/O the reference photometry file descriptor +int ipfd #I/O the input photometry file descriptor +int sfd #I/O the shifts file descriptor +pointer ls #I pointer to the linmatch structure +pointer gd #I the graphics stream pointer +pointer id #I display stream pointer + +int i, newref, newimage, newfit, newavg, newplot, plottype, wcs, key, reg +int hplot, lplot, lplot_type +pointer sp, cmd, udelete, stat +real bscale, bzero, bserr, bzerr, wx, wy +int rg_lstati(), rg_lplot(), clgcur(), rg_lgqverify(), rg_lgtverify() +int rg_ldelete(), rg_lfind(), rg_mmhplot(), rg_rifplot(), rg_rirplot() +int rg_lregions() +pointer rg_lstatp() + +begin + call gdeactivate (gd, 0) + + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (udelete, rg_lstati(ls, MAXNREGIONS), TY_INT) + + # Initialize the fitting. + newref = YES + newimage = YES + newfit = YES + newavg = YES + + # Initialize the plotting. + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN, LS_MEDIAN, LS_MODE: + if (rg_lstati (ls, NREGIONS) > 1) + plottype = LS_MMFIT + else + plottype = LS_MMHIST + case LS_FIT: + if (rg_lstati (ls, NREGIONS) > 1) + plottype = LS_BSZFIT + else + plottype = LS_RIFIT + case LS_PHOTOMETRY: + plottype = LS_BSZFIT + default: + } + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN, LS_MEDIAN, LS_MODE: + if (rg_lstati (ls, NREGIONS) > 1) + plottype = LS_MMFIT + else + plottype = LS_MMHIST + case LS_FIT: + if (rg_lstati (ls, NREGIONS) > 1) + plottype = LS_BSZFIT + else + plottype = LS_RIFIT + case LS_PHOTOMETRY: + plottype = LS_BSZFIT + default: + } + + # Do the initial fit. + if (rg_lstati (ls, NREGIONS) <= 0) { + call gclear (gd) + call gflush (gd) + bscale = 1.0; bzero = 0.0 + bserr = INDEFR; bzerr = INDEFR + call printf ("The regions/photometry list is empty\n") + } else { + call amovki (LS_NO, Memi[rg_lstatp(ls,RDELETE)], rg_lstati(ls, + NREGIONS)) + call rg_scale (imr, im1, ls, bscale, bzero, bserr, bzerr, YES) + call amovki (NO, Memi[udelete], rg_lstati(ls,NREGIONS)) + if (rg_lplot (gd, imr, im1, ls, Memi[udelete], 1, bscale, bzero, + plottype) == OK) { + newref = NO + newimage = NO + newfit = NO + newavg = NO + call rg_lpwrec (ls, 0) + } else { + call gclear (gd) + call gflush (gd) + call rg_lstats (ls, IMAGE, Memc[cmd], SZ_FNAME) + call printf ("Error computing scale factors for image %s\n") + call pargstr (Memc[cmd]) + } + } + newplot = NO + + # Loop over the cursor commands. + while (clgcur ("gcommands", wx, wy, wcs, key, Memc[cmd], SZ_LINE) != + EOF) { + + switch (key) { + + # Print the help page. + case '?': + call gpagefile (gd, HELPFILE, "") + + # Quit the task gracefully. + case 'q': + if (rg_lgqverify ("linmatch", db, dformat, ls, + key) == YES) { + call sfree (sp) + return (rg_lgtverify (key)) + } + + # Refit the data. + case 'f': + if (newref == YES || newimage == YES || newfit == YES || + newavg == YES) { + if (rg_lstati(ls, BSALGORITHM) != LS_PHOTOMETRY && + rg_lstati(ls, BZALGORITHM) != LS_PHOTOMETRY) { + if (newref == YES) { + if (rg_lregions (reglist, imr, ls, 1, YES) > 0) + ; + } else if (newimage == YES) { + call rg_lindefr (ls) + } + } + if (newfit == YES) + call amovki (LS_NO, Memi[rg_lstatp(ls,RDELETE)], + rg_lstati(ls,NREGIONS)) + else if (newavg == YES) { + do i = 1, rg_lstati(ls,NREGIONS) { + if (Memi[rg_lstatp(ls,RDELETE)+i-1] == + LS_DELETED || Memi[rg_lstatp(ls, + RDELETE)+i-1] == LS_BADSIGMA) + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_NO + } + + } + do i = 1, rg_lstati(ls,NREGIONS) { + if (Memi[udelete+i-1] == YES) + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_DELETED + } + if (newfit == YES) + call rg_scale (imr, im1, ls, bscale, bzero, bserr, + bzerr, YES) + else if (newavg == YES) + call rg_scale (imr, im1, ls, bscale, bzero, bserr, + bzerr, NO) + newref = NO + newimage = NO + newfit = NO + newavg = NO + newplot = YES + } + + # Plot the default graph. + case 'g': + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN, LS_MEDIAN, LS_MODE: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_MMFIT) + newplot = YES + plottype = LS_MMFIT + } else { + if (plottype != LS_MMHIST) + newplot = YES + plottype = LS_MMHIST + } + case LS_FIT: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_BSZFIT) + newplot = YES + plottype = LS_BSZFIT + } else { + if (plottype != LS_RIFIT) + newplot = YES + plottype = LS_RIFIT + } + case LS_PHOTOMETRY: + if (plottype != LS_BSZFIT) + newplot = YES + plottype = LS_BSZFIT + default: + } + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN, LS_MEDIAN, LS_MODE: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_MMFIT) + newplot = YES + plottype = LS_MMFIT + } else { + if (plottype != LS_MMHIST) + newplot = YES + plottype = LS_MMHIST + } + case LS_FIT: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_BSZFIT) + plottype = LS_BSZFIT + } else { + if (plottype != LS_RIFIT) + plottype = LS_RIFIT + } + case LS_PHOTOMETRY: + if (plottype != LS_BSZFIT) + newplot = YES + plottype = LS_BSZFIT + default: + } + + # Graph the residuals from the current fit. + case 'i': + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN, LS_MEDIAN, LS_MODE: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_MMRESID) + newplot = YES + plottype = LS_MMRESID + } else { + call printf ( + "There are too few regions for a residuals plot\n") + } + case LS_FIT: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_BSZRESID) + newplot = YES + plottype = LS_BSZRESID + } else { + if (plottype != LS_RIRESID) + newplot = YES + plottype = LS_RIRESID + } + case LS_PHOTOMETRY: + if (plottype == LS_BSZFIT) { + newplot = YES + plottype = LS_BSZRESID + } else if (plottype == LS_MAGSKYFIT) { + newplot = YES + plottype = LS_MAGSKYRESID + } + default: + } + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN, LS_MEDIAN, LS_MODE: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_MMRESID) + newplot = YES + plottype = LS_MMRESID + } else { + call printf ( + "There are too few regions for a residuals plot\n") + } + case LS_FIT: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_BSZRESID) + newplot = YES + plottype = LS_BSZRESID + } else { + if (plottype != LS_RIRESID) + newplot = YES + plottype = LS_RIRESID + } + case LS_PHOTOMETRY: + if (plottype == LS_BSZFIT) { + newplot = YES + plottype = LS_BSZRESID + } else if (plottype == LS_MAGSKYFIT) { + newplot = YES + plottype = LS_MAGSKYRESID + } + default: + } + + # Plot the histogram and show the statistics of a given region. + # selected from a plot. + case 's': + if (imr != NULL && im1 != NULL) { + reg = rg_lfind (gd, ls, wcs, wx, wy, bscale, bzero, + plottype) + if (reg > 0) { + if (rg_mmhplot (gd, imr, im1, ls, Memi[udelete], + reg) == OK) { + call rg_lpwrec (ls, reg) + } else { + call printf ( + "Unable to plot statistics for region %d\n") + call pargi (reg) + } + } else + call printf ("Unable to plot region statistics\n") + } else + call printf ( + "The reference or input image is undefined\n") + + # Trace the fit of a given region selected from a plot. + case 't': + if (imr != NULL && im1 != NULL && (rg_lstati(ls, + BSALGORITHM) == LS_FIT || rg_lstati(ls,BZALGORITHM) == + LS_FIT)) { + reg = rg_lfind (gd, ls, wcs, wx, wy, bscale, bzero, + plottype) + if (reg > 0) { + if (plottype == LS_BSZFIT) + stat = rg_rifplot (gd, imr, im1, ls, + Memi[udelete], reg) + else if (plottype == LS_BSZRESID) + stat = rg_rirplot (gd, imr, im1, ls, + Memi[udelete], reg) + else + stat = ERR + if (stat == OK) + call rg_lpwrec (ls, reg) + else { + call printf ( + "Unable to plot statistics for region %d\n") + call pargi (reg) + } + } else + call printf ( + "Unable to plot region statistics\n") + } else + call printf ( + "The least squares fit is undefined\n") + + # Plot the statistics and show the histograms for each + # region in turn. + case 'h': + if (imr != NULL && im1 != NULL) { + reg = 1 + if (rg_mmhplot (gd, imr, im1, ls, Memi[udelete], + reg) == ERR) { + call printf ( + "Unable to plot statistics for region 1\n") + next + } + hplot = NO + call printf ( + "Hit [spbar=next,-=prev,s=stats,?=help,q=quit]:") + while (clgcur ("gcommands", wx, wy, wcs, key, Memc[cmd], + SZ_LINE) != EOF) { + switch (key) { + case '?': + call printf ( + "Hit [spbar=next,-=prev,s=stats,?=help,q=quit]:") + case 'q': + call printf ("\n") + break + case ' ': + if (reg < rg_lstati (ls, NREGIONS)) { + reg = reg + 1 + hplot = YES + } + case '-': + if (reg > 1) { + reg = reg - 1 + hplot = YES + } + case 's': + call rg_lpwrec (ls, reg) + } + if (hplot == YES) { + if (rg_mmhplot (gd, imr, im1, ls, + Memi[udelete], reg) == ERR) + ; + call printf ( + "Hit [spbar=next,-=prev,s=stats,?=help,q=quit]:") + hplot = NO + } + } + newplot = YES + } else + call printf ( + "The reference or input image is undefined\n") + + # Step through the least sqares fits one at a time. + case 'l': + if (imr != NULL && im1 != NULL && (rg_lstati(ls, + BSALGORITHM) == LS_FIT || rg_lstati(ls,BZALGORITHM) == + LS_FIT)) { + reg = 1 + lplot = NO + if (plottype == LS_BSZFIT || plottype == LS_RIFIT) + lplot_type = LS_RIFIT + else if (plottype == LS_BSZRESID || plottype == + LS_RIRESID) + lplot_type = LS_RIRESID + if (lplot_type == LS_RIFIT) + stat = rg_rifplot (gd, imr, im1, ls, Memi[udelete], + reg) + else if (lplot_type == LS_RIRESID) + stat = rg_rirplot (gd, imr, im1, ls, Memi[udelete], + reg) + else + stat = ERR + if (stat == ERR) { + call printf ("Unable to plot fits for region 1\n") + next + } + call printf ( + "Hit [spbar=next,-=prev,l=fit,i=resid,s=stats,?=help,q=quit]:") + while (clgcur ("gcommands", wx, wy, wcs, key, Memc[cmd], + SZ_LINE) != EOF) { + switch (key) { + case '?': + call printf ( + "Hit [spbar=next,-=prev,l=fit,i=resid,s=stats,?=help,q=quit]:") + case 'q': + call printf ("\n") + break + case ' ': + if (reg < rg_lstati (ls, NREGIONS)) { + reg = reg + 1 + lplot = YES + } + case '-': + if (reg > 1) { + reg = reg - 1 + lplot = YES + } + case 'l': + if (lplot_type == LS_RIRESID) + lplot = YES + lplot_type = LS_RIFIT + case 'i': + if (lplot_type == LS_RIFIT) + lplot = YES + lplot_type = LS_RIRESID + case 's': + call rg_lpwrec (ls, reg) + } + if (lplot == YES) { + if (lplot_type == LS_RIFIT) + stat = rg_rifplot (gd, imr, im1, ls, + Memi[udelete], reg) + else if (lplot_type == LS_RIRESID) + stat = rg_rirplot (gd, imr, im1, ls, + Memi[udelete], reg) + call printf ( + "Hit [spbar=next,-=prev,l=fit,i=resid,s=stats,?=help,q=quit]:") + lplot = NO + } + } + newplot = YES + } else + call printf ( + "The least squares fit is undefined\n") + + # Plot the photometry + case 'p': + if (rg_lstati(ls,BSALGORITHM) == LS_PHOTOMETRY || + rg_lstati(ls,BZALGORITHM) == LS_PHOTOMETRY) { + plottype = LS_MAGSKYFIT + newplot = YES + } else + call printf ("The input photometry is undefined\n") + + # Replot the current graph. + case 'r': + newplot = YES + + # Delete or undelete a region. + case 'd', 'u': + if (key == 'd') + reg = rg_ldelete (gd, ls, Memi[udelete], wcs, wx, wy, + bscale, bzero, plottype, YES) + else + reg = rg_ldelete (gd, ls, Memi[udelete], wcs, wx, wy, + bscale, bzero, plottype, NO) + if (reg > 0) + newavg = YES + + + # Process colon commands. + case ':': + call rg_lcolon (gd, ls, imr, im1, im2, db, dformat, + reglist, rpfd, ipfd, sfd, Memc[cmd], newref, + newimage, newfit, newavg) + + # Write the parameters to the parameter file. + case 'w': + call rg_plpars (ls) + + # Do nothing gracefully. + default: + } + + if (newplot == YES) { + if (rg_lstati(ls,NREGIONS) <= 0) { + call gclear (gd) + call gflush (gd) + bscale = 1.0; bzero = 0.0 + bserr = INDEFR; bzerr = INDEFR + call printf ("The regions/photometry list is empty\n") + } else if (newref == YES || newimage == YES) { + call printf ("Bscale and bzero must be recomputed\n") + } else if (rg_lplot (gd, imr, im1, ls, Memi[udelete], 1, + bscale, bzero, plottype) == OK) { + if (newfit == YES || newavg == YES) + call printf ("Bscale and bzero should be recomputed\n") + else + call rg_lpwrec (ls, 0) + newplot = NO + } else + call printf ("Unable to plot image data for region 1\n") + } + + } + + call sfree (sp) +end + +define QUERY "Hit [return=continue, n=next image, q=quit, w=quit and update parameters]: " + +# RG_LGQVERIFY -- Print a message on the status line asking the user if they +# really want to quit, returning YES if they really want to quit, NO otherwise. + +int procedure rg_lgqverify (task, db, dformat, rg, ch) + +char task[ARB] #I the calling task name +pointer db #I pointer to the shifts database file +int dformat #I is the shifts file in database format +pointer rg #I pointer to the task structure +int ch #I the input keystroke command + +int wcs, stat +pointer sp, cmd +real wx, wy +bool streq() +int clgcur() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Print the status line query in reverse video and get the keystroke. + call printf (QUERY) + #call flush (STDOUT) + if (clgcur ("gcommands", wx, wy, wcs, ch, Memc[cmd], SZ_LINE) == EOF) + ; + + # Process the command. + if (ch == 'q') { + call rg_lwrec (db, dformat, rg) + stat = YES + } else if (ch == 'w') { + call rg_lwrec (db, dformat, rg) + if (streq ("linmatch", task)) + call rg_plpars (rg) + stat = YES + } else if (ch == 'n') { + call rg_lwrec (db, dformat, rg) + stat = YES + } else { + stat = NO + } + + call sfree (sp) + return (stat) +end + + +# RG_LGTVERIFY -- Verify whether or not the user truly wishes to quit the +# task. + +int procedure rg_lgtverify (ch) + +int ch #I the input keystroke command + +begin + if (ch == 'q') { + return (YES) + } else if (ch == 'w') { + return (YES) + } else if (ch == 'n') { + return (NO) + } else { + return (NO) + } +end diff --git a/pkg/images/immatch/src/linmatch/rglpars.x b/pkg/images/immatch/src/linmatch/rglpars.x new file mode 100644 index 00000000..d5f66320 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rglpars.x @@ -0,0 +1,104 @@ +include <lexnum.h> +include "linmatch.h" + + +# RG_GLPARS -- Fetch the algorithm parameters required by the intensity scaling +# task. + +procedure rg_glpars (ls) + +pointer ls #I pointer to iscale structure + +int ip, nchars +pointer sp, str1, str2 +int clgeti(), nscan(), lexnum() +real clgetr() + +begin + # Allocate working space. + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + # Initialize the linscale structure. + call rg_linit (ls, clgeti ("maxnregions")) + + # Get the x and y shifts. + call rg_lsetr (ls, XSHIFT, clgetr("xshift")) + call rg_lsetr (ls, YSHIFT, clgetr("yshift")) + + # Get the scaling algorithm parameters. + call clgstr ("scaling", Memc[str1], SZ_LINE) + call sscan (Memc[str1]) + call gargwrd (Memc[str1], SZ_LINE) + call gargwrd (Memc[str2], SZ_LINE) + call rg_lsets (ls, BSSTRING, Memc[str1]) + ip = 1 + if (nscan() == 2) + call rg_lsets (ls, BZSTRING, Memc[str2]) + else if (lexnum(Memc[str1], ip, nchars) == LEX_NONNUM) + call rg_lsets (ls, BZSTRING, Memc[str1]) + else + call rg_lsets (ls, BZSTRING, "0.0") + + call rg_lseti (ls, DNX, clgeti ("dnx")) + call rg_lseti (ls, DNY, clgeti ("dny")) + call rg_lseti (ls, MAXITER, clgeti ("maxiter")) + call rg_lsetr (ls, DATAMIN, clgetr ("datamin")) + call rg_lsetr (ls, DATAMAX, clgetr ("datamax")) + call rg_lseti (ls, NREJECT, clgeti ("nreject")) + call rg_lsetr (ls, LOREJECT, clgetr ("loreject")) + call rg_lsetr (ls, HIREJECT, clgetr ("hireject")) + + call clgstr ("gain", Memc[str1], SZ_LINE) + call rg_lsets (ls, CCDGAIN, Memc[str1]) + call clgstr ("readnoise", Memc[str1], SZ_LINE) + call rg_lsets (ls, CCDREAD, Memc[str1]) + + call sfree (sp) +end + + +# RG_PLPARS -- Save the intensity scaling parameters in the .par file. + +procedure rg_plpars (ls) + +pointer ls # pointer to the linscale structure + +pointer sp, str1, str2, str +int rg_lstati() +real rg_lstatr() + +begin + # Allocate working space. + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Set the x and y shifts parameters. + call clputr ("xshift", rg_lstatr (ls, XSHIFT)) + call clputr ("yshift", rg_lstatr (ls, YSHIFT)) + + # Scaling algorithm parameters. + call rg_lstats (ls, BSSTRING, Memc[str1], SZ_LINE) + call rg_lstats (ls, BZSTRING, Memc[str2], SZ_LINE) + call sprintf (Memc[str], SZ_FNAME, "%s %s") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call clpstr ("scaling", Memc[str]) + call clputi ("dnx", rg_lstati (ls, DNX)) + call clputi ("dny", rg_lstati (ls, DNY)) + call clputi ("maxiter", rg_lstati (ls, MAXITER)) + call clputr ("datamin", rg_lstatr (ls, DATAMIN)) + call clputr ("datamax", rg_lstatr (ls, DATAMAX)) + call clputi ("nreject", rg_lstati (ls, NREJECT)) + call clputr ("loreject", rg_lstatr (ls, LOREJECT)) + call clputr ("hireject", rg_lstatr (ls, HIREJECT)) + call rg_lstats (ls, CCDGAIN, Memc[str], SZ_FNAME) + call clpstr ("gain", Memc[str]) + call rg_lstats (ls, CCDREAD, Memc[str], SZ_FNAME) + call clpstr ("readnoise", Memc[str]) + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/linmatch/rglplot.x b/pkg/images/immatch/src/linmatch/rglplot.x new file mode 100644 index 00000000..e46f3bcd --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rglplot.x @@ -0,0 +1,1592 @@ +include <mach.h> +include <gset.h> +include "linmatch.h" + +define MINFRACTION 0.01 +define FRACTION 0.05 + +# XP_LPLOT -- Plot the data. + +int procedure rg_lplot (gd, imr, im1, ls, udelete, region, bscale, bzero, + plot_type) + +pointer gd #I pointer to the graphics stream +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deletions array +int region #I the current region if applicable +real bscale #I the computed bscale value +real bzero #I the computed bzero value +int plot_type #I the current plot type + +int stat +int rg_mmhplot(), rg_mmfplot(), rg_mmrplot(), rg_rifplot(), rg_rirplot() +int rg_bzfplot(), rg_bzrplot(), rg_msfplot(), rg_msrplot() + +begin + stat = OK + + switch (plot_type) { + case LS_MMHIST: + stat = rg_mmhplot (gd, imr, im1, ls, udelete, region) + case LS_MMFIT: + stat = rg_mmfplot (gd, ls, udelete, bscale, bzero) + case LS_MMRESID: + stat = rg_mmrplot (gd, ls, udelete, bscale, bzero) + case LS_RIFIT: + stat = rg_rifplot (gd, imr, im1, ls, udelete, region) + case LS_RIRESID: + stat = rg_rirplot (gd, imr, imr, ls, udelete, region) + case LS_BSZFIT: + stat = rg_bzfplot (gd, ls, udelete, bscale, bzero) + case LS_BSZRESID: + stat = rg_bzrplot (gd, ls, udelete, bscale, bzero) + case LS_MAGSKYFIT: + stat = rg_msfplot (gd, ls, udelete, bscale, bzero) + case LS_MAGSKYRESID: + stat = rg_msrplot (gd, ls, udelete, bscale, bzero) + default: + stat = ERR + } + + return (stat) +end + + +# RG_MMHPLOT -- Plot the histogram of the data used to compute the mean, median,# and mode. + +int procedure rg_mmhplot (gd, imr, im1, ls, udelete, region) + +pointer gd #I pointer to the graphics stream +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deleteions array +int region #I the current region if applicable + +int nbinsr, nbins1 +pointer rbuf, ibuf, sp, hgmi, hgmr, image, title, str +real rsigma, hminr, hmaxr, dhr, isigma, hmin1, hmax1, dh1, ymin, ymax +int rg_lstati(), rg_limget() +pointer rg_lstatp() + +begin + # Get the data. + if (imr == NULL || im1 == NULL) { + return (ERR) + } else if (region == rg_lstati (ls,CNREGION) && + rg_lstatp (ls,RBUF) != NULL && rg_lstatp(ls, IBUF) != NULL) { + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + } else if (rg_limget (ls, imr, im1, region) == OK) { + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + } else { + return (ERR) + } + + # Get the reference image binning parameters. + rsigma = sqrt (real(Memi[rg_lstatp(ls,RNPTS)+region-1])) * + Memr[rg_lstatp(ls,RSIGMA)+region-1] + hminr = Memr[rg_lstatp(ls,RMEDIAN)+region-1] - LMODE_HWIDTH * rsigma + hmaxr = Memr[rg_lstatp(ls,RMEDIAN)+region-1] + LMODE_HWIDTH * rsigma + dhr = LMODE_ZBIN * rsigma + if (dhr <= 0.0) + return (ERR) + nbinsr = (hmaxr - hminr) / dhr + 1 + if (nbinsr <= 0) + return (ERR) + + # Get the input image binning parameters. + isigma = sqrt (real(Memi[rg_lstatp(ls,INPTS)+region-1])) * + Memr[rg_lstatp(ls,ISIGMA)+region-1] + hmin1 = Memr[rg_lstatp(ls,IMEDIAN)+region-1] - LMODE_HWIDTH * isigma + hmax1 = Memr[rg_lstatp(ls,IMEDIAN)+region-1] + LMODE_HWIDTH * isigma + dh1 = LMODE_ZBIN * isigma + if (dh1 <= 0.0) + return (ERR) + nbins1 = (hmax1 - hmin1) / dh1 + 1 + if (nbins1 <= 0.0) + return (ERR) + + # Allocate working space. + call smark (sp) + call salloc (hgmi, max (nbinsr, nbins1), TY_INT) + call salloc (hgmr, max (nbinsr, nbins1), TY_REAL) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + call gclear (gd) + + # Create the reference histogram. + call aclri (Memi[hgmi], nbinsr) + call ahgmr (Memr[rbuf], Memi[rg_lstatp(ls,RNPTS)+region-1], + Memi[hgmi], nbinsr, hminr, hmaxr) + call achtir (Memi[hgmi], Memr[hgmr], nbinsr) + call alimr (Memr[hgmr], nbinsr, ymin, ymax) + + # Compute the limits for the reference histogram. + call gseti (gd, G_WCS, 1) + call gsview (gd, 0.1, 0.9, 0.6, 0.9) + call gswind (gd, hminr, hmaxr, ymin, ymax) + call rg_pfill (gd, hminr, hmaxr, ymin, ymax, GF_SOLID, 0) + call rg_lstats (ls, REFIMAGE, Memc[image], SZ_FNAME) + call sprintf (Memc[str], SZ_LINE, + "Mean = %g Median = %g Mode = %g Sigma = %g") + call pargr (Memr[rg_lstatp(ls,RMEAN)+region-1]) + call pargr (Memr[rg_lstatp(ls,RMEDIAN)+region-1]) + call pargr (Memr[rg_lstatp(ls,RMODE)+region-1]) + call pargr (rsigma) + + # Create the title for the reference histogram. + call sprintf (Memc[title], 2 * SZ_LINE, + "Ref Image: %s Region: %d%s\nNbins = %d Hmin = %g Hmax = %g Dh = %g\n%s\n") + call pargstr (Memc[image]) + call pargi (region) + if (udelete[region] == YES) + call pargstr (" [deleted]") + else if (Memi[rg_lstatp(ls,RDELETE)+region-1] != LS_NO) + call pargstr (" [rejected]") + else + call pargstr ("") + call pargi (nbinsr) + call pargr (hminr) + call pargr (hmaxr) + call pargr (dhr) + call pargstr (Memc[str]) + call gseti (gd, G_YNMINOR, 0) + call glabax (gd, Memc[title], "", "") + + # Plot the reference histogram. + call rg_lhbox (gd, Memr[hgmr], nbinsr, hminr - dhr / 2.0, + hmaxr + dhr / 2.0) + + # Create the input histogram. + call aclri (Memi[hgmi], nbins1) + call ahgmr (Memr[ibuf], Memi[rg_lstatp(ls,INPTS)+region-1], + Memi[hgmi], nbins1, hmin1, hmax1) + call achtir (Memi[hgmi], Memr[hgmr], nbins1) + call alimr (Memr[hgmr], nbins1, ymin, ymax) + + # Compute the limits for the input histogram. + call gseti (gd, G_WCS, 2) + call gsview (gd, 0.1, 0.9, 0.1, 0.4) + call gswind (gd, hmin1, hmax1, ymin, ymax) + call rg_pfill (gd, hmin1, hmax1, ymin, ymax, GF_SOLID, 0) + + # Create the title for the input histogram. + call rg_lstats (ls, IMAGE, Memc[image], SZ_FNAME) + call sprintf (Memc[str], SZ_LINE, + "Mean = %g Median = %g Mode = %g Sigma = %g") + call pargr (Memr[rg_lstatp(ls,IMEAN)+region-1]) + call pargr (Memr[rg_lstatp(ls,IMEDIAN)+region-1]) + call pargr (Memr[rg_lstatp(ls,IMODE)+region-1]) + call pargr (isigma) + call sprintf (Memc[title], 2 * SZ_LINE, + "Input Image: %s Region: %d%s\nNbins = %d Hmin = %g Hmax = %g Dh = %g\n%s\n") + call pargstr (Memc[image]) + call pargi (region) + if (udelete[region] == YES) + call pargstr (" [deleted]") + else if (Memi[rg_lstatp(ls,RDELETE)+region-1] != NO) + call pargstr (" [rejected]") + else + call pargstr ("") + call pargi (nbins1) + call pargr (hmin1) + call pargr (hmax1) + call pargr (dh1) + call pargstr (Memc[str]) + call gseti (gd, G_YNMINOR, 0) + call glabax (gd, Memc[title], "", "") + + # Plot the input histogram. + call rg_lhbox (gd, Memr[hgmr], nbins1, hmin1 - dh1 / 2.0, + hmax1 + dh1 / 2.0) + + call sfree (sp) + + return (OK) +end + + +# RG_MMFPLOT -- Plot the fit computed from the mean, median, or mode. + +int procedure rg_mmfplot (gd, ls, udelete, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deletions array +real bscale #I the fitted bscale value +real bzero #I the fitted bzero value + +bool start, finish +int nregions, mtype +pointer sp, title, str, imager, image1 +real xmin, xmax, ymin, ymax, diff, dxmin, dxmax, dymin, dymax, x, y +int rg_lstati() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (ERR) + + # Determine the type of data to plot. + mtype = 0 + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + if (mtype <= 0) + return (ERR) + + # Allocate working space. + call smark (sp) + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (imager, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_LINE, TY_CHAR) + + # Clear the plot space. + call gclear (gd) + + # Compute the limits of the plot. + switch (mtype) { + case LS_MEAN: + call rg_galimr (Memr[rg_lstatp(ls,IMEAN)], + Memi[rg_lstatp(ls,RDELETE)], nregions, xmin, xmax) + call rg_galimr (Memr[rg_lstatp(ls,RMEAN)], + Memi[rg_lstatp(ls,RDELETE)], nregions, ymin, ymax) + case LS_MEDIAN: + call rg_galimr (Memr[rg_lstatp(ls,IMEDIAN)], + Memi[rg_lstatp(ls,RDELETE)], nregions, xmin, xmax) + call rg_galimr (Memr[rg_lstatp(ls,RMEDIAN)], + Memi[rg_lstatp(ls,RDELETE)], nregions, ymin, ymax) + case LS_MODE: + call rg_galimr (Memr[rg_lstatp(ls,IMODE)], + Memi[rg_lstatp(ls,RDELETE)], nregions, xmin, xmax) + call rg_galimr (Memr[rg_lstatp(ls,RMODE)], + Memi[rg_lstatp(ls,RDELETE)], nregions, ymin, ymax) + } + dxmin = xmin + dxmax = xmax + dymin = ymin + dymax = ymax + + diff = xmax - xmin + if (diff <= 0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (xmax + xmin) / 2.0) + xmin = xmin - diff * FRACTION + xmax = xmax + diff * FRACTION + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (ymax + ymin) / 2.0) + ymin = ymin - diff * FRACTION + ymax = ymax + diff * FRACTION + call gswind (gd, xmin, xmax, ymin, ymax) + + # Construct the titles and axis labels. + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + call rg_lstats (ls, IMAGE, Memc[image1], SZ_FNAME) + call sprintf (Memc[str], SZ_LINE, + "Nregions = %d Ref Image = %g * Input Image + %g") + call pargi (nregions) + call pargr (bscale) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, + "Counts for %s versus Counts for %s\n%s\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Image Counts", + "Ref Image Counts") + + # Plot the data. + switch (mtype) { + case LS_MEAN: + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMEAN)], + Memr[rg_lstatp(ls,RMEAN)], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions, GM_BOX, GM_CROSS) + case LS_MEDIAN: + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMEDIAN)], + Memr[rg_lstatp(ls,RMEDIAN)], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions, GM_BOX, GM_CROSS) + case LS_MODE: + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMODE)], + Memr[rg_lstatp(ls,RMODE)], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions, GM_BOX, GM_CROSS) + } + + # Plot the fit. + start = false + finish = false + if (! IS_INDEFR(bscale) && ! IS_INDEFR(bzero)) { + y = bscale * dxmin + bzero + if (y >= ymin && y <= ymax) { + call gamove (gd, dxmin, y) + start = true + } + y = bscale * dxmax + bzero + if (y >= ymin && y <= ymax) { + if (start) { + call gadraw (gd, dxmax, y) + finish = true + } else { + call gamove (gd, dxmax, y) + start = true + } + } + x = (dymin - bzero) / bscale + if (x >= xmin && x <= xmax) { + if (! start) { + call gamove (gd, x, dymin) + start = true + } else if (! finish) { + call gadraw (gd, x, dymin) + finish = true + } + } + x = (dymax - bzero) / bscale + if (x >= xmin && x <= xmax) { + if (! start) { + call gamove (gd, x, dymax) + start = true + } else if (! finish) { + call gadraw (gd, x, dymax) + finish = true + } + } + } + + call sfree (sp) + + return (OK) +end + + +# RG_MMRPLOT -- Plot the residuals from the fit computed from the mean, +# median, or mode. + +int procedure rg_mmrplot (gd, ls, udelete, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deletions array +real bscale #I the fitted bscale value +real bzero #I the fitted bzero value + +int nregions, mtype +pointer sp, resid, title, imager, image1, str +real xmin, xmax, ymin, ymax, diff +int rg_lstati() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (ERR) + + # Determine the type of data to plot. + mtype = 0 + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + if (mtype <= 0) + return (ERR) + + # Allocate working space. + call smark (sp) + + call gclear (gd) + + # Compute the data. + call salloc (resid, nregions, TY_REAL) + switch (mtype) { + case LS_MEAN: + call altmr (Memr[rg_lstatp(ls,IMEAN)], Memr[resid], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMEAN)], Memr[resid], Memr[resid], + nregions) + call rg_galimr (Memr[rg_lstatp(ls,IMEAN)], + Memi[rg_lstatp(ls,RDELETE)], nregions, xmin, xmax) + call rg_galimr (Memr[resid], Memi[rg_lstatp(ls,RDELETE)], nregions, + ymin, ymax) + case LS_MEDIAN: + call altmr (Memr[rg_lstatp(ls,IMEDIAN)], Memr[resid], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMEDIAN)], Memr[resid], Memr[resid], + nregions) + call rg_galimr (Memr[rg_lstatp(ls,IMEDIAN)], + Memi[rg_lstatp(ls,RDELETE)], nregions, xmin, xmax) + call rg_galimr (Memr[resid], Memi[rg_lstatp(ls,RDELETE)], nregions, + ymin, ymax) + case LS_MODE: + call altmr (Memr[rg_lstatp(ls,IMODE)], Memr[resid], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMODE)], Memr[resid], Memr[resid], + nregions) + call rg_galimr (Memr[rg_lstatp(ls,IMODE)], + Memi[rg_lstatp(ls,RDELETE)], nregions, xmin, xmax) + call rg_galimr (Memr[resid], Memi[rg_lstatp(ls,RDELETE)], nregions, + ymin, ymax) + } + + # Compute the data limits. + diff = xmax - xmin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (xmax + xmin) / 2.0) + xmin = xmin - diff * FRACTION + xmax = xmax + diff * FRACTION + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (ymax + ymin) / 2.0) + ymin = ymin - diff * FRACTION + ymax = ymax + diff * FRACTION + call gswind (gd, xmin, xmax, ymin, ymax) + + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + call rg_lstats (ls, IMAGE, Memc[image1], SZ_FNAME) + call sprintf (Memc[str], SZ_LINE, + "Nregions = %d Ref Image = %g * Input Image + %g") + call pargi (nregions) + call pargr (bscale) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, + "Residuals for %s versus Counts for %s\n%s\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Image Counts", + "Residual Counts") + + # Plot the data. + switch (mtype) { + case LS_MEAN: + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMEAN)], Memr[resid], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions, + GM_BOX, GM_CROSS) + case LS_MEDIAN: + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMEDIAN)], Memr[resid], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions, + GM_BOX, GM_CROSS) + case LS_MODE: + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMODE)], Memr[resid], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions, + GM_BOX, GM_CROSS) + } + + # Plot the residuals 0 line. + call gamove (gd, xmin, 0.0) + call gadraw (gd, xmax, 0.0) + + call sfree (sp) + + return (OK) +end + + +# RG_RIFPLOT -- Plot the pixel to pixel fit for a region. + +int procedure rg_rifplot (gd, imr, im1, ls, udelete, region) + +pointer gd #I pointer to the graphics stream +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I pointer to the user deletions array +int region #I the current region + +bool start, finish +int npts +pointer rbuf, ibuf, sp, title, str, imager, image1, resid +real xmin, xmax, ymin, ymax, diff, bscale, bzero, datamin, datamax +real loreject, hireject, chi, dxmin, dxmax, dymin, dymax, x, y +int rg_lstati(), rg_limget() +pointer rg_lstatp() +real rg_lstatr() + +begin + # Get the data. + if (imr == NULL || im1 == NULL) { + return (ERR) + } else if (region == rg_lstati (ls,CNREGION) && + rg_lstatp (ls,RBUF) != NULL && rg_lstatp(ls, IBUF) != NULL) { + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + } else if (rg_limget (ls, imr, im1, region) == OK) { + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + } else { + return (ERR) + } + + # Initialize. + call gclear (gd) + + # Get some constants + npts = Memi[rg_lstatp(ls,RNPTS)+region-1] + bscale = Memr[rg_lstatp(ls,RBSCALE)+region-1] + bzero = Memr[rg_lstatp(ls,RBZERO)+region-1] + chi = Memr[rg_lstatp(ls,RCHI)+region-1] + if (IS_INDEFR(rg_lstatr(ls,DATAMIN))) + datamin = -MAX_REAL + else + datamin = rg_lstatr (ls,DATAMIN) + if (IS_INDEFR(rg_lstatr(ls,DATAMAX))) + datamax = MAX_REAL + else + datamax = rg_lstatr (ls,DATAMAX) + if (rg_lstati(ls,NREJECT) <= 0 || IS_INDEFR(rg_lstatr(ls,LOREJECT)) || + IS_INDEFR(chi)) + loreject = -MAX_REAL + else + loreject = -rg_lstatr (ls,LOREJECT) * chi + if (rg_lstati(ls,NREJECT) <= 0 || IS_INDEFR(rg_lstatr(ls,HIREJECT)) || + IS_INDEFR(chi)) + hireject = MAX_REAL + else + hireject = rg_lstatr (ls,HIREJECT) * chi + + # Compute the plot limits. + call alimr (Memr[ibuf], npts, xmin, xmax) + call alimr (Memr[rbuf], npts, ymin, ymax) + dxmin = xmin + dxmax = xmax + dymin = ymin + dymax = ymax + + diff = xmax - xmin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (xmax + xmin) / 2.0) + xmin = xmin - diff * FRACTION + xmax = xmax + diff * FRACTION + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (ymax + ymin) / 2.0) + ymin = ymin - diff * FRACTION + ymax = ymax + diff * FRACTION + call gswind (gd, xmin, xmax, ymin, ymax) + + # Allocate working space. + call smark (sp) + + # Create the plot title. + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + call rg_lstats (ls, IMAGE, Memc[image1], SZ_FNAME) + call sprintf (Memc[str], SZ_LINE, + "Region %d%s: Ref Image = %g * Input Image + %g") + call pargi (region) + if (udelete[region] == YES) + call pargstr (" [deleted]") + else if (Memi[rg_lstatp(ls,RDELETE)+region-1] != LS_NO) + call pargstr (" [rejected]") + else + call pargstr ("") + call pargr (bscale) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, + "Counts for Image %s versus Counts for Image %s\n%s\n\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Image Counts", + "Ref image Counts") + + # Compute the residuals. + call salloc (resid, npts, TY_REAL) + if (IS_INDEFR(bscale) || IS_INDEFR(bzero)) + call amovkr (0.0, Memr[resid], npts) + else { + call altmr (Memr[ibuf], Memr[resid], npts, bscale, bzero) + call asubr (Memr[rbuf], Memr[resid], Memr[resid], npts) + } + + # Plot the data. + call rg_riplot (gd, Memr[ibuf], Memr[rbuf], Memr[resid], npts, + datamin, datamax, loreject, hireject, GM_BOX, GM_CROSS) + + # Plot the fit if bscale and bzero are defined. + start = false + finish = false + if (! IS_INDEFR(bscale) && ! IS_INDEFR(bzero)) { + y = bscale * dxmin + bzero + if (y >= ymin && y <= ymax) { + call gamove (gd, dxmin, y) + start = true + } + y = bscale * dxmax + bzero + if (y >= ymin && y <= ymax) { + if (start) { + call gadraw (gd, dxmax, y) + finish = true + } else { + call gamove (gd, dxmax, y) + start = true + } + } + x = (dymin - bzero) / bscale + if (x >= xmin && x <= xmax) { + if (! start) { + call gamove (gd, x, dymin) + start = true + } else if (! finish) { + call gadraw (gd, x, dymin) + finish = true + } + } + x = (dymax - bzero) / bscale + if (x >= xmin && x <= xmax) { + if (! start) { + call gamove (gd, x, dymax) + start = true + } else if (! finish) { + call gadraw (gd, x, dymax) + finish = true + } + } + } + + call sfree (sp) + + return (OK) +end + + +# RG_RIRPLOT -- Plot the pixel to pixel fit residuals for a region. + +int procedure rg_rirplot (gd, imr, im1, ls, udelete, region) + +pointer gd #I pointer to the graphics stream +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I pointer to the user deletions array +int region #I the current region + +int npts +pointer rbuf, ibuf, sp, title, str, imager, image1, resid +real xmin, xmax, ymin, ymax, diff, bscale, bzero, datamin, datamax +real loreject, hireject, chi +int rg_lstati(), rg_limget() +pointer rg_lstatp() +real rg_lstatr() + +begin + # Get the data. + if (imr == NULL || im1 == NULL) { + return (ERR) + } else if (region == rg_lstati (ls,CNREGION) && + rg_lstatp (ls,RBUF) != NULL && rg_lstatp(ls, IBUF) != NULL) { + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + } else if (rg_limget (ls, imr, im1, region) == OK) { + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + } else { + return (ERR) + } + + # Initialize. + call gclear (gd) + + # Get some constants + npts = Memi[rg_lstatp(ls,RNPTS)+region-1] + bscale = Memr[rg_lstatp(ls,RBSCALE)+region-1] + bzero = Memr[rg_lstatp(ls,RBZERO)+region-1] + chi = Memr[rg_lstatp(ls,RCHI)+region-1] + if (IS_INDEFR(rg_lstatr(ls,DATAMIN))) + datamin = -MAX_REAL + else + datamin = rg_lstatr (ls,DATAMIN) + if (IS_INDEFR(rg_lstatr(ls,DATAMAX))) + datamax = MAX_REAL + else + datamax = rg_lstatr (ls,DATAMAX) + if (rg_lstati(ls,NREJECT) <= 0 || IS_INDEFR(rg_lstatr(ls,LOREJECT)) || + IS_INDEFR(chi)) + loreject = -MAX_REAL + else + loreject = -rg_lstatr (ls,LOREJECT) * chi + if (rg_lstati(ls,NREJECT) <= 0 || IS_INDEFR(rg_lstatr(ls,HIREJECT)) || + IS_INDEFR(chi)) + hireject = MAX_REAL + else + hireject = rg_lstatr (ls,HIREJECT) * chi + + # Allocate working space. + call smark (sp) + + # Compute the residuals. + call salloc (resid, npts, TY_REAL) + if (IS_INDEFR(bscale) || IS_INDEFR(bzero)) + call amovkr (INDEFR, Memr[resid], npts) + else { + call altmr (Memr[ibuf], Memr[resid], npts, bscale, bzero) + call asubr (Memr[rbuf], Memr[resid], Memr[resid], npts) + } + + # Compute the plot limits. + call alimr (Memr[ibuf], npts, xmin, xmax) + call alimr (Memr[resid], npts, ymin, ymax) + diff = xmax - xmin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (xmin + xmax) / 2.0) + xmin = xmin - diff * FRACTION + xmax = xmax + diff * FRACTION + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (ymin + ymax) / 2.0) + ymin = ymin - diff * FRACTION + ymax = ymax + diff * FRACTION + call gswind (gd, xmin, xmax, ymin, ymax) + + # Create the plot title. + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + + # Create the plot title. + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + call rg_lstats (ls, IMAGE, Memc[image1], SZ_FNAME) + call sprintf (Memc[str], SZ_LINE, + "Region %d%s: Ref Image = %g * Input Image + %g") + call pargi (region) + if (udelete[region] == YES) + call pargstr (" [deleted]") + else if (Memi[rg_lstatp(ls,RDELETE)+region-1] != LS_NO) + call pargstr (" [rejected]") + else + call pargstr ("") + call pargr (bscale) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, + "Residuals for Image %s versus Counts for Image %s\n%s\n\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Image Counts", + "Ref image Counts") + + # Plot the data. + call rg_rriplot (gd, Memr[ibuf], Memr[rbuf], Memr[resid], npts, + datamin, datamax, loreject, hireject, GM_BOX, GM_CROSS) + + # Plot the 0 line if bscale and bzero are defined. + if ( ! IS_INDEFR(bscale) && ! IS_INDEFR(bzero)) { + call gamove (gd, xmin, 0.0) + call gadraw (gd, xmax, 0.0) + } + + call sfree (sp) + + return (OK) +end + + +# RG_BZFPLOT -- Plot the bscale and bzero values computed from the +# fit algorithm. + +int procedure rg_bzfplot (gd, ls, udelete, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deletions array +real bscale #I the fitted bscale value +real bzero #I the fitted bzero value + +int i, nregions +pointer sp, xreg, title, str, imager, image1 +real xmin, xmax, ymin, ymax, diff +int rg_lstati() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (ERR) + + # Allocate working space. + call smark (sp) + + # Set up space and info the plot title. + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + if (rg_lstati(ls,BSALGORITHM) == LS_PHOTOMETRY || + rg_lstati(ls,BZALGORITHM) == LS_PHOTOMETRY) + call rg_lstats (ls, PHOTFILE, Memc[image1], SZ_FNAME) + else + call rg_lstats (ls, IMAGE, Memc[image1], SZ_FNAME) + + # Set the x array. + call salloc (xreg, nregions, TY_REAL) + do i = 1, nregions + Memr[xreg+i-1] = i + xmin = 1.0 - FRACTION * (nregions - 1) + xmax = nregions + FRACTION * (nregions - 1) + + call gclear (gd) + + # Determine the limits of bscale versus region. + call alimr (Memr[rg_lstatp(ls,RBSCALE)], nregions, ymin, ymax) + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (ymax + ymin) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 1) + call gsview (gd, 0.15, 0.9, 0.6, 0.9) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bscale versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference: %s Input: %s Bscale: %g") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargr (bscale) + call sprintf (Memc[title], 2 * SZ_LINE, + "Bscale vs. Region\n%s\n") + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Region", "Bscale") + + # Plot the points. + call rg_lxyplot (gd, Memr[xreg], Memr[rg_lstatp(ls,RBSCALE)], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + call gamove (gd, xmin, bscale) + call gadraw (gd, xmax, bscale) + + # Determine the limits of bzero versus region. + call alimr (Memr[rg_lstatp(ls,RBZERO)], nregions, ymin, ymax) + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (ymin + ymax) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 2) + call gsview (gd, 0.15, 0.9, 0.1, 0.4) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bzero versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference: %s Input: %s Bzero: %g") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, "Bzero vs. Region\n%s\n") + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Region", "Bzero") + + # Plot the points. + call rg_lxyplot (gd, Memr[xreg], Memr[rg_lstatp(ls,RBZERO)], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + call gamove (gd, xmin, bzero) + call gadraw (gd, xmax, bzero) + + call sfree (sp) + + return (OK) +end + + +# RG_BZRPLOT -- Plot the bscale and bzero values computed from the +# fit algorithm. + +int procedure rg_bzrplot (gd, ls, udelete, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deletions array +real bscale #I the fitted bscale value +real bzero #I the fitted bzero value + +int i, nregions +pointer sp, xreg, yreg, title, str, imager, image1 +real xmin, xmax, ymin, ymax, diff +int rg_lstati() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (ERR) + + # Allocate working space. + call smark (sp) + call salloc (xreg, nregions, TY_REAL) + call salloc (yreg, nregions, TY_REAL) + + # Set up space and info the plot title. + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + if (rg_lstati(ls,BSALGORITHM) == LS_PHOTOMETRY || + rg_lstati(ls,BZALGORITHM) == LS_PHOTOMETRY) + call rg_lstats (ls, PHOTFILE, Memc[image1], SZ_FNAME) + else + call rg_lstats (ls, IMAGE, Memc[image1], SZ_FNAME) + + # Set the x array. + do i = 1, nregions + Memr[xreg+i-1] = i + xmin = 1.0 - FRACTION * (nregions - 1) + xmax = nregions + FRACTION * (nregions - 1) + + call gclear (gd) + + # Determine the limits of the bscale value versus region. + call asubkr (Memr[rg_lstatp(ls,RBSCALE)], bscale, Memr[yreg], nregions) + call alimr (Memr[yreg], nregions, ymin, ymax) + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (ymax + ymin) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 1) + call gsview (gd, 0.15, 0.9, 0.6, 0.9) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bscale versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference: %s Input: %s Bscale: %g") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargr (bscale) + call sprintf (Memc[title], 2 * SZ_LINE, + "Bscale Residuals vs. Region\n%s\n") + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Region", "Bscale Residuals") + + # Plot the points. + call rg_lxyplot (gd, Memr[xreg], Memr[yreg], Memi[rg_lstatp(ls, + RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + call gamove (gd, xmin, 0.0) + call gadraw (gd, xmax, 0.0) + + # Determine the limits of the bscale value versus region. + call asubkr (Memr[rg_lstatp(ls,RBZERO)], bzero, Memr[yreg], nregions) + call alimr (Memr[yreg], nregions, ymin, ymax) + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (ymax + ymin) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 2) + call gsview (gd, 0.15, 0.9, 0.1, 0.4) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bzero versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference: %s Input: %s Bzero: %g") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, + "Bzero Residuals vs. Region\n%s\n") + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Region", "Bzero Residuals") + + # Plot the points. + call rg_lxyplot (gd, Memr[xreg], Memr[yreg], Memi[rg_lstatp(ls, + RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + call gamove (gd, xmin, 0.0) + call gadraw (gd, xmax, 0.0) + + call sfree (sp) + + return (OK) +end + + +# RG_MSFPLOT -- Plot the magnitude and sky values of the regions. + +int procedure rg_msfplot (gd, ls, udelete, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deletions array +real bscale #I the fitted bscale value +real bzero #I the fitted bzero value + +bool start, finish +int nregions +pointer sp, title, str, imager, image1 +real xmin, xmax, ymin, ymax, diff, dxmin, dxmax, dymin, dymax, x, y +int rg_lstati() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 0) + return (ERR) + + # Allocate working space. + call smark (sp) + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + call rg_lstats (ls, PHOTFILE, Memc[image1], SZ_FNAME) + + call gclear (gd) + + # Determine the limits of the bscale value versus region. + call alimr (Memr[rg_lstatp(ls,IMAG)], nregions, xmin, xmax) + dxmin = xmin + dxmax = xmax + diff = xmax - xmin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (xmax + xmin) / 2.0) + xmin = xmin - FRACTION * diff + xmax = xmax + FRACTION * diff + call alimr (Memr[rg_lstatp(ls,RMAG)], nregions, ymin, ymax) + dymin = ymin + dymax = ymax + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (ymax + ymin) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 1) + call gsview (gd, 0.15, 0.9, 0.6, 0.9) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bscale versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference magnitudes = Input magnitudes + %0.3f") + call pargr (-2.5 * log10 (bscale)) + call sprintf (Memc[title], 2 * SZ_LINE, + "Magnitudes for %s vs. Magnitudes for %s\n%s\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Magnitudes", + "Ref Magnitudes") + + # Plot the points. + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMAG)], Memr[rg_lstatp(ls,RMAG)], + Memi[rg_lstatp(ls, RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + if (bscale > 0.0) { + call gamove (gd, dxmin, dxmin - 2.5 * log10(bscale)) + call gadraw (gd, dxmax, dxmax - 2.5 * log10(bscale)) + } + + # Determine the limits of the bscale value versus region. + call alimr (Memr[rg_lstatp(ls,ISKY)], nregions, xmin, xmax) + dxmin = xmin + dxmax = xmax + diff = xmax - xmin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (xmax + xmin) / 2.0) + xmin = xmin - FRACTION * diff + xmax = xmax + FRACTION * diff + call alimr (Memr[rg_lstatp(ls,RSKY)], nregions, ymin, ymax) + dymin = ymin + dymax = ymax + diff = ymax - ymin + if (diff <= 0.0) + diff = 0.0 + else + diff = max (diff, MINFRACTION * (ymax + ymin) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 2) + call gsview (gd, 0.15, 0.9, 0.1, 0.4) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bscale versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference skies = %g * Input skies + %g") + call pargr (bscale) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, + "Sky Values for %s vs. Sky Values for %s\n%s\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Sky Values", + "Ref Sky Values") + + # Plot the points. + call rg_lxyplot (gd, Memr[rg_lstatp(ls,ISKY)], Memr[rg_lstatp(ls,RSKY)], + Memi[rg_lstatp(ls, RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + start = false + finish = false + if (! IS_INDEFR(bscale) && ! IS_INDEFR(bzero)) { + y = bscale * dxmin + bzero + if (y >= ymin && y <= ymax) { + call gamove (gd, dxmin, y) + start = true + } + y = bscale * dxmax + bzero + if (y >= ymin && y <= ymax) { + if (start) { + call gadraw (gd, dxmax, y) + finish = true + } else { + call gamove (gd, dxmax, y) + start = true + } + } + x = (dymin - bzero) / bscale + if (x >= xmin && x <= xmax) { + if (! start) { + call gamove (gd, x, dymin) + start = true + } else if (! finish) { + call gadraw (gd, x, dymin) + finish = true + } + } + x = (dymax - bzero) / bscale + if (x >= xmin && x <= xmax) { + if (! start) { + call gamove (gd, x, dymax) + start = true + } else if (! finish) { + call gadraw (gd, x, dymax) + finish = true + } + } + } + + call sfree (sp) + + return (OK) +end + + +# RG_MSRPLOT -- Plot the magnitude and sky values of the regions. + +int procedure rg_msrplot (gd, ls, udelete, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deletions array +real bscale #I the fitted bscale value +real bzero #I the fitted bzero value + +int nregions +pointer sp, yreg, title, str, imager, image1 +real xmin, xmax, ymin, ymax, diff, dmin, dmax +int rg_lstati() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 0) + return (ERR) + + # Allocate working space. + call smark (sp) + call salloc (yreg, nregions, TY_REAL) + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + call rg_lstats (ls, PHOTFILE, Memc[image1], SZ_FNAME) + + call gclear (gd) + + # Determine the limits of the bscale value versus region. + call alimr (Memr[rg_lstatp(ls,IMAG)], nregions, xmin, xmax) + diff = xmax - xmin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (xmax + xmin) / 2.0) + dmin = xmin + dmax = xmax + xmin = xmin - FRACTION * diff + xmax = xmax + FRACTION * diff + if (bscale > 0) { + call aaddkr (Memr[rg_lstatp(ls,IMAG)], -2.5*log10(bscale), + Memr[yreg], nregions) + call asubr (Memr[rg_lstatp(ls,RMAG)], Memr[yreg], Memr[yreg], + nregions) + } else + call asubr (Memr[rg_lstatp(ls,RMAG)], Memr[rg_lstatp(ls,IMAG)], + Memr[yreg], nregions) + call alimr (Memr[yreg], nregions, ymin, ymax) + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (ymax + ymin) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 1) + call gsview (gd, 0.15, 0.9, 0.6, 0.9) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bscale versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference: %s Input: %s Bscale: %g") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargr (bscale) + call sprintf (Memc[title], 2 * SZ_LINE, + "Residuals for %s vs. Magnitudes for %s\n%s\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Magnitudes", + "Mag Residuals") + + # Plot the points. + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMAG)], Memr[yreg], + Memi[rg_lstatp(ls, RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + if (bscale > 0.0) { + call gamove (gd, xmin, 0.0) + call gadraw (gd, xmax, 0.0) + } + + # Determine the limits of the bscale value versus region. + call alimr (Memr[rg_lstatp(ls,ISKY)], nregions, xmin, xmax) + diff = xmax - xmin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (xmax + xmin) / 2.0) + dmin = xmin + dmax = xmax + xmin = xmin - FRACTION * diff + xmax = xmax + FRACTION * diff + call altmr (Memr[rg_lstatp(ls,ISKY)], Memr[yreg], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RSKY)], Memr[yreg], Memr[yreg], + nregions) + call alimr (Memr[yreg], nregions, ymin, ymax) + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (ymax + ymin) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 2) + call gsview (gd, 0.15, 0.9, 0.1, 0.4) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bscale versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference: %s Input: %s Bscale: %g Bzero: %g") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargr (bscale) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, + "Residuals for %s vs. Sky Values for %s\n%s\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Sky Values", + "Sky Residuals") + + # Plot the points. + call rg_lxyplot (gd, Memr[rg_lstatp(ls,ISKY)], Memr[yreg], + Memi[rg_lstatp(ls, RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + call gamove (gd, xmin, 0.0) + call gadraw (gd, xmax, 0.0) + + call sfree (sp) + + return (OK) +end + + +# RG_LHBOX -- Draw a stepped curve of the histogram data. + +procedure rg_lhbox (gp, ydata, npts, x1, x2) + +pointer gp #I the graphics descriptor +real ydata[ARB] #I the y coordinates of the line endpoints +int npts #I the number of line endpoints +real x1, x2 #I starting and ending x coordinates + +int pixel +real left, right, top, bottom, x, y, dx + +begin + call ggwind (gp, left, right, bottom, top) + dx = (x2 - x1) / npts + + # Do the first vertical line. + call gamove (gp, x1, bottom) + call gadraw (gp, x1, ydata[1]) + + # Do the first horizontal line. + call gadraw (gp, x1 + dx, ydata[1]) + + # Draw the remaining horizontal lines. + do pixel = 2, npts { + x = x1 + dx * (pixel - 1) + y = ydata[pixel] + call gadraw (gp, x, y) + call gadraw (gp, x + dx, y) + } + + # Draw the last vertical line. + call gadraw (gp, x + dx, bottom) +end + + +# RG_PFILL -- Fill a rectangular area with a given style and color. + +procedure rg_pfill (gd, xmin, xmax, ymin, ymax, fstyle, fcolor) + +pointer gd #I pointer to the graphics stream +real xmin, xmax #I the x coordinate limits +real ymin, ymax #I the y coordinate limits +int fstyle #I the fill style +int fcolor #I the fill color + +real x[4], y[4] + +begin + call gseti (gd, G_FACOLOR, fcolor) + x[1] = xmin; y[1] = ymin + x[2] = xmax; y[2] = ymin + x[3] = xmax; y[3] = ymax + x[4] = xmin; y[4] = ymax + call gfill (gd, x, y, 4, fstyle) +end + + +# XP_LXYPLOT -- Plot the x and y points. + +procedure rg_lxyplot (gd, x, y, del, udel, npts, gmarker, dmarker) + +pointer gd # pointer to the graphics stream +real x[ARB] # the x coordinates +real y[ARB] # the y coordinates +int del[ARB] # the deletions array +int udel[ARB] # the user deletions array +int npts # the number of points to be marked +int gmarker # the good point marker type +int dmarker # the deleted point marker type + +int i + +begin + # Plot the points. + do i = 1, npts { + if (udel[i] == YES) { + call gmark (gd, x[i], y[i], gmarker, 2.0, 2.0) + call gmark (gd, x[i], y[i], dmarker, 2.0, 2.0) + } else if (del[i] != LS_NO) + call gmark (gd, x[i], y[i], dmarker, 2.0, 2.0) + else + call gmark (gd, x[i], y[i], gmarker, 2.0, 2.0) + } +end + + +# XP_RIPLOT -- Plot the reference image intensity versus the input image +# intensity. + +procedure rg_riplot (gd, x, y, resid, npts, datamin, datamax, loreject, + hireject, gmarker, dmarker) + +pointer gd #I pointer to the graphics stream +real x[ARB] #I the x coordinates +real y[ARB] #I the y coordinates +real resid[ARB] #I the residuals array +int npts #I the number of points to be marked +real datamin #I the good data minimum +real datamax #I the good data maximum +real loreject #I the low side rejection limit +real hireject #I the high side rejection limit +int gmarker #I the good point marker type +int dmarker #I the deleted point marker type + +int i + +begin + do i = 1, npts { + if (x[i] < datamin || x[i] > datamax) + call gmark (gd, x[i], y[i], dmarker, 2.0, 2.0) + else if (y[i] < datamin || y[i] > datamax) + call gmark (gd, x[i], y[i], dmarker, 2.0, 2.0) + else if (resid[i] < loreject || resid[i] > hireject) + call gmark (gd, x[i], y[i], dmarker, 2.0, 2.0) + else + call gmark (gd, x[i], y[i], gmarker, 2.0, 2.0) + } +end + + +# XP_RRIPLOT -- Plot the reference image intensity versus the input image +# intensity. + +procedure rg_rriplot (gd, x, y, resid, npts, datamin, datamax, loreject, + hireject, gmarker, dmarker) + +pointer gd #I pointer to the graphics stream +real x[ARB] #I the x coordinates +real y[ARB] #I the y coordinates +real resid[ARB] #I the residuals array +int npts #I the number of points to be marked +real datamin #I the good data minimum +real datamax #I the good data maximum +real loreject #I the low side rejection limit +real hireject #I the high side rejection limit +int gmarker #I the good point marker type +int dmarker #I the deleted point marker type + +int i + +begin + do i = 1, npts { + if (x[i] < datamin || x[i] > datamax) + call gmark (gd, x[i], resid[i], dmarker, 2.0, 2.0) + else if (y[i] < datamin || y[i] > datamax) + call gmark (gd, x[i], resid[i], dmarker, 2.0, 2.0) + else if (IS_INDEFR(resid[i])) + call gmark (gd, x[i], resid[i], dmarker, 2.0, 2.0) + else if (resid[i] < loreject || resid[i] > hireject) + call gmark (gd, x[i], resid[i], dmarker, 2.0, 2.0) + else + call gmark (gd, x[i], resid[i], gmarker, 2.0, 2.0) + } +end + + +# RG_GALIMR -- Compute the good data limits for the plot. + +procedure rg_galimr (a, index, npts, amin, amax) + +real a[ARB] #I the input array +int index[ARB] #I the index array +int npts #I the size of the array +real amin, amax #O the output min and max values + +int i +real dmin, dmax, gmin, gmax + +begin + dmin = a[1]; dmax = a[1] + gmin = MAX_REAL; gmax = -MAX_REAL + + do i = 1, npts { + if (a[i] < dmin) + dmin = a[i] + else if (a[i] > dmax) + dmax = a[i] + if (index[i] == LS_NO) { + if (a[i] < gmin) + gmin = a[i] + if (a[i] > gmax) + gmax = a[i] + } + } + + if (gmin == MAX_REAL) + amin = dmin + else + amin = gmin + if (gmax == -MAX_REAL) + amax = dmax + else + amax = gmax +end diff --git a/pkg/images/immatch/src/linmatch/rglregions.x b/pkg/images/immatch/src/linmatch/rglregions.x new file mode 100644 index 00000000..16f01b15 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rglregions.x @@ -0,0 +1,1084 @@ +include <ctype.h> +include <fset.h> +include <imhdr.h> +include "linmatch.h" + +# RG_LREGIONS -- Decode the input regions description. If the regions string +# is NULL then the regions list is empty. The regions are specified in section +# notation, grid notation, coordinate notation or are read +# from a file. + +int procedure rg_lregions (list, im, ls, rp, reread) + +int list #I pointer to the regions file list +pointer im #I pointer to the reference image +pointer ls #I pointer to the linscale structure +int rp #I region pointer +int reread #I reread the current file + +char fname[SZ_FNAME] +int max_nregions, nregions, fd +pointer sp, regions +int rg_lstati(), rg_lgrid(), rg_lgregions(), rg_lsregions() +int rg_lrsections(), rg_lrcoords(), fntgfnb(), open() +data fname[1] /EOS/ +errchk fntgfnb(), seek(), open(), close() + +begin + call smark (sp) + call salloc (regions, SZ_LINE, TY_CHAR) + + call rg_lstats (ls, REGIONS, Memc[regions], SZ_LINE) + max_nregions = rg_lstati (ls, MAXNREGIONS) + + if (rp < 1 || rp > max_nregions || Memc[regions] == EOS) { + nregions = 0 + } else if (rg_lgrid (im, ls, rp, max_nregions) > 0) { + nregions = rg_lstati (ls, NREGIONS) + } else if (rg_lgregions (im, ls, rp, max_nregions) > 0) { + nregions = rg_lstati (ls, NREGIONS) + } else if (rg_lsregions (im, ls, rp, max_nregions) > 0) { + nregions = rg_lstati (ls, NREGIONS) + } else if (list != NULL) { + if (reread == NO) { + iferr { + if (fntgfnb (list, fname, SZ_FNAME) != EOF) { + fd = open (fname, READ_ONLY, TEXT_FILE) + nregions= rg_lrsections (fd, im, ls, rp, max_nregions) + if (nregions <= 0) { + call seek (fd, BOF) + nregions= rg_lrcoords (fd, im, ls, rp, max_nregions) + } + call close (fd) + } else + nregions = 0 + } then + nregions = 0 + } else if (fname[1] != EOS) { + iferr { + fd = open (fname, READ_ONLY, TEXT_FILE) + nregions= rg_lrsections (fd, im, ls, rp, max_nregions) + if (nregions <= 0) { + call seek (fd, BOF) + nregions= rg_lrcoords (fd, im, ls, rp, max_nregions) + } + call close (fd) + } then + nregions = 0 + } + } else + nregions = 0 + + call sfree (sp) + + return (nregions) +end + + +# RG_LGRID - Decode the regions from a grid specification. + +int procedure rg_lgrid (im, ls, rp, max_nregions) + +pointer im #I pointer to the reference image +pointer ls #I pointer to the linscale structure +int rp #I index of the current region +int max_nregions #I the maximum number of regions + +int i, istart, iend, j, jstart, jend, ncols, nlines, nxsample, nysample +int nxcols, nylines, nregions +pointer sp, region, section +int rg_lstati(), nscan(), strcmp() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_lrealloc (ls, max_nregions) + + # Initialize. + call rg_lstats (ls, REGIONS, Memc[region], SZ_LINE) + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + nregions = min (rp - 1, rg_lstati (ls, NREGIONS)) + + # Decode the grid specification. + call sscan (Memc[region]) + call gargwrd (Memc[section], SZ_LINE) + call gargi (nxsample) + call gargi (nysample) + if ((nscan() != 3) || (strcmp (Memc[section], "grid") != 0)) { + call sfree (sp) + return (nregions) + } + + # Decode the regions. + if ((nxsample * nysample) > max_nregions) { + nxsample = nint (sqrt (real (max_nregions) * real (ncols) / + real (nlines))) + nysample = real (max_nregions) / real (nxsample) + } + nxcols = ncols / nxsample + nylines = nlines / nysample + jstart = 1 + (nlines - nysample * nylines) / 2 + jend = jstart + (nysample - 1) * nylines + do j = jstart, jend, nylines { + istart = 1 + (ncols - nxsample * nxcols) / 2 + iend = istart + (nxsample - 1) * nxcols + do i = istart, iend, nxcols { + Memi[rg_lstatp(ls,RC1)+nregions] = i + Memi[rg_lstatp(ls,RC2)+nregions] = i + nxcols - 1 + Memi[rg_lstatp(ls,RL1)+nregions] = j + Memi[rg_lstatp(ls,RL2)+nregions] = j + nylines - 1 + Memi[rg_lstatp(ls,RXSTEP)+nregions] = 1 + Memi[rg_lstatp(ls,RYSTEP)+nregions] = 1 + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = nregions + 1 + } + } + + call rg_lseti (ls, NREGIONS, nregions) + if (nregions > 0) + call rg_lrealloc (ls, nregions) + else + call rg_lrfree (ls) + call sfree (sp) + + return (nregions) +end + + +# RG_LGREGIONS -- Compute the column and line limits givenan x and y +# coordinate and a default size. + +int procedure rg_lgregions (im, ls, rp, max_nregions) + +pointer im #I pointer to the image +pointer ls #I pointer to the linscale structure +int rp #I pointer to the current region +int max_nregions #I maximum number of regions + +char comma +int ncols, nlines, nregions, onscan() +int x1, x2, y1, y2 +pointer sp, region +real x, y, xc, yc +int rg_lstati(), nscan() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information. + call rg_lrealloc (ls, max_nregions) + + # Get the constants. + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + # Decode the center. + call rg_lstats (ls, REGIONS, Memc[region], SZ_LINE) + nregions = min (rp - 1, rg_lstati (ls, NREGIONS)) + onscan = 0 + call sscan (Memc[region]) + call gargr (x) + call gargr (y) + call gargc (comma) + + # Compute the data region. + while ((nscan() == onscan + 3) && (nregions < max_nregions)) { + + # Check for the comma. + if (comma != ',') + break + + # Compute a more accurate center. + #if (rg_lstati (ls, CENTER) == YES) { + #call rg_lcntr (im, x, y, DEF_CRADIUS, xc, yc) + #} else { + xc = x + yc = y + #} + + # Compute the data section. + x1 = xc - rg_lstati (ls, DNX) / 2 + x2 = x1 + rg_lstati (ls, DNX) - 1 + if (IM_NDIM(im) == 1) { + y1 = 1 + y2 = 1 + } else { + y1 = yc - rg_lstati (ls, DNY) / 2 + y2 = y1 + rg_lstati (ls, DNY) - 1 + } + + # Make sure that the region is on the image. + if (x1 >= 1 && x2 <= IM_LEN(im,1) && y1 >= 1 && + y2 <= IM_LEN(im,2)) { + Memi[rg_lstatp(ls,RC1)+nregions] = x1 + Memi[rg_lstatp(ls,RC2)+nregions] = x2 + Memi[rg_lstatp(ls,RL1)+nregions] = y1 + Memi[rg_lstatp(ls,RL2)+nregions] = y2 + Memi[rg_lstatp(ls,RXSTEP)+nregions] = 1 + Memi[rg_lstatp(ls,RYSTEP)+nregions] = 1 + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = nregions + 1 + } + + onscan = nscan() + call gargr (x) + call gargr (y) + call gargc (comma) + } + + # Reallocate the correct amount of space. + call rg_lseti (ls, NREGIONS, nregions) + if (nregions > 0) + call rg_lrealloc (ls, nregions) + else + call rg_lrfree (ls) + + call sfree (sp) + + return (nregions) +end + + +# RG_LMKREGIONS -- Procedure to mark the sections on the image display. +# Sections are marked by pointing the image display cursor to the +# lower left and upper rights corners of the desired sections respectively. + +int procedure rg_lmkregions (fd, im, ls, rp, max_nregions, regions, maxch) + +int fd #I pointer to the output text file +pointer im #I pointer to the image +pointer ls #I pointer to the intensity scaling structure +int rp #I pointer to current region +int max_nregions #I maximum number of regions +char regions[ARB] #O the output regions string +int maxch #I the maximum size of the output string + +int nregions, op, wcs, key +pointer sp, cmd +real xll, yll, xur, yur +int rg_lstati(), clgcur(), gstrcpy() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_lrealloc (ls, max_nregions) + + # Initialize. + nregions = min (rp-1, rg_lstati (ls, NREGIONS)) + op = 1 + regions[1] = EOS + + while (nregions < max_nregions) { + + call printf ("Mark lower left corner of region %d [q to quit].\n") + call pargi (nregions + 1) + if (clgcur ("icommands", xll, yll, wcs, key, Memc[cmd], + SZ_LINE) == EOF) + break + if (key == 'q') + break + + call printf ("Mark upper right corner of region %d [q to quit].\n") + call pargi (nregions + 1) + if (clgcur ("icommands", xur, yur, wcs, key, Memc[cmd], + SZ_LINE) == EOF) + break + if (key == 'q') + break + + # Make sure that the region is on the image. + if (xll < 1.0 || xur > IM_LEN(im,1) || yll < 1.0 || yur > + IM_LEN(im,2)) + next + + Memi[rg_lstatp(ls,RC1)+nregions] = nint(xll) + Memi[rg_lstatp(ls,RC2)+nregions] = nint(xur) + Memi[rg_lstatp(ls,RXSTEP)+nregions] = 1 + Memi[rg_lstatp(ls,RL1)+nregions] = nint(yll) + Memi[rg_lstatp(ls,RL2)+nregions] = nint(yur) + Memi[rg_lstatp(ls,RYSTEP)+nregions] = 1 + + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = nregions + 1 + + # Write the regions string. + call sprintf (Memc[cmd], SZ_LINE, "[%d:%d,%d:%d] ") + call pargi (nint(xll)) + call pargi (nint(xur)) + call pargi (nint(yll)) + call pargi (nint(yur)) + op = op + gstrcpy (Memc[cmd], regions[op], maxch - op + 1) + + # Write the output record. + if (fd != NULL) { + call fprintf (fd, "[%d:%d,%d:%d]\n") + call pargi (nint(xll)) + call pargi (nint(xur)) + call pargi (nint(yll)) + call pargi (nint(yur)) + } + } + call printf ("\n") + + # Reallocate the correct amount of space. + call rg_lsets (ls, REGIONS, regions) + call rg_lseti (ls, NREGIONS, nregions) + + if (nregions > 0) + call rg_lrealloc (ls, nregions) + else + call rg_lrfree (ls) + + call sfree (sp) + + return (nregions) +end + + +# RG_LMKXY -- Create a list of objects by selecting objects with +# the image display cursor. + +int procedure rg_lmkxy (fd, im, ls, rp, max_nregions) + +int fd #I the output coordinates file descriptor +pointer im #I pointer to the image +pointer ls #I pointer to the psf matching structure +int rp #I pointer to current region +int max_nregions #I maximum number of regions + +int nregions, wcs, key, x1, x2, y1, y2 +pointer sp, region, cmd +real xc, yc +int clgcur(), rg_lstati() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_FNAME, TY_CHAR) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_lrealloc (ls, max_nregions) + + nregions = min (rp-1, rg_lstati (ls, NREGIONS)) + while (nregions < max_nregions) { + + # Identify the object. + call printf ("Mark object %d [any key=mark,q=quit]:\n") + call pargi (nregions + 1) + if (clgcur ("icommands", xc, yc, wcs, key, Memc[cmd], + SZ_LINE) == EOF) + break + if (key == 'q') + break + + # Compute the data section. + x1 = xc - rg_lstati (ls, DNX) / 2 + x2 = x1 + rg_lstati (ls, DNX) - 1 + y1 = yc - rg_lstati (ls, DNY) / 2 + y2 = y1 + rg_lstati (ls, DNY) - 1 + + # Make sure that the region is on the image. + if (x1 < 1 || x2 > IM_LEN(im,1) || y1 < 1 || y2 > + IM_LEN(im,2)) + next + + if (fd != NULL) { + call fprintf (fd, "%0.3f %0.3f\n") + call pargr (xc) + call pargr (yc) + } + + Memi[rg_lstatp(ls,RC1)+nregions] = x1 + Memi[rg_lstatp(ls,RC2)+nregions] = x2 + Memi[rg_lstatp(ls,RXSTEP)+nregions] = 1 + Memi[rg_lstatp(ls,RL1)+nregions] = y1 + Memi[rg_lstatp(ls,RL2)+nregions] = y2 + Memi[rg_lstatp(ls,RYSTEP)+nregions] = 1 + + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + + nregions = nregions + 1 + + } + + # Reallocate the correct amount of space. + call rg_lseti (ls, NREGIONS, nregions) + if (nregions > 0) { + call rg_lrealloc (ls, nregions) + if (fd != NULL) { + call fstats (fd, F_FILENAME, Memc[region], SZ_FNAME) + call rg_lsets (ls, REGIONS, Memc[region]) + } else + call rg_lsets (ls, REGIONS, "") + } else { + call rg_lrfree (ls) + call rg_lsets (ls, REGIONS, "") + } + + call sfree (sp) + return (nregions) +end + + +# RG_LRSECTIONS -- Read the sections from a file. + +int procedure rg_lrsections (fd, im, ls, rp, max_nregions) + +int fd #I the regions file descriptor +pointer im #I pointer to the image +pointer ls #I pointer to the linscale structure +int rp #I pointer to current region +int max_nregions #I the maximum number of regions + +int stat, nregions, ncols, nlines, x1, y1, x2, y2, xstep, ystep +pointer sp, section, line +int rg_lstati(), getline(), rg_lgsections() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_lrealloc (ls, max_nregions) + + # Get the constants. + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + # Decode the regions string. + nregions = min (rp - 1, rg_lstati (ls, NREGIONS)) + while (getline (fd, Memc[line]) != EOF && nregions < max_nregions) { + + call sscan (Memc[line]) + call gargwrd (Memc[section], SZ_LINE) + + while (Memc[section] != EOS && nregions < max_nregions) { + stat = rg_lgsections (Memc[section], x1, x2, xstep, y1, y2, + ystep, ncols, nlines) + + # Check for even dimensioned regions. + if (stat == OK) { + if (mod (x2 - x1 + 1, 2) == 2) { + x2 = x2 + 1 + if (x2 > ncols) + x2 = x2 - 2 + if (x2 < 1) + stat = ERR + } + if (mod (y2 - y1 + 1, 2) == 2) { + y2 = y2 + 1 + if (y2 > nlines) + y2 = y2 - 2 + if (y2 < 1) + stat = ERR + } + } else + stat = ERR + + # Add the new region to the list. + if (stat == OK) { + Memi[rg_lstatp(ls,RC1)+nregions] = x1 + Memi[rg_lstatp(ls,RC2)+nregions] = x2 + Memi[rg_lstatp(ls,RL1)+nregions] = y1 + Memi[rg_lstatp(ls,RL2)+nregions] = y2 + Memi[rg_lstatp(ls,RXSTEP)+nregions] = xstep + Memi[rg_lstatp(ls,RYSTEP)+nregions] = ystep + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = nregions + 1 + } + + call gargwrd (Memc[section], SZ_LINE) + } + } + + call rg_lseti (ls, NREGIONS, nregions) + if (nregions > 0) + call rg_lrealloc (ls, nregions) + else + call rg_lrfree (ls) + + call sfree (sp) + return (nregions) +end + + +# RG_LRCOORDS -- Read the coordinates from a file. + +int procedure rg_lrcoords (fd, im, ls, rp, max_nregions) + +int fd #I the regions file descriptor +pointer im #I pointer to the image +pointer ls #I pointer to the linscale structure +int rp #I pointer to current region +int max_nregions #I the maximum number of regions + +int ncols, nlines, nregions, x1, x2, y1, y2 +pointer sp, line +real x, y, xc, yc +int rg_lstati(), getline(), nscan() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_lrealloc (ls, max_nregions) + + # Get the constants. + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + # Decode the regions string. + nregions = min (rp - 1, rg_lstati (ls, NREGIONS)) + while (getline (fd, Memc[line]) != EOF && nregions < max_nregions) { + + call sscan (Memc[line]) + call gargr (x) + call gargr (y) + if (nscan() != 2) + next + + # Compute a more accurate center. + #if (rg_lstati (ls, CENTER) == YES) { + #call rg_lcntr (im, x, y, DEF_CRADIUS, xc, yc) + #} else { + xc = x + yc = y + #} + + # Compute the data section. + x1 = xc - rg_lstati (ls, DNX) / 2 + x2 = x1 + rg_lstati (ls, DNX) - 1 + if (IM_NDIM(im) == 1) { + y1 = 1 + y2 = 1 + } else { + y1 = yc - rg_lstati (ls, DNY) / 2 + y2 = y1 + rg_lstati (ls, DNY) - 1 + } + + # Make sure that the region is on the image. + if (x1 >= 1 && x2 <= IM_LEN(im,1) && y1 >= 1 && y2 <= + IM_LEN(im,2)) { + Memi[rg_lstatp(ls,RC1)+nregions] = x1 + Memi[rg_lstatp(ls,RC2)+nregions] = x2 + Memi[rg_lstatp(ls,RL1)+nregions] = y1 + Memi[rg_lstatp(ls,RL2)+nregions] = y2 + Memi[rg_lstatp(ls,RXSTEP)+nregions] = 1 + Memi[rg_lstatp(ls,RYSTEP)+nregions] = 1 + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = nregions + 1 + } + } + + call rg_lseti (ls, NREGIONS, nregions) + if (nregions > 0) + call rg_lrealloc (ls, nregions) + else + call rg_lrfree (ls) + + call sfree (sp) + return (nregions) +end + + +# RG_LRPHOT -- Read the photometry from a file. + +int procedure rg_lrphot (fd, ls, rp, max_nregions, refimage) + +int fd #I the regions file descriptor +pointer ls #I pointer to the linscale structure +int rp #I pointer to current region +int max_nregions #I the maximum number of regions +int refimage #I is the photometry for the reference image + +int nregions, maxnr +pointer sp, line +real sky, skyerr, mag, magerr +int rg_lstati(), getline(), nscan() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Allocate the space to hold the arrays. + if (refimage == YES) { + call rg_lrealloc (ls, max_nregions) + nregions = min (rp - 1, rg_lstati (ls, NREGIONS)) + maxnr = max_nregions + } else { + nregions = 0 + maxnr = rg_lstati(ls, NREGIONS) + } + + while (getline (fd, Memc[line]) != EOF && nregions < maxnr) { + + call sscan (Memc[line]) + call gargr (sky) + call gargr (skyerr) + call gargr (mag) + call gargr (magerr) + if (nscan() != 4) + next + + Memi[rg_lstatp(ls,RC1)+nregions] = INDEFI + Memi[rg_lstatp(ls,RC2)+nregions] = INDEFI + Memi[rg_lstatp(ls,RL1)+nregions] = INDEFI + Memi[rg_lstatp(ls,RL2)+nregions] = INDEFI + Memi[rg_lstatp(ls,RXSTEP)+nregions] = INDEFI + Memi[rg_lstatp(ls,RYSTEP)+nregions] = INDEFI + + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + if (refimage == YES) { + Memr[rg_lstatp(ls,RSKY)+nregions] = sky + Memr[rg_lstatp(ls,RSKYERR)+nregions] = skyerr + Memr[rg_lstatp(ls,RMAG)+nregions] = mag + Memr[rg_lstatp(ls,RMAGERR)+nregions] = magerr + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + } + + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + if (refimage == NO) { + Memr[rg_lstatp(ls,ISKY)+nregions] = sky + Memr[rg_lstatp(ls,ISKYERR)+nregions] = skyerr + Memr[rg_lstatp(ls,IMAG)+nregions] = mag + Memr[rg_lstatp(ls,IMAGERR)+nregions] = magerr + } + + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = nregions + 1 + } + + if (refimage == YES) { + call rg_lseti (ls, NREGIONS, nregions) + if (nregions > 0) + call rg_lrealloc (ls, nregions) + else + call rg_lrfree (ls) + } else if (nregions < rg_lstati (ls,NREGIONS)) { + call rg_lseti (ls, NREGIONS, nregions) + } + + call sfree (sp) + return (nregions) +end + + +# RG_LSREGIONS -- Procedure to compute the column and line limits given +# an image section. If the section is the null string then the region list +# is empty. + +int procedure rg_lsregions (im, ls, rp, max_nregions) + +pointer im #I pointer to the image +pointer ls #I pointer to the linscale structure +int rp #I pointer to the current region +int max_nregions #I maximum number of regions + +int ncols, nlines, nregions +int x1, x2, y1, y2, xstep, ystep +pointer sp, section, region +int rg_lstati(), rg_lgsections() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + call rg_lstats (ls, REGIONS, Memc[region], SZ_LINE) + + # Allocate the arrays to hold the regions information. + call rg_lrealloc (ls, max_nregions) + + # Get the constants. + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + if (Memc[region] != EOS) { + + call sscan (Memc[region]) + call gargwrd (Memc[section], SZ_LINE) + + nregions = min (rp - 1, rg_lstati (ls, NREGIONS)) + while (Memc[section] != EOS && nregions < max_nregions) { + + # Check for even dimensioned regions. + if (rg_lgsections (Memc[section], x1, x2, xstep, y1, y2, ystep, + ncols, nlines) == OK) { + Memi[rg_lstatp(ls,RC1)+nregions] = x1 + Memi[rg_lstatp(ls,RC2)+nregions] = x2 + Memi[rg_lstatp(ls,RL1)+nregions] = y1 + Memi[rg_lstatp(ls,RL2)+nregions] = y2 + Memi[rg_lstatp(ls,RXSTEP)+nregions] = xstep + Memi[rg_lstatp(ls,RYSTEP)+nregions] = ystep + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = nregions + 1 + } + call gargwrd (Memc[section], SZ_LINE) + } + + } else { + Memi[rg_lstatp(ls,RC1)+nregions] = 1 + Memi[rg_lstatp(ls,RC2)+nregions] = ncols + Memi[rg_lstatp(ls,RL1)+nregions] = 1 + Memi[rg_lstatp(ls,RL2)+nregions] = nlines + Memi[rg_lstatp(ls,RXSTEP)+nregions] = 1 + Memi[rg_lstatp(ls,RYSTEP)+nregions] = 1 + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = 1 + } + + + # Reallocate the correct amount of space. + call rg_lseti (ls, NREGIONS, nregions) + if (nregions > 0) + call rg_lrealloc (ls, nregions) + else + call rg_lrfree (ls) + + call sfree (sp) + return (nregions) +end + + +# RG_LGSECTIONS -- Decode an image section into column and line limits +# and a step size. Sections which describe the whole image are decoded into +# a block ncols * nlines long. + +int procedure rg_lgsections (section, x1, x2, xstep, y1, y2, ystep, ncols, + nlines) + +char section[ARB] #I the input section string +int x1, x2 #O the output column section limits +int xstep #O the output column step size +int y1, y2 #O the output line section limits +int ystep #O the output line step size +int ncols, nlines #I the maximum number of lines and columns + +int ip +int rg_lgdim() + +begin + ip = 1 + if (rg_lgdim (section, ip, x1, x2, xstep, ncols) == ERR) + return (ERR) + if (rg_lgdim (section, ip, y1, y2, ystep, nlines) == ERR) + return (ERR) + + return (OK) +end + + +# RG_LGDIM -- Decode a single subscript expression to produce the +# range of values for that subscript (X1:X2), and the sampling step size, STEP. +# Note that X1 may be less than, greater than, or equal to X2, and STEP may +# be a positive or negative nonzero integer. Various shorthand notations are +# permitted, as is embedded whitespace. + +int procedure rg_lgdim (section, ip, x1, x2, step, limit) + +char section[ARB] #I the input image section +int ip #I/O pointer to the position in section string +int x1 #O first limit of dimension +int x2 #O second limit of dimension +int step #O step size of dimension +int limit #I maximum size of dimension + +int temp +int ctoi() + +begin + x1 = 1 + x2 = limit + step = 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + if (section[ip] =='[') + ip = ip + 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + + # Get X1, X2. + if (ctoi (section, ip, temp) > 0) { # [x1 + x1 = max (1, min (temp, limit)) + if (section[ip] == ':') { + ip = ip + 1 + if (ctoi (section, ip, temp) == 0) # [x1:x2 + return (ERR) + x2 = max (1, min (temp, limit)) + } else + x2 = x1 + + } else if (section[ip] == '-') { + x1 = limit + x2 = 1 + ip = ip + 1 + if (section[ip] == '*') + ip = ip + 1 + + } else if (section[ip] == '*') # [* + ip = ip + 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + # Get sample step size, if give. + if (section[ip] == ':') { # ..:step + ip = ip + 1 + if (ctoi (section, ip, step) == 0) + return (ERR) + else if (step == 0) + return (ERR) + } + + # Allow notation such as "-*:5", (or even "-:5") where the step + # is obviously supposed to be negative. + + if (x1 > x2 && step > 0) + step = -step + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + if (section[ip] == ',') { + ip = ip + 1 + return (OK) + } else if (section[ip] == ']') + return (OK) + else + return (ERR) +end + + + diff --git a/pkg/images/immatch/src/linmatch/rglscale.x b/pkg/images/immatch/src/linmatch/rglscale.x new file mode 100644 index 00000000..480455ea --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rglscale.x @@ -0,0 +1,1337 @@ +include <imhdr.h> +include <mach.h> +include "linmatch.h" +include "lsqfit.h" + +# RG_LSCALE -- Compute the scaling parameters required to match the +# intensities of an image to a reference image. + +int procedure rg_lscale (imr, im1, db, dformat, ls) + +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer db #I pointer to the database file +int dformat #I write the output file in database format +pointer ls #I pointer to the linscale structure + +pointer sp, image, imname +real bscale, bzero, bserr, bzerr +bool streq() +int rg_lstati(), fscan(), nscan() + +#int i, nregions +#int rg_isfit () +#pointer rg_istatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call rg_lstats (ls, IMAGE, Memc[image], SZ_FNAME) + + # Initialize. + bscale = 1.0 + bzero = 0.0 + + # Compute the average bscale and bzero for the image either by + # reading it from a file or by computing it directly from the + # data. + + if (rg_lstati(ls, BZALGORITHM) == LS_FILE && rg_lstati (ls, + BSALGORITHM) == LS_FILE) { + + # Read the results of a previous run from the database file or + # a simple text file. + if (dformat == YES) { + call rg_lfile (db, ls, bscale, bzero, bserr, bzerr) + } else { + if (fscan(db) != EOF) { + call gargwrd (Memc[imname], SZ_FNAME) + call gargr (bscale) + call gargr (bzero) + call gargr (bserr) + call gargr (bzerr) + if (! streq (Memc[image], Memc[imname]) || nscan() != 5) { + bscale = 1.0 + bzero = 0.0 + bserr = INDEFR + bzerr = INDEFR + } + } else { + bscale = 1.0 + bzero = 0.0 + bserr = INDEFR + bzerr = INDEFR + } + } + + # Store the values. + call rg_lsetr (ls, TBSCALE, bscale) + call rg_lsetr (ls, TBZERO, bzero) + call rg_lsetr (ls, TBSCALEERR, bserr) + call rg_lsetr (ls, TBZEROERR, bzerr) + + } else { + + # Write out the algorithm parameters. + if (dformat == YES) + call rg_ldbparams (db, ls) + + # Compute the individual scaling factors and their errors for + # all the regions and the average scaling factors and their + # errors. + call rg_scale (imr, im1, ls, bscale, bzero, bserr, bzerr, YES) + + # Write out the results for the individual regions. + if (dformat == YES) + call rg_lwreg (db, ls) + + # Write out the final scaling factors + if (dformat == YES) + call rg_ldbtscale (db, ls) + else { + call fprintf (db, "%s %g %g %g %g\n") + call pargstr (Memc[image]) + call pargr (bscale) + call pargr (bzero) + call pargr (bserr) + call pargr (bzerr) + } + } + + call sfree (sp) + + return (NO) +end + + +# RG_SCALE -- Compute the scaling parameters for a list of regions. + +procedure rg_scale (imr, im1, ls, tbscale, tbzero, tbserr, tbzerr, refit) + +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer ls #I pointer to the intensity matching structure +real tbscale #O the average scaling parameter +real tbzero #O the average offset parameter +real tbserr #O the average error in the scaling parameter +real tbzerr #O the average error in the offset parameter +int refit #I recompute entire fit, otherwise recompute averages + +int i, nregions, ngood +double sumbscale, sumbzero, sumwbscale, sumbserr, sumbzerr, sumwbzero, dw +real bscale, bzero, bserr, bzerr, avbscale, avbzero, avbserr, avbzerr +int rg_lstati(), rg_limget(), rg_lbszfit() +pointer rg_lstatp() +real rg_lstatr() + +begin + # Determine the number of regions. + nregions = rg_lstati (ls, NREGIONS) + + # Initialize the statistics + sumbscale = 0.0d0 + sumbserr = 0.0d0 + sumwbscale = 0.0d0 + sumbzero = 0.0d0 + sumbzerr = 0.0d0 + sumwbzero = 0.0d0 + ngood = 0 + + # Loop over the regions. + do i = 1, nregions { + + if (refit == YES) { + + # Set the current region. + call rg_lseti (ls, CNREGION, i) + + # Fetch the data for the given region and estimate the mean, + # median, mode, standard deviation, and number of points in + # each region, if this is required by the algorithm. + if (imr != NULL) { + if (rg_limget (ls, imr, im1, i) == ERR) { + call rg_lgmmm (ls, i) + next + } else + call rg_lgmmm (ls, i) + } + + # Compute bscale and bzero and store the results in the + # internal arrays + if (rg_lbszfit (ls, i, bscale, bzero, bserr, bzerr) == ERR) + next + + } else { + bscale = Memr[rg_lstatp(ls,RBSCALE)+i-1] + bzero = Memr[rg_lstatp(ls,RBZERO)+i-1] + bserr = Memr[rg_lstatp(ls,RBSCALEERR)+i-1] + bzerr = Memr[rg_lstatp(ls,RBZEROERR)+i-1] + } + + # Accumulate the weighted sums of the scaling factors. + if (Memi[rg_lstatp(ls,RDELETE)+i-1] == LS_NO && + ! IS_INDEFR(bserr) && ! IS_INDEFR(bzerr)) { + + if (bserr <= 0.0) + dw = 1.0d0 + else + dw = 1.0d0 / bserr ** 2 + sumbscale = sumbscale + dw * bscale + sumbserr = sumbserr + dw * bscale * bscale + sumwbscale = sumwbscale + dw + + if (bzerr <= 0.0) + dw = 1.0d0 + else + dw = 1.0d0 / bzerr ** 2 + sumbzero = sumbzero + dw * bzero + sumbzerr = sumbzerr + dw * bzero * bzero + sumwbzero = sumwbzero + dw + + ngood = ngood + 1 + } + } + + # Compute the average scaling factors. + call rg_avstats (sumbscale, sumbzero, sumwbscale, sumwbzero, sumbserr, + sumbzerr, bserr, bserr, avbscale, avbzero, avbserr, avbzerr, ngood) + + # Perform the rejection cycle. + if (ngood > 2 && rg_lstati(ls, NREJECT) > 0 && + (! IS_INDEFR(rg_lstatr(ls,LOREJECT)) || ! IS_INDEFR(rg_lstatr(ls, + HIREJECT)))) { + call rg_ravstats (ls, sumbscale, sumbzero, sumwbscale, sumwbzero, + sumbserr, sumbzerr, bserr, bzerr, avbscale, avbzero, avbserr, + avbzerr, ngood) + } + + # Compute the final scaling factors. + if (ngood > 1) { + call rg_lbszavg (ls, avbscale, avbzero, avbserr, avbzerr, + tbscale, tbzero, tbserr, tbzerr) + } else { + tbscale = avbscale + tbzero = avbzero + tbserr = avbserr + tbzerr = avbzerr + } + + # Store the compute values. + call rg_lsetr (ls, TBSCALE, tbscale) + call rg_lsetr (ls, TBZERO, tbzero) + call rg_lsetr (ls, TBSCALEERR, tbserr) + call rg_lsetr (ls, TBZEROERR, tbzerr) +end + + +# RG_LIMGET -- Fetch the reference and input image data and compute the +# statistics for a given region. + +int procedure rg_limget (ls, imr, im1, i) + +pointer ls #I pointer to the intensity scaling structure +pointer imr #I pointer to reference image +pointer im1 #I pointer to image +int i #I the region id + +int stat, nrimcols, nrimlines, nimcols, nimlines, nrcols, nrlines, ncols +int nlines, rc1, rc2, rl1, rl2, c1, c2, l1, l2, xstep, ystep, npts +pointer sp, str, ibuf, rbuf, prc1, prc2, prxstep, prl1, prl2, prystep +int rg_lstati(), rg_simget() +pointer rg_lstatp() +real rg_lstatr() + +#int c1, c2, l1, l2 +#int ncols, nlines, npts + +define nextregion_ 11 + +begin + stat = OK + + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Delete the data of the previous region if any. + rbuf = rg_lstatp (ls, RBUF) + if (rbuf != NULL) + call mfree (rbuf, TY_REAL) + rbuf = NULL + ibuf = rg_lstatp (ls, IBUF) + if (ibuf != NULL) + call mfree (ibuf, TY_REAL) + ibuf = NULL + + # Check for number of regions. + if (i < 1 || i > rg_lstati (ls, NREGIONS)) { + stat = ERR + goto nextregion_ + } + + # Get the reference and input image sizes. + nrimcols = IM_LEN(imr,1) + if (IM_NDIM(imr) == 1) + nrimlines = 1 + else + nrimlines = IM_LEN(imr,2) + nimcols = IM_LEN(im1,1) + if (IM_NDIM(im1) == 1) + nimlines = 1 + else + nimlines = IM_LEN(im1,2) + + # Get the reference region pointers. + prc1 = rg_lstatp (ls, RC1) + prc2 = rg_lstatp (ls, RC2) + prl1 = rg_lstatp (ls, RL1) + prl2 = rg_lstatp (ls, RL2) + prxstep = rg_lstatp (ls, RXSTEP) + prystep = rg_lstatp (ls, RYSTEP) + + # Get the reference subraster regions. + rc1 = Memi[prc1+i-1] + rc2 = Memi[prc2+i-1] + rl1 = Memi[prl1+i-1] + rl2 = Memi[prl2+i-1] + xstep = Memi[prxstep+i-1] + ystep = Memi[prystep+i-1] + nrcols = (rc2 - rc1) / xstep + 1 + nrlines = (rl2 - rl1) / ystep + 1 + + # Move to the next region if current reference region is off the image. + if (rc1 < 1 || rc1 > nrimcols || rc2 < 1 || rc2 > nrimcols || + rl1 > nrimlines || rl1 < 1 || rl2 < 1 || rl2 > nrimlines) { + call rg_lstats (ls, REFIMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Reference region %d: %s[%d:%d:%d,%d:%d:%d] is off image.\n") + call pargi (i) + call pargstr (Memc[str]) + call pargi (rc1) + call pargi (rc2) + call pargi (xstep) + call pargi (rl1) + call pargi (rl2) + call pargi (ystep) + stat = ERR + goto nextregion_ + } + + # Move to next region if current reference region is too small. + if (nrcols < 3 || (IM_NDIM(imr) == 2 && nrlines < 3)) { + call rg_lstats (ls, REFIMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Reference region %d: %s[%d:%d:%d,%d:%d:%d] has too few points.\n") + call pargi (i) + call pargstr (Memc[str]) + call pargi (rc1) + call pargi (rc2) + call pargi (xstep) + call pargi (rl1) + call pargi (rl2) + call pargi (ystep) + stat = ERR + goto nextregion_ + } + + # Get the reference image data. + npts = rg_simget (imr, rc1, rc2, xstep, rl1, rl2, ystep, rbuf) + if (npts < 9) { + stat = ERR + go to nextregion_ + } + call rg_lsetp (ls, RBUF, rbuf) + Memi[rg_lstatp(ls,RNPTS)+i-1] = npts + + # Get the input image subraster regions. + c1 = rc1 + rg_lstatr (ls, SXSHIFT) + c2 = rc2 + rg_lstatr (ls, SXSHIFT) + l1 = rl1 + rg_lstatr (ls, SYSHIFT) + l2 = rl2 + rg_lstatr (ls, SYSHIFT) + #c1 = max (1, min (nimcols, c1)) + #c2 = min (nimcols, max (1, c2)) + #l1 = max (1, min (nimlines, l1)) + #l2 = min (nimlines, max (1, l2)) + ncols = (c2 - c1) / xstep + 1 + nlines = (l2 - l1) / ystep + 1 + + # Move to the next region if current input region is off the image. + if (c1 < 1 || c1 > nimcols || c2 > nimcols || c2 < 1 || + l1 > nimlines || l1 < 1 || l2 < 1 || l2 > nimlines) { + call rg_lstats (ls, IMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Input region %d: %s[%d:%d:%d,%d:%d:%d] is off image.\n") + call pargi (i) + call pargstr (Memc[str]) + call pargi (c1) + call pargi (c2) + call pargi (xstep) + call pargi (l1) + call pargi (l2) + call pargi (ystep) + stat = ERR + goto nextregion_ + } + + # Move to the next region if current input region is too small. + if (ncols < 3 || (IM_NDIM(im1) == 2 && nlines < 3)) { + call rg_lstats (ls, IMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Input regions %d: %s[%d:%d:%d,%d:%d:%d] has too few points.\n") + call pargi (i) + call pargstr (Memc[str]) + call pargi (c1) + call pargi (c2) + call pargi (xstep) + call pargi (l1) + call pargi (l2) + call pargi (ystep) + stat = ERR + goto nextregion_ + } + + # Get the image data. + npts = rg_simget (im1, c1, c2, xstep, l1, l2, ystep, ibuf) + if (npts < 9) { + stat = ERR + go to nextregion_ + } + call rg_lsetp (ls, IBUF, ibuf) + Memi[rg_lstatp(ls,INPTS)+i-1] = npts + + +nextregion_ + call sfree (sp) + if (stat == ERR) { + call rg_lsetp (ls, RBUF, rbuf) + if (ibuf != NULL) + call mfree (ibuf, TY_REAL) + call rg_lsetp (ls, IBUF, NULL) + call rg_lseti (ls, CNREGION, i) + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADREGION + return (ERR) + } else { + call rg_lsetp (ls, RBUF, rbuf) + call rg_lsetp (ls, IBUF, ibuf) + call rg_lseti (ls, CNREGION, i) + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_NO + return (OK) + } +end + + +# RG_LGMMM -- Compute the mean, median and mode of a data region + +procedure rg_lgmmm (ls, i) + +pointer ls #I pointer to the intensity scaling structure +int i #I the current region + +int npts +pointer rbuf, ibuf, buf +real sigma, dmin, dmax +int rg_lstati() +pointer rg_lstatp() +real rg_lmode(), rg_lstatr() + +begin + # Test that the data buffers exist and contain data. + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + npts = Memi[rg_lstatp (ls, RNPTS)+i-1] + if (rbuf == NULL || npts <= 0) { + Memr[rg_lstatp(ls,RMEAN)+i-1] = 0.0 + Memr[rg_lstatp(ls,RMEDIAN)+i-1] = 0.0 + Memr[rg_lstatp(ls,RMODE)+i-1] = 0.0 + Memr[rg_lstatp(ls,RSIGMA)+i-1] = 0.0 + Memr[rg_lstatp(ls,IMEAN)+i-1] = 0.0 + Memr[rg_lstatp(ls,IMEDIAN)+i-1] = 0.0 + Memr[rg_lstatp(ls,IMODE)+i-1] = 0.0 + Memr[rg_lstatp(ls,ISIGMA)+i-1] = 0.0 + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADREGION + return + } + call malloc (buf, npts, TY_REAL) + + # Compute the mean, median, and mode of the reference region but + # don't recompute the reference region statistics needlessly. + if ((!IS_INDEFR(rg_lstatr(ls,DATAMIN)) || !IS_INDEFR(rg_lstatr(ls, + DATAMAX))) && (rg_lstati(ls,BSALGORITHM) != LS_FIT || + rg_lstati(ls,BZALGORITHM) != LS_FIT)) { + call alimr (Memr[rbuf], npts, dmin, dmax) + if (!IS_INDEFR(rg_lstatr(ls,DATAMIN))) { + if (dmin < rg_lstatr(ls,DATAMIN)) { + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADREGION + call eprintf ( + "Reference region %d contains data < datamin\n") + call pargi (i) + } + } + if (!IS_INDEFR(rg_lstatr(ls,DATAMAX))) { + if (dmax > rg_lstatr(ls,DATAMAX)) { + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADREGION + call eprintf ( + "Reference region %d contains data > datamax\n") + call pargi (i) + } + } + } + call aavgr (Memr[rbuf], npts, Memr[rg_lstatp(ls,RMEAN)+i-1], sigma) + Memr[rg_lstatp(ls,RSIGMA)+i-1] = sigma / sqrt (real(npts)) + call asrtr (Memr[rbuf], Memr[buf], npts) + if (mod (npts,2) == 1) + Memr[rg_lstatp(ls,RMEDIAN)+i-1] = Memr[buf+npts/2] + else + Memr[rg_lstatp(ls,RMEDIAN)+i-1] = (Memr[buf+npts/2-1] + + Memr[buf+npts/2]) / 2.0 + Memr[rg_lstatp(ls,RMODE)+i-1] = rg_lmode (Memr[buf], npts, + LMODE_NMIN, LMODE_ZRANGE, LMODE_ZBIN, LMODE_ZSTEP) + sigma = sqrt ((max (Memr[rg_lstatp(ls,RMEAN)+i-1], 0.0) / + rg_lstatr(ls,RGAIN) + (rg_lstatr(ls,RREADNOISE) / + rg_lstatr (ls,RGAIN)) ** 2) / npts) + Memr[rg_lstatp(ls,RSIGMA)+i-1] = + min (Memr[rg_lstatp(ls,RSIGMA)+i-1], sigma) + + if (ibuf == NULL) { + Memr[rg_lstatp(ls,IMEAN)+i-1] = Memr[rg_lstatp(ls,RMEAN)+i-1] + Memr[rg_lstatp(ls,IMEDIAN)+i-1] = Memr[rg_lstatp(ls,RMEDIAN)+i-1] + Memr[rg_lstatp(ls,IMODE)+i-1] = Memr[rg_lstatp(ls,RMODE)+i-1] + Memr[rg_lstatp(ls,ISIGMA)+i-1] = Memr[rg_lstatp(ls,RSIGMA)+i-1] + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADREGION + call mfree (buf, TY_REAL) + return + } + + # Compute the mean, median, and mode of the input region. + if ((!IS_INDEFR(rg_lstatr(ls,DATAMIN)) || !IS_INDEFR(rg_lstatr(ls, + DATAMAX))) && (rg_lstati(ls,BSALGORITHM) != LS_FIT || + rg_lstati(ls,BZALGORITHM) != LS_FIT)) { + call alimr (Memr[ibuf], npts, dmin, dmax) + if (!IS_INDEFR(rg_lstatr(ls,DATAMIN))) { + if (dmin < rg_lstatr(ls,DATAMIN)) { + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADREGION + call eprintf ("Input region %d contains data < datamin\n") + call pargi (i) + } + } + if (!IS_INDEFR(rg_lstatr(ls,DATAMAX))) { + if (dmax > rg_lstatr(ls,DATAMAX)) { + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADREGION + call eprintf ("Input region %d contains data > datamax\n") + call pargi (i) + } + } + } + call aavgr (Memr[ibuf], npts, Memr[rg_lstatp(ls,IMEAN)+i-1], sigma) + Memr[rg_lstatp(ls,ISIGMA)+i-1] = sigma / sqrt (real(npts)) + call asrtr (Memr[ibuf], Memr[buf], npts) + if (mod (npts,2) == 1) + Memr[rg_lstatp(ls,IMEDIAN)+i-1] = Memr[buf+npts/2] + else + Memr[rg_lstatp(ls,IMEDIAN)+i-1] = (Memr[buf+npts/2-1] + + Memr[buf+npts/2]) / 2.0 + Memr[rg_lstatp(ls,IMODE)+i-1] = rg_lmode (Memr[buf], npts, LMODE_NMIN, + LMODE_ZRANGE, LMODE_ZBIN, LMODE_ZSTEP) + sigma = sqrt ((max (Memr[rg_lstatp(ls,IMEAN)+i-1], 0.0) / + rg_lstatr(ls,IGAIN) + (rg_lstatr(ls,IREADNOISE) / + rg_lstatr (ls,IGAIN)) ** 2) / npts) + Memr[rg_lstatp(ls,ISIGMA)+i-1] = + min (Memr[rg_lstatp(ls,ISIGMA)+i-1], sigma) + + + call mfree (buf, TY_REAL) +end + + +# RG_LBSZFIT -- Compute the bscale and bzero factor for a single region. + +int procedure rg_lbszfit (ls, i, bscale, bzero, bserr, bzerr) + +pointer ls #I pointer to the intensity scaling strucuture +int i #I the number of the current region +real bscale #O the computed bscale factor +real bzero #O the computed bzero factor +real bserr #O the computed error in bscale +real bzerr #O the computed error in bzero + +int stat +real bjunk, chi +bool fp_equalr() +int rg_lstati() +pointer rg_lstatp() +real rg_lstatr() + +begin + stat = OK + + # Compute the bscale factor. + switch (rg_lstati (ls, BSALGORITHM)) { + case LS_NUMBER: + bscale = rg_lstatr (ls, CBSCALE) + bserr = 0.0 + chi = INDEFR + case LS_MEAN: + if (fp_equalr (0.0, Memr[rg_lstatp(ls,IMEAN)+i-1])) { + bscale = 1.0 + bserr = 0.0 + } else { + bscale = Memr[rg_lstatp(ls, RMEAN)+i-1] / + Memr[rg_lstatp (ls, IMEAN)+i-1] + if (fp_equalr (0.0, Memr[rg_lstatp(ls,RMEAN)+i-1])) + bserr = 0.0 + else + bserr = abs (bscale) * sqrt ((Memr[rg_lstatp(ls, + RSIGMA)+i-1] / Memr[rg_lstatp(ls,RMEAN)+i-1]) ** 2 + + (Memr[rg_lstatp(ls, ISIGMA)+i-1] / + Memr[rg_lstatp(ls,IMEAN)+i-1]) ** 2) + } + chi = INDEFR + case LS_MEDIAN: + if (fp_equalr (0.0, Memr[rg_lstatp(ls,IMEDIAN)+i-1])) { + bscale = 1.0 + bserr= 0.0 + } else { + bscale = Memr[rg_lstatp (ls,RMEDIAN)+i-1] / + Memr[rg_lstatp(ls,IMEDIAN)+i-1] + if (fp_equalr (0.0, Memr[rg_lstatp(ls,RMEDIAN)+i-1])) + bserr = 0.0 + else + bserr = abs (bscale) * sqrt ((Memr[rg_lstatp(ls, + RSIGMA)+i-1] / Memr[rg_lstatp(ls,RMEDIAN)+i-1]) ** 2 + + (Memr[rg_lstatp(ls, ISIGMA)+i-1] / Memr[rg_lstatp(ls, + IMEDIAN)+i-1]) ** 2) + } + chi = INDEFR + case LS_MODE: + if (fp_equalr (0.0, Memr[rg_lstatp (ls,IMODE)+i-1])) { + bscale = 1.0 + bserr = 0.0 + } else { + bscale = Memr[rg_lstatp (ls, RMODE)+i-1] / + Memr[rg_lstatp (ls, IMODE)+i-1] + if (fp_equalr (0.0, Memr[rg_lstatp (ls,RMODE)+i-1])) + bserr = 0.0 + else + bserr = abs (bscale) * sqrt ((Memr[rg_lstatp(ls, + RSIGMA)+i-1] / Memr[rg_lstatp(ls,RMODE)+i-1]) ** 2 + + (Memr[rg_lstatp(ls, ISIGMA)+i-1] / Memr[rg_lstatp(ls, + IMODE)+i-1]) ** 2) + } + chi = INDEFR + case LS_FIT: + call rg_llsqfit (ls, i, bscale, bzero, bserr, bzerr, chi) + case LS_PHOTOMETRY: + if (IS_INDEFR(Memr[rg_lstatp(ls,RMAG)+i-1]) || + IS_INDEFR(Memr[rg_lstatp(ls,IMAG)+i-1])) { + bscale = 1.0 + bserr = 0.0 + } else { + bscale = 10.0 ** ((Memr[rg_lstatp(ls,IMAG)+i-1] - + Memr[rg_lstatp(ls,RMAG)+i-1]) / 2.5) + if (IS_INDEFR(Memr[rg_lstatp(ls,RMAGERR)+i-1]) || + IS_INDEFR(Memr[rg_lstatp(ls,IMAGERR)+i-1])) + bserr = 0.0 + else + bserr = 0.4 * log (10.0) * bscale * + sqrt (Memr[rg_lstatp(ls,RMAGERR)+i-1] ** 2 + + Memr[rg_lstatp(ls,IMAGERR)+i-1] ** 2) + } + chi = INDEFR + default: + bscale = 1.0 + bserr = 0.0 + chi = INDEFR + } + + # Compute the bzero factor. + switch (rg_lstati (ls, BZALGORITHM)) { + case LS_NUMBER: + bzero = rg_lstatr (ls, CBZERO) + bzerr = 0.0 + chi = INDEFR + case LS_MEAN: + if (rg_lstati(ls, BSALGORITHM) == LS_NUMBER) { + bzero = Memr[rg_lstatp(ls,RMEAN)+i-1] - Memr[rg_lstatp(ls, + IMEAN)+i-1] + bzerr = sqrt (Memr[rg_lstatp(ls,RSIGMA)+i-1] ** 2 + + Memr[rg_lstatp(ls,ISIGMA)+i-1] ** 2) + } else { + bzero = 0.0 + bzerr = 0.0 + } + chi = INDEFR + case LS_MEDIAN: + if (rg_lstati(ls, BSALGORITHM) == LS_NUMBER) { + bzero = Memr[rg_lstatp(ls,RMEDIAN)+i-1] - + Memr[rg_lstatp(ls,IMEDIAN)+i-1] + bzerr = sqrt (Memr[rg_lstatp(ls,RSIGMA)+i-1] ** 2 + + Memr[rg_lstatp(ls,ISIGMA)+i-1] ** 2) + } else { + bzero = 0.0 + bzerr = 0.0 + } + chi = INDEFR + case LS_MODE: + if (rg_lstati(ls, BSALGORITHM) == LS_NUMBER) { + bzero = Memr[rg_lstatp(ls,RMODE)+i-1] - Memr[rg_lstatp(ls, + IMODE)+i-1] + bzerr = sqrt (Memr[rg_lstatp(ls,RSIGMA)+i-1] ** 2 + + Memr[rg_lstatp(ls,ISIGMA)+i-1] ** 2) + } else { + bzero = 0.0 + bzerr = 0.0 + } + chi = INDEFR + case LS_FIT: + if (rg_lstati(ls, BSALGORITHM) == LS_NUMBER) + call rg_llsqfit (ls, i, bjunk, bzero, bjunk, bzerr, chi) + case LS_PHOTOMETRY: + if (IS_INDEFR(Memr[rg_lstatp(ls,RSKY)+i-1]) || + IS_INDEFR(Memr[rg_lstatp(ls,ISKY)+i-1])) { + bzero = 0.0 + bzerr = 0.0 + } else { + bzero = Memr[rg_lstatp(ls,RSKY)+i-1] - bscale * + Memr[rg_lstatp(ls,ISKY)+i-1] + if (IS_INDEFR(Memr[rg_lstatp(ls,RSKYERR)+i-1]) || + IS_INDEFR(Memr[rg_lstatp(ls,ISKYERR)+i-1])) + bzerr = 0.0 + else + bzerr = sqrt (Memr[rg_lstatp(ls,RSKYERR)+i-1] ** 2 + + bserr ** 2 * Memr[rg_lstatp(ls,ISKY)+i-1] ** 2 + + bscale ** 2 * Memr[rg_lstatp(ls,ISKYERR)+i-1] ** 2) + + } + chi = INDEFR + default: + bzero = 0.0 + bzerr = 0.0 + chi = INDEFR + } + + # Store the results. + Memr[rg_lstatp(ls,RBSCALE)+i-1] = bscale + Memr[rg_lstatp(ls,RBZERO)+i-1] = bzero + Memr[rg_lstatp(ls,RBSCALEERR)+i-1] = bserr + Memr[rg_lstatp(ls,RBZEROERR)+i-1] = bzerr + Memr[rg_lstatp(ls,RCHI)+i-1] = chi + + return (stat) +end + + +# RG_LBSZAVG -- Compute the final scaling parameters. + +procedure rg_lbszavg (ls, avbscale, avbzero, avbserr, avbzerr, tbscale, + tbzero, tbserr, tbzerr) + +pointer ls #I pointer to the intensity scaling strucuture +real avbscale #I the computed bscale factor +real avbzero #I the computed bzero factor +real avbserr #I the computed error in bscale +real avbzerr #I the computed error in bzero +real tbscale #O the computed bscale factor +real tbzero #O the computed bzero factor +real tbserr #O the computed error in bscale +real tbzerr #O the computed error in bzero + +int i, bsalg, bzalg, nregions +pointer sp, weight +real answers[MAX_NFITPARS] +int rg_lstati() +pointer rg_lstatp() +real rg_lstatr() + +begin + bsalg = rg_lstati (ls, BSALGORITHM) + bzalg = rg_lstati (ls, BZALGORITHM) + nregions = rg_lstati (ls, NREGIONS) + + call smark (sp) + call salloc (weight, nregions, TY_REAL) + + if (bsalg == LS_MEAN || bzalg == LS_MEAN) { + do i = 1, nregions { + if (IS_INDEFR(Memr[rg_lstatp(ls,IMEAN)+i-1]) || + IS_INDEFR(Memr[rg_lstatp(ls,RMEAN)+i-1]) || + Memi[rg_lstatp(ls,RDELETE)+i-1] != LS_NO) + Memr[weight+i-1] = 0.0 + else + Memr[weight+i-1] = 1.0 + } + call ll_lsqf1 (Memr[rg_lstatp(ls,IMEAN)], Memr[rg_lstatp(ls, + RMEAN)], Memr[rg_lstatp(ls,ISIGMA)], Memr[rg_lstatp(ls, + RSIGMA)], Memr[weight], nregions, rg_lstati(ls,MAXITER), + answers) + if (nregions > 2 && rg_lstati(ls,NREJECT) > 0 && + (! IS_INDEFR(rg_lstatr(ls,LOREJECT)) || + ! IS_INDEFR(rg_lstatr(ls,HIREJECT)))) { + call ll_rlsqf1 (Memr[rg_lstatp(ls,IMEAN)], Memr[rg_lstatp(ls, + RMEAN)], Memr[rg_lstatp(ls,ISIGMA)], Memr[rg_lstatp(ls, + RSIGMA)], Memr[weight], nregions, rg_lstati(ls,MAXITER), + answers, rg_lstati(ls,NREJECT), rg_lstatr(ls,LOREJECT), + rg_lstatr(ls,HIREJECT)) + do i = 1, nregions { + if (Memr[weight+i-1] <= 0.0 && Memi[rg_lstatp(ls, + RDELETE)+i-1] == LS_NO) + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADSIGMA + } + } + if (IS_INDEFR(CHI[answers])) { + tbscale = avbscale + tbserr = avbserr + tbzero = avbzero + tbzerr = avbzerr + } else if (bsalg == LS_MEAN && bzalg == LS_MEAN) { + tbscale = SLOPE[answers] + tbserr = ESLOPE[answers] + tbzero = YINCPT[answers] + tbzerr = EYINCPT[answers] + } else if (bsalg == LS_MEAN) { + tbscale = SLOPE[answers] + tbserr = ESLOPE[answers] + tbzero = avbzero + tbzerr = avbzerr + } else { + tbscale = avbscale + tbserr = avbserr + tbzero = avbzero + tbzerr = avbzerr + } + + } else if (bsalg == LS_MEDIAN || bzalg == LS_MEDIAN) { + do i = 1, nregions { + if (IS_INDEFR(Memr[rg_lstatp(ls,IMEDIAN)+i-1]) || + IS_INDEFR(Memr[rg_lstatp(ls,RMEDIAN)+i-1]) || + Memi[rg_lstatp(ls,RDELETE)+i-1] != LS_NO) + Memr[weight+i-1] = 0.0 + else + Memr[weight+i-1] = 1.0 + } + call ll_lsqf1 (Memr[rg_lstatp(ls,IMEDIAN)], Memr[rg_lstatp(ls, + RMEDIAN)], Memr[rg_lstatp(ls,ISIGMA)], Memr[rg_lstatp(ls, + RSIGMA)], Memr[weight], nregions, rg_lstati(ls,MAXITER), + answers) + if (nregions > 2 && rg_lstati(ls,NREJECT) > 0 && + (! IS_INDEFR(rg_lstatr(ls,LOREJECT)) || + ! IS_INDEFR(rg_lstatr(ls,HIREJECT)))) { + call ll_rlsqf1 (Memr[rg_lstatp(ls,IMEDIAN)], Memr[rg_lstatp(ls, + RMEDIAN)], Memr[rg_lstatp(ls,ISIGMA)], Memr[rg_lstatp(ls, + RSIGMA)], Memr[weight], nregions, rg_lstati(ls,MAXITER), + answers, rg_lstati(ls,NREJECT), rg_lstatr(ls,LOREJECT), + rg_lstatr(ls,HIREJECT)) + do i = 1, nregions { + if (Memr[weight+i-1] <= 0.0 && Memi[rg_lstatp(ls, + RDELETE)+i-1] == LS_NO) + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADSIGMA + } + } + if (IS_INDEFR(CHI[answers])) { + tbscale = avbscale + tbserr = avbserr + tbzero = avbzero + tbzerr = avbzerr + } else if (bsalg == LS_MEDIAN && bzalg == LS_MEDIAN) { + tbscale = SLOPE[answers] + tbserr = ESLOPE[answers] + tbzero = YINCPT[answers] + tbzerr = EYINCPT[answers] + } else if (bsalg == LS_MEDIAN) { + tbscale = SLOPE[answers] + tbserr = ESLOPE[answers] + tbzero = avbzero + tbzerr = avbzerr + } else { + tbscale = avbscale + tbserr = avbserr + tbzero = avbzero + tbzerr = avbzerr + } + } else if (bsalg == LS_MODE || bzalg == LS_MODE) { + do i = 1, nregions { + if (IS_INDEFR(Memr[rg_lstatp(ls,IMODE)+i-1]) || + IS_INDEFR(Memr[rg_lstatp(ls,RMODE)+i-1]) || + Memi[rg_lstatp(ls,RDELETE)+i-1] != LS_NO) + Memr[weight+i-1] = 0.0 + else + Memr[weight+i-1] = 1.0 + } + call ll_lsqf1 (Memr[rg_lstatp(ls,IMODE)], Memr[rg_lstatp(ls, + RMODE)], Memr[rg_lstatp(ls,ISIGMA)], Memr[rg_lstatp(ls, + RSIGMA)], Memr[weight], nregions, rg_lstati(ls,MAXITER), + answers) + if (nregions > 2 && rg_lstati(ls,NREJECT) > 0 && + (! IS_INDEFR(rg_lstatr(ls,LOREJECT)) || + ! IS_INDEFR(rg_lstatr(ls,HIREJECT)))) { + call ll_rlsqf1 (Memr[rg_lstatp(ls,IMODE)], Memr[rg_lstatp(ls, + RMODE)], Memr[rg_lstatp(ls,ISIGMA)], Memr[rg_lstatp(ls, + RSIGMA)], Memr[weight], nregions, rg_lstati(ls,MAXITER), + answers, rg_lstati(ls,NREJECT), rg_lstatr(ls,LOREJECT), + rg_lstatr(ls,HIREJECT)) + do i = 1, nregions { + if (Memr[weight+i-1] <= 0.0 && Memi[rg_lstatp(ls, + RDELETE)+i-1] == LS_NO) + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADSIGMA + } + } + if (IS_INDEFR(CHI[answers])) { + tbscale = avbscale + tbserr = avbserr + tbzero = avbzero + tbzerr = avbzerr + } else if (bsalg == LS_MODE && bzalg == LS_MODE) { + tbscale = SLOPE[answers] + tbserr = ESLOPE[answers] + tbzero = YINCPT[answers] + tbzerr = EYINCPT[answers] + } else if (bsalg == LS_MODE) { + tbscale = SLOPE[answers] + tbserr = ESLOPE[answers] + tbzero = avbzero + tbzerr = avbzerr + } else { + tbscale = avbscale + tbserr = avbserr + tbzero = avbzero + tbzerr = avbzerr + } + } else { + tbscale = avbscale + tbzero = avbzero + tbserr = avbserr + tbzerr = avbzerr + } + + + call sfree (sp) +end + + +# RG_LFILE -- Fetch the scaling parameters from the datafile. + +procedure rg_lfile (db, ls, bscale, bzero, bserr, bzerr) + +pointer db #I pointer to the database file +pointer ls #I pointer to the intensity scaling structure +real bscale #O the average scaling parameter +real bzero #O the average offset parameter +real bserr #O the error in bscale +real bzerr #O the error in bzero + +int rec +pointer sp, record +int dtlocate() +real dtgetr() + +begin + call smark (sp) + call salloc (record, SZ_FNAME, TY_CHAR) + + call rg_lstats (ls, RECORD, Memc[record], SZ_FNAME) + iferr { + rec = dtlocate (db, Memc[record]) + bscale = dtgetr (db, rec, "bscale") + bzero = dtgetr (db, rec, "bzero") + bserr = dtgetr (db, rec, "bserr") + bzerr = dtgetr (db, rec, "bzerr") + } then { + bscale = 1.0 + bzero = 0.0 + bserr = INDEFR + bzerr = INDEFR + } + + call sfree (sp) +end + + +# RG_SIMGET -- Fill a buffer from a specified region of the image including a +# step size in x and y. + +int procedure rg_simget (im, c1, c2, cstep, l1, l2, lstep, ptr) + +pointer im #I the pointer to the iraf image +int c1, c2 #I the column limits +int cstep #I the column step size +int l1, l2 #I the line limits +int lstep #I the line step size +pointer ptr #I the pointer to the output buffer + +int i, j, ncols, nlines, npts +pointer iptr, buf +pointer imgs2r() + +begin + ncols = (c2 - c1) / cstep + 1 + nlines = (l2 - l1) / lstep + 1 + npts = ncols * nlines + call malloc (ptr, npts, TY_REAL) + + iptr = ptr + do j = l1, l2, lstep { + buf = imgs2r (im, c1, c2, j, j) + do i = 1, ncols { + Memr[iptr+i-1] = Memr[buf] + buf = buf + cstep + } + iptr = iptr + ncols + } + + return (npts) +end + + +# RG_LMODE -- 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 rg_lmode (a, npts, nmin, zrange, fzbin, fzstep) + +real a[npts] #I the sorted input data array +int npts #I the number of points +int nmin #I the minimum number of points +real zrange #I fraction of pixels around median to use +real fzbin #I the bin size for the mode search +real fzstep #I the step size for the mode search + +int x1, x2, x3, nmax +real zstep, zbin, y1, y2, mode +bool fp_equalr() + +begin + # If there are too few points return the median. + if (npts < nmin) { + if (mod (npts,2) == 1) + return (a[1+npts/2]) + else + return ((a[npts/2] + a[1+npts/2]) / 2.0) + } + + # Compute the data range that will be used to do the mode search. + # If the data has no range then the constant value will be returned. + x1 = max (1, int (1.0 + npts * (1.0 - zrange) / 2.0)) + x3 = min (npts, int (1.0 + npts * (1.0 + zrange) / 2.0)) + if (fp_equalr (a[x1], a[x3])) + return (a[x1]) + + # Compute the bin and step size. The bin size is based on the + # data range over a fraction of the pixels around the median + # and a bin step which may be smaller than the bin size. + + zstep = fzstep * (a[x3] - a[x1]) + zbin = fzbin * (a[x3] - a[x1]) + + nmax = 0 + x2 = x1 + for (y1 = a[x1]; x2 < x3; y1 = y1 + zstep) { + for (; a[x1] < y1; x1 = x1 + 1) + ; + y2 = y1 + zbin + for (; (x2 < x3) && (a[x2] < y2); x2 = x2 + 1) + ; + if (x2 - x1 > nmax) { + nmax = x2 - x1 + if (mod (x2+x1,2) == 0) + mode = a[(x2+x1)/2] + else + mode = (a[(x2+x1)/2] + a[(x2+x1)/2+1]) / 2.0 + } + } + + return (mode) +end + + +# RG_LLSQFIT -- Compute the bscale and bzero factors by doing a least squares +# fit to the region data. For this technque to be successful the data must +# be registered and psf matched. + +procedure rg_llsqfit (ls, i, bscale, bzero, bserr, bzerr, chi) + +pointer ls #I pointer to the intensity scaling structure +int i #I the current region +real bscale #O the computed bscale factor +real bzero #O the computed bzero factor +real bserr #O the estimated error in bscale +real bzerr #O the estimated error in bzero +real chi #O the output chi at unit weight + +int j, npts +pointer rbuf, ibuf, rerr, ierr, weight +real rgain, igain, rrnoise, irnoise, answers[MAX_NFITPARS] +real datamin, datamax +int rg_lstati() +pointer rg_lstatp() +real rg_lstatr() + +begin + # Get the data pointers. + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + + # Allocate space for the error and weight arrays. + npts = Memi[rg_lstatp(ls,RNPTS)+i-1] + call malloc (rerr, npts, TY_REAL) + call malloc (ierr, npts, TY_REAL) + call malloc (weight, npts, TY_REAL) + + # Compute the errors. + rgain = rg_lstatr (ls, RGAIN) + igain = rg_lstatr (ls, IGAIN) + rrnoise = rg_lstatr (ls, RREADNOISE) ** 2 / rgain + irnoise = rg_lstatr (ls, IREADNOISE) ** 2 / igain + do j = 1, npts { + Memr[rerr+j-1] = (Memr[rbuf+j-1] + rrnoise) / rgain + Memr[ierr+j-1] = (Memr[ibuf+j-1] + irnoise) / igain + } + + # Compute the weights. + if (IS_INDEFR(rg_lstatr(ls,DATAMIN)) && IS_INDEFR(ls,DATAMAX)) + call amovkr (1.0, Memr[weight], npts) + else { + if (IS_INDEFR(rg_lstatr(ls,DATAMIN))) + datamin = -MAX_REAL + else + datamin = rg_lstatr (ls, DATAMIN) + if (IS_INDEFR(rg_lstatr(ls,DATAMAX))) + datamax = MAX_REAL + else + datamax = rg_lstatr (ls, DATAMAX) + do j = 1, npts { + if (Memr[rbuf+j-1] < datamin || Memr[rbuf+j-1] > datamax) + Memr[weight+j-1] = 0.0 + else if (Memr[ibuf+j-1] < datamin || Memr[ibuf+j-1] > datamax) + Memr[weight+j-1] = 0.0 + else + Memr[weight+j-1] = 1.0 + } + } + + # Compute the fit. + call ll_lsqf1 (Memr[ibuf], Memr[rbuf], Memr[ierr], Memr[rerr], + Memr[weight], npts, rg_lstati(ls, MAXITER), answers) + + # Perform the rejection cycle. + if (npts > 2 && rg_lstati(ls,NREJECT) > 0 && + (! IS_INDEFR(rg_lstatr(ls,LOREJECT)) || + ! IS_INDEFR(rg_lstatr(ls,HIREJECT)))) + call ll_rlsqf1 (Memr[ibuf], Memr[rbuf], Memr[ierr], Memr[rerr], + Memr[weight], npts, rg_lstati(ls,MAXITER), answers, + rg_lstati(ls,NREJECT), rg_lstatr(ls,LOREJECT), + rg_lstatr(ls,HIREJECT)) + bscale = SLOPE[answers] + bzero = YINCPT[answers] + bserr = ESLOPE[answers] + bzerr = EYINCPT[answers] + chi = CHI[answers] + + # Free the working space. + call mfree (rerr, TY_REAL) + call mfree (ierr, TY_REAL) + call mfree (weight, TY_REAL) +end + + +# RG_RAVSTATS -- Compute the average statistics. + +procedure rg_ravstats (ls, sumbscale, sumbzero, sumwbscale, sumwbzero, sumbserr, + sumbzerr, bserr, bzerr, avbscale, avbzero, avbserr, avbzerr, ngood) + +pointer ls #I pointer to the linmatch structure +double sumbscale #I/O sum of the bscale values +double sumbzero #I/O sum of the bzero values +double sumwbscale #I/O sum of the weighted bscale values +double sumwbzero #I/O sum of the weighted bzero values +double sumbserr #I/O sum of the bscale error +double sumbzerr #I/O sum of the bscale error +real bserr #I/O the bscale error of 1 observation +real bzerr #I/O the bzero error of 1 observation +real avbscale #I/O the average bscale factor +real avbzero #I/O the average bzero factor +real avbserr #O the average bscale error factor +real avbzerr #O the average bzero error factor +int ngood #I/O the number of good data values + +int i, nregions, nrej, nbad +real sigbscale, sigbzero, lobscale, hibscale, lobzero, hibzero +real bscale, bzero, bsresid, bzresid +double dw +int rg_lstati() +pointer rg_lstatp() +real rg_lsigma(), rg_lstatr() + +begin + nregions = rg_lstati (ls,NREGIONS) + + nrej = 0 + repeat { + + # Compute sigma. + sigbscale = rg_lsigma (Memr[rg_lstatp(ls,RBSCALE)], + Memi[rg_lstatp(ls,RDELETE)], nregions, avbscale) + if (sigbscale <= 0.0) + break + sigbzero = rg_lsigma (Memr[rg_lstatp(ls,RBZERO)], + Memi[rg_lstatp(ls,RDELETE)], nregions, avbzero) + if (sigbzero <= 0.0) + break + + if (IS_INDEFR(rg_lstatr(ls,LOREJECT))) { + lobscale = -MAX_REAL + lobzero = -MAX_REAL + } else { + lobscale = -sigbscale * rg_lstatr (ls, LOREJECT) + lobzero = -sigbzero * rg_lstatr (ls, LOREJECT) + } + if (IS_INDEFR(rg_lstatr(ls,HIREJECT))) { + hibscale = MAX_REAL + hibzero = MAX_REAL + } else { + hibscale = sigbscale * rg_lstatr (ls, HIREJECT) + hibzero = sigbzero * rg_lstatr (ls, HIREJECT) + } + + nbad = 0 + do i = 1, nregions { + if (Memi[rg_lstatp(ls,RDELETE)+i-1] != LS_NO) + next + bscale = Memr[rg_lstatp(ls,RBSCALE)+i-1] + if (IS_INDEFR(bscale)) + next + bzero = Memr[rg_lstatp(ls,RBZERO)+i-1] + if (IS_INDEFR(bzero)) + next + bserr = Memr[rg_lstatp(ls,RBSCALEERR)+i-1] + bsresid = bscale - avbscale + bzerr = Memr[rg_lstatp(ls,RBZEROERR)+i-1] + bzresid = bzero - avbzero + if (bsresid >= lobscale && bsresid <= hibscale && bzresid >= + lobzero && bzresid <= hibzero) + next + + if (bserr <= 0.0) + dw = 1.0d0 + else + dw = 1.0d0 / bserr ** 2 + sumbscale = sumbscale - dw * bscale + sumbserr = sumbserr - dw * bscale * bscale + sumwbscale = sumwbscale - dw + + if (bzerr <= 0.0) + dw = 1.0d0 + else + dw = 1.0d0 / bzerr ** 2 + sumbzero = sumbzero - dw * bzero + sumbzerr = sumbzerr - dw * bzero * bzero + sumwbzero = sumwbzero - dw + + nbad = nbad + 1 + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADSIGMA + ngood = ngood - 1 + } + + if (nbad <= 0) + break + + call rg_avstats (sumbscale, sumbzero, sumwbscale, sumwbzero, + sumbserr, sumbzerr, bserr, bzerr, avbscale, avbzero, + avbserr, avbzerr, ngood) + if (ngood <= 0) + break + + nrej = nrej + 1 + + } until (nrej >= rg_lstati(ls,NREJECT)) +end + + +# RG_AVSTATS -- Compute the average statistics. + +procedure rg_avstats (sumbscale, sumbzero, sumwbscale, sumwbzero, sumbserr, + sumbzerr, bserr, bzerr, avbscale, avbzero, avbserr, avbzerr, ngood) + +double sumbscale #I sum of the bscale values +double sumbzero #I sum of the bzero values +double sumwbscale #I sum of the weighted bscale values +double sumwbzero #I sum of the weighted bzero values +double sumbserr #I sum of the bscale error +double sumbzerr #I sum of the bscale error +real bserr #I the bscale error of 1 observation +real bzerr #I the bzero error of 1 observation +real avbscale #O the average bscale factor +real avbzero #O the average bzero factor +real avbserr #O the average bscale error factor +real avbzerr #O the average bzero error factor +int ngood #I the number of good data values + +begin + # Compute the average scaling factors. + if (ngood > 0) { + avbscale = sumbscale / sumwbscale + if (ngood > 1) { + avbserr = ngood * (sumbserr / sumwbscale - (sumbscale / + sumwbscale) ** 2) / + (ngood - 1) + if (avbserr >= 0.0) + avbserr = sqrt (avbserr) + else + avbserr = 0.0 + } else + avbserr = bserr + avbzero = sumbzero / sumwbzero + if (ngood > 1) { + avbzerr = ngood * (sumbzerr / sumwbzero - (sumbzero / + sumwbzero) ** 2) / + (ngood - 1) + if (avbzerr >= 0.0) + avbzerr = sqrt (avbzerr) + else + avbzerr = 0.0 + } else + avbzerr = bzerr + } else { + avbscale = 1.0 + avbzero = 0.0 + avbserr = INDEFR + avbzerr = INDEFR + } +end + + +# RG_LSIGMA -- Compute the standard deviation of an array taken into +# account any existing deletions. + +real procedure rg_lsigma (a, del, npts, mean) + +real a[ARB] #I the input array +int del[ARB] #I the deletions array +int npts #I the number of points in the array +real mean #I the mean of the array + +int i, ngood +double sumsq + +begin + sumsq = 0.0d0 + ngood = 0 + + do i = 1, npts { + if (del[i] != LS_NO) + next + if (IS_INDEFR(a[i])) + next + sumsq = sumsq + (a[i] - mean) ** 2 + ngood = ngood + 1 + } + + if (ngood <= 1) + return (0.0) + else if (sumsq <= 0.0) + return (0.0) + else + return (sqrt (real (sumsq / (ngood - 1)))) +end diff --git a/pkg/images/immatch/src/linmatch/rglshow.x b/pkg/images/immatch/src/linmatch/rglshow.x new file mode 100644 index 00000000..1bf2c65f --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rglshow.x @@ -0,0 +1,107 @@ +include "linmatch.h" + +# RG_LSHOW -- Print the LINMATCH task parameters. + +procedure rg_lshow (ls) + +pointer ls #I pointer to linmatch structure + +pointer sp, str1, str2 +int rg_lstati() +real rg_lstatr() + +begin + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + call printf ("\nIntensity Matching Parameters\n") + if (rg_lstati (ls, BSALGORITHM) != LS_PHOTOMETRY && rg_lstati(ls, + BZALGORITHM) != LS_PHOTOMETRY) { + call rg_lstats (ls, IMAGE, Memc[str1], SZ_FNAME) + call printf (" %s: %s") + call pargstr (KY_IMAGE) + call pargstr (Memc[str1]) + call rg_lstats (ls, REFIMAGE, Memc[str1], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str1]) + call rg_lstats (ls, REGIONS, Memc[str1], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_REGIONS) + call pargstr (Memc[str1]) + call rg_lstats (ls, CCDGAIN, Memc[str1], SZ_LINE) + call rg_lstats (ls, CCDREAD, Memc[str2], SZ_LINE) + call printf (" %s: %s %s: %s\n") + call pargstr (KY_GAIN) + call pargstr (Memc[str1]) + call pargstr (KY_READNOISE) + call pargstr (Memc[str2]) + } else { + call rg_lstats (ls, IMAGE, Memc[str1], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str1]) + call rg_lstats (ls, PHOTFILE, Memc[str1], SZ_FNAME) + call printf (" %s: %s") + call pargstr (KY_IMAGE) + call pargstr (Memc[str1]) + call rg_lstats (ls, REFIMAGE, Memc[str1], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str1]) + } + call rg_lstats (ls, SHIFTSFILE, Memc[str1], SZ_FNAME) + if (Memc[str1] != EOS) { + call printf (" %s: %s\n") + call pargstr (KY_SHIFTSFILE) + call pargstr (Memc[str1]) + } else { + call printf (" %s: %g %s: %g\n") + call pargstr (KY_XSHIFT) + call pargr (rg_lstatr(ls,XSHIFT)) + call pargstr (KY_YSHIFT) + call pargr (rg_lstatr(ls,YSHIFT)) + } + call printf (" %s: %d %s: %d\n") + call pargstr (KY_DNX) + call pargi (rg_lstati(ls,DNX)) + call pargstr (KY_DNY) + call pargi (rg_lstati(ls,DNY)) + + call rg_lstats (ls, DATABASE, Memc[str1], SZ_FNAME) + call printf (" %s: %s") + call pargstr (KY_DATABASE) + call pargstr (Memc[str1]) + call rg_lstats (ls, OUTIMAGE, Memc[str1], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_OUTIMAGE) + call pargstr (Memc[str1]) + + call rg_lstats (ls, BSSTRING, Memc[str1], SZ_LINE) + call rg_lstats (ls, BZSTRING, Memc[str2], SZ_LINE) + call printf (" %s: %s %s\n") + call pargstr ("scaling") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call printf (" %s = %g %s = %g") + call pargstr (KY_DATAMIN) + call pargr (rg_lstatr (ls, DATAMIN)) + call pargstr (KY_DATAMAX) + call pargr (rg_lstatr (ls, DATAMAX)) + call printf (" %s: %d\n") + call pargstr (KY_MAXITER) + call pargi (rg_lstati(ls,MAXITER)) + call printf (" %s: %d") + call pargstr (KY_NREJECT) + call pargi (rg_lstati(ls,NREJECT)) + call printf (" %s = %g %s = %g\n") + call pargstr (KY_LOREJECT) + call pargr (rg_lstatr (ls, LOREJECT)) + call pargstr (KY_HIREJECT) + call pargr (rg_lstatr (ls, HIREJECT)) + + call printf ("\n") + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/linmatch/rglsqfit.x b/pkg/images/immatch/src/linmatch/rglsqfit.x new file mode 100644 index 00000000..f728ecde --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rglsqfit.x @@ -0,0 +1,443 @@ +include <mach.h> +include "lsqfit.h" + +# LL_RLSQF1 -- Given an initial fit reject points outside of the low and +# high cut rejections parameters. + +procedure ll_rlsqf1 (x, y, xerr, yerr, weight, npts, maxiter, answers, nreject, + locut, hicut) + +real x[ARB] #I the input vector +real y[ARB] #I the reference vector +real xerr[ARB] #I the input vector errors squared +real yerr[ARB] #I the reference vector errors squared +real weight[ARB] #I the input weight array +int npts #I the number of points +int maxiter #I the number of iterations +real answers[ARB] #I/O the answers array +int nreject #I the max number of rejection cycles +real locut #I the low side rejection parameter +real hicut #I the high side rejection parameter + +int i, niter, nrej +real loval, hival, resid + +begin + if ((IS_INDEFR(locut) && IS_INDEFR(hicut)) || npts <= 2) + return + if (RMS[answers] <= 0.0 || IS_INDEFR(CHI[answers])) + return + + niter = 0 + repeat { + if (IS_INDEFR(locut)) + loval = -MAX_REAL + else + loval = -locut * RMS[answers] + if (IS_INDEFR(hicut)) + hival = MAX_REAL + else + hival = hicut * RMS[answers] + nrej = 0 + do i = 1, npts { + if (weight[i] <= 0.0) + next + resid = y[i] - (SLOPE[answers] * x[i] + YINCPT[answers]) + if (resid >= loval && resid <= hival) + next + weight[i] = 0.0 + nrej = nrej + 1 + } + if (nrej <= 0) + break + call ll_lsqf1 (x, y, xerr, yerr, weight, npts, maxiter, answers) + if (IS_INDEFR(CHI[answers])) + break + if (RMS[answers] <= 0.0) + break + niter = niter + 1 + } until (niter >= nreject) +end + + +# LL_LSQF1 -- Compute the slope and intercept of the equation y = a * x + b +# using error arrays in both x and y. + +procedure ll_lsqf1 (x, y, xerr, yerr, weight, npts, niter, answers) + +real x[ARB] #I the input vector +real y[ARB] #I the reference vector +real xerr[ARB] #I the input vector errors squared +real yerr[ARB] #I the reference vector errors squared +real weight[ARB] #I the input weight array +int npts #I the number of points +int niter #I the number of iterations +real answers[ARB] #I/O the answers array + +int i, j +pointer bufr, bufx, bufw +real slope, yintrcpt, me1, msq, wt, dm, db + +begin + # Peform the initial fit. + call ll_0lsqf1 (x, y, weight, npts, answers) + if (IS_INDEFR(CHI[answers])) + return + + # Allocate working space. + call malloc (bufr, npts, TY_REAL) + call malloc (bufx, npts, TY_REAL) + call malloc (bufw, npts, TY_REAL) + + # Initialize the iterations. + slope = SLOPE[answers] + yintrcpt = YINCPT[answers] + me1 = CHI[answers] + + # Iterate on the fit. + do i = 1, niter { + msq = slope * slope + do j = 1, npts { + if (weight[j] <= 0.0) { + Memr[bufr+j-1] = 0.0 + Memr[bufw+j-1] = 0.0 + Memr[bufx+j-1] = 0.0 + } else { + wt = yerr[j] + msq * xerr[j] + if (wt <= 0.0) + wt = 1.0 + else + wt = 1.0 / wt + Memr[bufr+j-1] = y[j] - (slope * x[j] + yintrcpt) + Memr[bufw+j-1] = weight[j] * wt + Memr[bufx+j-1] = x[j] + Memr[bufr+j-1] * slope * xerr[j] * + wt + } + } + call ll_0lsqf1 (Memr[bufx], Memr[bufr], Memr[bufw], npts, answers) + if (IS_INDEFR(CHI[answers])) + break + if (abs ((me1 - CHI[answers]) / CHI[answers]) < 1.0e-5) + break + dm = SLOPE[answers] + db = YINCPT[answers] + me1 = CHI[answers] + slope = slope + dm + yintrcpt = yintrcpt + db + } + + # Compute the final answers. + SLOPE[answers] = slope + YINCPT[answers] = yintrcpt + + call mfree (bufr, TY_REAL) + call mfree (bufx, TY_REAL) + call mfree (bufw, TY_REAL) +end + + +# LL_0LSQF1: Compute the slope and intercept of the equation y = a * x + b +# using errors in y only. + +procedure ll_0lsqf1 (x, y, w, npts, answers) + +real x[ARB] #I the input vector +real y[ARB] #I the reference vector +real w[ARB] #I the weight vector +int npts #I the number of points +real answers[ARB] #I the answers + +int i, ngood +double sumyy, sumxx, sumxy, sumx, sumy, sumw +double a, b, det +real wressq, ressq +bool fp_equald() +double ll_dsum1(), ll_dsum2(), ll_dsum3() + +begin + # Compute the determinant. + sumyy = ll_dsum3 (y, y, w, npts) + sumxx = ll_dsum3 (x, x, w, npts) + sumxy = ll_dsum3 (x, y, w, npts) + sumy = ll_dsum2 (y, w, npts) + sumx = ll_dsum2 (x, w, npts) + sumw = ll_dsum1 (w, npts) + det = sumw * sumxx - sumx * sumx + + if (fp_equald (0.0d0, det)) { + SLOPE[answers] = INDEFR + YINCPT[answers] = INDEFR + ESLOPE[answers] = INDEFR + EYINCPT[answers] = INDEFR + CHI[answers] = INDEFR + RMS[answers] = INDEFR + } else { + a = (sumw * sumxy - sumx * sumy) / det + b = (sumxx * sumy - sumx * sumxy) / det + ngood = 0.0 + ressq = 0.0 + do i = 1, npts { + if (w[i] > 0.0) { + ngood = ngood + 1 + ressq = ressq + (y[i] - (a * x[i] + b)) ** 2 + } + } + SLOPE[answers] = a + YINCPT[answers] = b + wressq = sumyy + a * (a * sumxx + 2. * (b * sumx - sumxy)) + + b * (b * sumw - 2.0 * sumy) + if (ngood <= 2) { + CHI[answers] = 0.0 + ESLOPE[answers] = 0.0 + EYINCPT[answers] = 0.0 + RMS[answers] = 0.0 + } else if (wressq >= 0.0) { + CHI[answers] = sqrt (wressq / (ngood - 2)) + ESLOPE[answers] = CHI[answers] * sqrt (real (sumw / abs(det))) + EYINCPT[answers] = CHI[answers] * sqrt (real (sumxx / abs(det))) + RMS[answers] = sqrt (ressq / (ngood - 2)) + } else { + CHI[answers] = 0.0 + ESLOPE[answers] = 0.0 + EYINCPT[answers] = 0.0 + RMS[answers] = 0.0 + } + } +end + + +## GET_LSQF2: iterate LSq Fit to z=ax+by+c for errors in x, y and z. +## NB: xerr, yerr, zerr are errors SQUARED. +## +# +#procedure get_lsqf2 (x, y, z, xerr, yerr, zerr, weight, npts, niter, stats) +# +#real x[npts], y[npts], z[npts] # data vectors +#real xerr[npts], yerr[npts], zerr[npts] # error ** 2 vectors +#real weight[npts] # additional weight factors +#int npts # vector lengths +#int niter # no. of iterations +#real stats[NFITPAR] # returned fit params +# +#int i, j +#real a, b, c, me1 +#pointer bufr, bufx, bufy, bufw +#real asq, bsq, res, wt, da, db, dc +# +#begin +# call malloc (bufr, npts, TY_REAL) +# call malloc (bufx, npts, TY_REAL) +# call malloc (bufy, npts, TY_REAL) +# call malloc (bufw, npts, TY_REAL) +# +## initial fit; NB needs expansion +# call get_0lsqf2 (x, y, z, weight, npts, stats) +# a = SLOPE1[stats] +# b = SLOPE2[stats] +# c = OFFSET[stats] +# me1 = CHI[stats] +## call printf ("iteration: %2d a=%7.4f b=%7.4f off=%6.2f (%7.3f) \n") +## call pargi (0) +## call pargr (a) +## call pargr (b) +## call pargr (c) +## call pargr (me1) +# +## iterate +# do i = 1, niter { +# asq = a * a +# bsq = b * b +# do j = 1, npts { +# res = z[j] - (a * x[j] + b * y[j] + c) +# wt = 1. / (zerr[j] + asq * xerr[j] + bsq * yerr[j]) +# Memr[bufr+j-1] = res +# Memr[bufw+j-1] = weight[j] * wt +# Memr[bufx+j-1] = x[j] + res * a * xerr[j] * wt +# Memr[bufy+j-1] = y[j] + res * b * yerr[j] * wt +# } +# call get_0lsqf2 (Memr[bufx], Memr[bufy], Memr[bufr], Memr[bufw], npts, stats) +# da = SLOPE1[stats] +# db = SLOPE2[stats] +# dc = OFFSET[stats] +# me1 = CHI[stats] +# a = a + da +# b = b + db +# c = c + dc +## call printf ("iteration: %2d a=%7.4f b=%7.4f off=%6.2f (%7.3f) \n") +## call pargi (i) +## call pargr (a) +## call pargr (b) +## call pargr (c) +## call pargr (me1) +# } +# +# SLOPE1[stats] = a +# SLOPE2[stats] = b +# OFFSET[stats] = c +# +# call mfree (bufr, TY_REAL) +# call mfree (bufx, TY_REAL) +# call mfree (bufy, TY_REAL) +# call mfree (bufw, TY_REAL) +#end +# +## +## GET_0LSQF2 -- calculate the zeroth order LLSq Fit for 2 independent variables, +## assumming errors in z only +## +# +# procedure get_0lsqf2 (x, y, z, w, npt, stats) +# +#real x[npt], y[npt] # input coords +#real z[npt] # ref. coord. +#real w[npt] # weights +#int npt # number of points +#real stats[NFITPAR] # fit info struct +# +#real ga[4, 3] +# +#double dsum1(), dsum2(), dsum3() +# +#begin +# ga[1,1] = dsum3 (x, x, w, npt) +# ga[2,1] = dsum3 (x, y, w, npt) +# ga[2,2] = dsum3 (y, y, w, npt) +# ga[3,1] = dsum2 (x, w, npt) +# ga[3,2] = dsum2 (y, w, npt) +# ga[4,1] = dsum3 (x, z, w, npt) +# ga[4,2] = dsum3 (y, z, w, npt) +# ga[4,3] = dsum2 (z, w, npt) +# ga[3,3] = dsum1 (w, npt) +# +# ga[1,2] = ga[2,1] +# ga[1,3] = ga[3,1] +# ga[2,3] = ga[3,2] +# +# call g_elim(ga, 3) +# +# SLOPE1[stats] = ga[4,1] +# SLOPE2[stats] = ga[4,2] +# OFFSET[stats] = ga[4,3] +##need to define errors, me1 +# EOFFSET[stats] = INDEF +# ESLOPE1[stats] = INDEF +# ESLOPE2[stats] = INDEF +# CHI[stats] = INDEF +#end +# + + +# LL_LLSQF0 -- Compute the offset b in the equation y - x = b using error +# arrays in both x and y. + +#procedure ll_lsqf0 (x, y, xerr, yerr, w, npts, answers) + +#real x[ARB] #I the input vector +#real y[ARB] #I the reference vector +#real xerr[ARB] #I the input vector errors squared +#real yerr[ARB] #I the reference vector errors squared +#real w[ARB] #I the input weight vector +#int npts #I the number of points +#real answers[ARB] #I the answer vector + +#double sumxx, sumx, sumw +#pointer bufr, bufw +#double ll_dsum1(), ll_dsum2(), ll_dsum3() + +#begin +# # Allocate working space. +# call malloc (bufr, npts, TY_REAL) +# call malloc (bufw, npts, TY_REAL) +# +# call asubr (y, x, Memr[bufr], npts) +# call aaddr (yerr, xerr, Memr[bufw], npts) +# call adivr (w, Memr[bufw], Memr[bufw], npts) +# +# sumxx = ll_dsum3 (Memr[bufr], Memr[bufr], Memr[bufw], npts) +# sumx = ll_dsum2 (Memr[bufr], Memr[bufw], npts) +# sumw = ll_dsum1 (Memr[bufw], npts) +# +# if (sumw <= 0.0d0) { +# OFFSET[answers] = INDEFR +# EOFFSET[answers] = INDEFR +# CHI[answers] = INDEFR +# } else { +# OFFSET[answers] = sumx / sumw +# if (npts > 1) { +# CHI[answers] = sqrt (real ((sumxx - sumx * sumx / sumw) / +# (npts - 1))) +# EOFFSET[answers] = CHI[answers] / sqrt (real (sumw)) +# } else { +# CHI[answers] = 0.0 +# EOFFSET[answers] = 0.0 +# } +# } +# +# # Free working space. +# call mfree (bufr, TY_REAL) +# call mfree (bufw, TY_REAL) +#end + + +# LL_DSUM1 -- Compute a double precision vector sum. + +double procedure ll_dsum1 (a, n) + +real a[ARB] #I the input vector +int n #I the number of points + +double sum +int i + +begin + sum = 0.0d0 + do i = 1, n + sum = sum + a[i] + + return (sum) +end + + +# LL_DSUM2 -- Compute a double precision vector product. + +double procedure ll_dsum2 (a, b, n) + +real a[n] #I the input vector +real b[n] #I the weight vector +int n #I the number of points + +double sum +int i + +begin + sum = 0.0d0 + do i = 1, n { + if (b[i] > 0.0) + sum = sum + a[i] * b[i] + } + + return (sum) +end + + +# LL_DSUM3 -- Compute a double precision weighted dot product. + + +double procedure ll_dsum3 (a, b, c, n) + +real a[n] #I first input vector +real b[n] #I second input vector +real c[n] #I input weight vector +int n #I the number of points + +double sum +int i + +begin + sum = 0.0d0 + do i = 1, n + if (c[i] > 0.0) + sum = sum + a[i] * b[i] * c[i] + + return (sum) +end diff --git a/pkg/images/immatch/src/linmatch/rgltools.x b/pkg/images/immatch/src/linmatch/rgltools.x new file mode 100644 index 00000000..845a0ac4 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rgltools.x @@ -0,0 +1,1017 @@ +include "linmatch.h" + +# RG_LINIT -- Initialize the linscale structure. + +procedure rg_linit (ls, max_nregions) + +pointer ls #I/O pointer to the intensity scaling structure +int max_nregions #I the maximum number of regions + +begin + # Allocate the temporary space. + call malloc (ls, LEN_LSSTRUCT, TY_STRUCT) + + # Set up the regions parameters. + LS_NREGIONS(ls) = 0 + LS_CNREGION(ls) = 1 + LS_MAXNREGIONS(ls) = max_nregions + + # Initialize the pointers. + LS_RC1(ls) = NULL + LS_RC2(ls) = NULL + LS_RL1(ls) = NULL + LS_RL2(ls) = NULL + LS_RXSTEP(ls) = NULL + LS_RYSTEP(ls) = NULL + LS_XSHIFT(ls) = 0.0 + LS_YSHIFT(ls) = 0.0 + LS_SXSHIFT(ls) = 0.0 + LS_SYSHIFT(ls) = 0.0 + + LS_RBUF(ls) = NULL + LS_RGAIN(ls) = 1.0 + LS_RREADNOISE(ls) = 0.0 + LS_RMEAN(ls) = NULL + LS_RMEDIAN(ls) = NULL + LS_RMODE(ls) = NULL + LS_RSIGMA(ls) = NULL + LS_RSKY(ls) = NULL + LS_RSKYERR(ls) = NULL + LS_RMAG(ls) = NULL + LS_RMAGERR(ls) = NULL + LS_RNPTS(ls) = NULL + + LS_IBUF(ls) = NULL + LS_IGAIN(ls) = 1.0 + LS_IREADNOISE(ls) = 0.0 + LS_IMEAN(ls) = NULL + LS_IMEDIAN(ls) = NULL + LS_IMODE(ls) = NULL + LS_ISIGMA(ls) = NULL + LS_ISKY(ls) = NULL + LS_ISKYERR(ls) = NULL + LS_IMAG(ls) = NULL + LS_IMAGERR(ls) = NULL + LS_INPTS(ls) = NULL + + LS_RBSCALE(ls) = NULL + LS_RBSCALEERR(ls) = NULL + LS_RBZERO(ls) = NULL + LS_RBZEROERR(ls) = NULL + LS_RDELETE(ls) = NULL + LS_RCHI(ls) = NULL + + # Initialize the scaling algorithm parameters. + LS_BZALGORITHM(ls) = DEF_BZALGORITHM + LS_BSALGORITHM(ls) = DEF_BSALGORITHM + LS_CBZERO(ls) = DEF_CBZERO + LS_CBSCALE(ls) = DEF_CBSCALE + LS_DNX(ls) = DEF_DNX + LS_DNY(ls) = DEF_DNY + LS_MAXITER(ls) = DEF_MAXITER + LS_DATAMIN(ls) = DEF_DATAMIN + LS_DATAMAX(ls) = DEF_DATAMAX + LS_NREJECT(ls) = DEF_NREJECT + LS_LOREJECT(ls) = DEF_LOREJECT + LS_HIREJECT(ls) = DEF_HIREJECT + LS_GAIN(ls) = DEF_GAIN + LS_READNOISE(ls) = DEF_READNOISE + + # Initialize the answers + LS_TBZERO(ls) = 0.0 + LS_TBZEROERR(ls) = INDEFR + LS_TBSCALE(ls) = 1.0 + LS_TBSCALEERR(ls) = INDEFR + + # Initialize the strings. + call strcpy ("mean", LS_BSSTRING(ls), SZ_FNAME) + call strcpy ("mean", LS_BZSTRING(ls), SZ_FNAME) + LS_CCDGAIN(ls) = EOS + LS_CCDREAD(ls) = EOS + LS_IMAGE(ls) = EOS + LS_REFIMAGE(ls) = EOS + LS_REGIONS(ls) = EOS + LS_DATABASE(ls) = EOS + LS_OUTIMAGE(ls) = EOS + LS_RECORD(ls) = EOS + LS_SHIFTSFILE(ls) = EOS + LS_PHOTFILE(ls) = EOS + + # Initialize the buffers. + call rg_lrinit (ls) +end + + +# RG_LRINIT -- Initialize the region dependent part of the linscale structure. + +procedure rg_lrinit (ls) + +pointer ls #I pointer to the intensity scaling structure + +begin + # Free up previously defined region pointers. + call rg_lrfree (ls) + + # Allocate region definition pointers. + call malloc (LS_RC1(ls), LS_MAXNREGIONS(ls), TY_INT) + call malloc (LS_RC2(ls), LS_MAXNREGIONS(ls), TY_INT) + call malloc (LS_RL1(ls), LS_MAXNREGIONS(ls), TY_INT) + call malloc (LS_RL2(ls), LS_MAXNREGIONS(ls), TY_INT) + call malloc (LS_RXSTEP(ls), LS_MAXNREGIONS(ls), TY_INT) + call malloc (LS_RYSTEP(ls), LS_MAXNREGIONS(ls), TY_INT) + + # Allocate region statistics pointers. + call malloc (LS_RMEAN(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RMEDIAN(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RMODE(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RSIGMA(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RSKY(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RSKYERR(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RMAG(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RMAGERR(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RNPTS(ls), LS_MAXNREGIONS(ls), TY_INT) + + call malloc (LS_IMEAN(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_IMEDIAN(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_IMODE(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_ISIGMA(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_ISKY(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_ISKYERR(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_IMAG(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_IMAGERR(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_INPTS(ls), LS_MAXNREGIONS(ls), TY_INT) + + call malloc (LS_RBSCALE(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RBSCALEERR(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RBZERO(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RBZEROERR(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RDELETE(ls), LS_MAXNREGIONS(ls), TY_INT) + call malloc (LS_RCHI(ls), LS_MAXNREGIONS(ls), TY_REAL) + + # Initialize region definitions. + call amovki (INDEFI, Memi[LS_RC1(ls)], LS_MAXNREGIONS(ls)) + call amovki (INDEFI, Memi[LS_RC2(ls)], LS_MAXNREGIONS(ls)) + call amovki (INDEFI, Memi[LS_RL1(ls)], LS_MAXNREGIONS(ls)) + call amovki (INDEFI, Memi[LS_RL2(ls)], LS_MAXNREGIONS(ls)) + call amovki (INDEFI, Memi[LS_RXSTEP(ls)], LS_MAXNREGIONS(ls)) + call amovki (INDEFI, Memi[LS_RYSTEP(ls)], LS_MAXNREGIONS(ls)) + + # Initilaize the statistics. + call amovkr (INDEFR, Memr[LS_RMEAN(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RMEDIAN(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RMODE(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RSIGMA(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RSKY(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RSKYERR(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RMAG(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RMAGERR(ls)], LS_MAXNREGIONS(ls)) + call amovki (INDEFI, Memi[LS_RNPTS(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_IMEAN(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_IMEDIAN(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_IMODE(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_ISIGMA(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_ISKY(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_ISKYERR(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_IMAG(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_IMAGERR(ls)], LS_MAXNREGIONS(ls)) + call amovki (INDEFI, Memi[LS_INPTS(ls)], LS_MAXNREGIONS(ls)) + + # Initialize the answers. + call amovkr (INDEFR, Memr[LS_RBSCALE(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RBSCALEERR(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RBZERO(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RBZEROERR(ls)], LS_MAXNREGIONS(ls)) + call amovki (LS_NO, Memi[LS_RDELETE(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RCHI(ls)], LS_MAXNREGIONS(ls)) +end + + +# RG_LINDEFR -- Re-initialize the regions dependent buffers. + +procedure rg_lindefr (ls) + +pointer ls #I pointer to the intensity scaling structure + +int nregions +int rg_lstati() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions > 0) { + + # Reinitialize the region definition pointers. + call amovki (INDEFI, Memi[LS_RC1(ls)], nregions) + call amovki (INDEFI, Memi[LS_RC2(ls)], nregions) + call amovki (INDEFI, Memi[LS_RL1(ls)], nregions) + call amovki (INDEFI, Memi[LS_RL2(ls)], nregions) + call amovki (INDEFI, Memi[LS_RXSTEP(ls)], nregions) + call amovki (INDEFI, Memi[LS_RYSTEP(ls)], nregions) + + # Reinitialize the statistics pointers. + call amovkr (INDEFR, Memr[LS_RMEAN(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RMEDIAN(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RMODE(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RSIGMA(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RSKY(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RSKYERR(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RMAG(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RMAGERR(ls)], nregions) + call amovki (INDEFI, Memi[LS_RNPTS(ls)], nregions) + + call amovkr (INDEFR, Memr[LS_IMEAN(ls)], nregions) + call amovkr (INDEFR, Memr[LS_IMEDIAN(ls)], nregions) + call amovkr (INDEFR, Memr[LS_IMODE(ls)], nregions) + call amovkr (INDEFR, Memr[LS_ISIGMA(ls)], nregions) + call amovkr (INDEFR, Memr[LS_ISKY(ls)], nregions) + call amovkr (INDEFR, Memr[LS_ISKYERR(ls)], nregions) + call amovkr (INDEFR, Memr[LS_IMAG(ls)], nregions) + call amovkr (INDEFR, Memr[LS_IMAGERR(ls)], nregions) + call amovki (INDEFI, Memi[LS_INPTS(ls)], nregions) + + # Reinitialize the answers pointers. + call amovkr (INDEFR, Memr[LS_RBSCALE(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RBSCALEERR(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RBZERO(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RBZEROERR(ls)], nregions) + call amovki (LS_NO, Memi[LS_RDELETE(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RCHI(ls)], nregions) + + } +end + + +# RG_LREALLOC -- Reallocate the regions dependent buffers. + +procedure rg_lrealloc (ls, nregions) + +pointer ls #I pointer to the intensity scaling structure +int nregions #I the number of regions + +int nr +int rg_lstati() + +begin + nr = rg_lstati (ls, NREGIONS) + + # Resize the region definition buffers. + call realloc (LS_RC1(ls), nregions, TY_INT) + call realloc (LS_RC2(ls), nregions, TY_INT) + call realloc (LS_RL1(ls), nregions, TY_INT) + call realloc (LS_RL2(ls), nregions, TY_INT) + call realloc (LS_RXSTEP(ls), nregions, TY_INT) + call realloc (LS_RYSTEP(ls), nregions, TY_INT) + + # Resize the statistics buffers. + call realloc (LS_RMEAN(ls), nregions, TY_REAL) + call realloc (LS_RMEDIAN(ls), nregions, TY_REAL) + call realloc (LS_RMODE(ls), nregions, TY_REAL) + call realloc (LS_RSIGMA(ls), nregions, TY_REAL) + call realloc (LS_RSKY(ls), nregions, TY_REAL) + call realloc (LS_RSKYERR(ls), nregions, TY_REAL) + call realloc (LS_RMAG(ls), nregions, TY_REAL) + call realloc (LS_RMAGERR(ls), nregions, TY_REAL) + call realloc (LS_RNPTS(ls), nregions, TY_INT) + + call realloc (LS_IMEAN(ls), nregions, TY_REAL) + call realloc (LS_IMEDIAN(ls), nregions, TY_REAL) + call realloc (LS_IMODE(ls), nregions, TY_REAL) + call realloc (LS_ISIGMA(ls), nregions, TY_REAL) + call realloc (LS_ISKY(ls), nregions, TY_REAL) + call realloc (LS_ISKYERR(ls), nregions, TY_REAL) + call realloc (LS_IMAG(ls), nregions, TY_REAL) + call realloc (LS_IMAGERR(ls), nregions, TY_REAL) + call realloc (LS_INPTS(ls), nregions, TY_INT) + + # Resize the answers buffers. + call realloc (LS_RBSCALE(ls), nregions, TY_REAL) + call realloc (LS_RBSCALEERR(ls), nregions, TY_REAL) + call realloc (LS_RBZERO(ls), nregions, TY_REAL) + call realloc (LS_RBZEROERR(ls), nregions, TY_REAL) + call realloc (LS_RDELETE(ls), nregions, TY_INT) + call realloc (LS_RCHI(ls), nregions, TY_REAL) + + # Reinitialize the region defintions. + call amovki (INDEFI, Memi[LS_RC1(ls)+nr], nregions - nr) + call amovki (INDEFI, Memi[LS_RC2(ls)+nr], nregions - nr) + call amovki (INDEFI, Memi[LS_RL1(ls)+nr], nregions - nr) + call amovki (INDEFI, Memi[LS_RL2(ls)+nr], nregions - nr) + call amovki (INDEFI, Memi[LS_RXSTEP(ls)+nr], nregions - nr) + call amovki (INDEFI, Memi[LS_RYSTEP(ls)+nr], nregions - nr) + + # Reinitialize the statistics buffers. + call amovkr (INDEFR, Memr[LS_RMEAN(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RMEDIAN(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RMODE(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RSIGMA(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RSKY(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RSKYERR(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RMAG(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RMAGERR(ls)+nr], nregions - nr) + call amovki (INDEFI, Memi[LS_RNPTS(ls)+nr], nregions - nr) + + call amovkr (INDEFR, Memr[LS_IMEAN(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_IMEDIAN(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_IMODE(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_ISIGMA(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_ISKY(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_ISKYERR(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_IMAG(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_IMAGERR(ls)+nr], nregions - nr) + call amovki (INDEFI, Memi[LS_INPTS(ls)+nr], nregions - nr) + + # Reinitialize the answers buffers. + call amovkr (INDEFR, Memr[LS_RBSCALE(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RBSCALEERR(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RBZERO(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RBZEROERR(ls)+nr], nregions - nr) + call amovki (LS_NO, Memi[LS_RDELETE(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RCHI(ls)+nr], nregions - nr) +end + + +# RG_LRFREE -- Free the regions portion of the linscale structure. + +procedure rg_lrfree (ls) + +pointer ls #I pointer to the intensity scaling structure + +begin + LS_NREGIONS(ls) = 0 + + # Free the regions definitions buffers. + if (LS_RC1(ls) != NULL) + call mfree (LS_RC1(ls), TY_INT) + LS_RC1(ls) = NULL + if (LS_RC2(ls) != NULL) + call mfree (LS_RC2(ls), TY_INT) + LS_RC2(ls) = NULL + if (LS_RL1(ls) != NULL) + call mfree (LS_RL1(ls), TY_INT) + LS_RL1(ls) = NULL + if (LS_RL2(ls) != NULL) + call mfree (LS_RL2(ls), TY_INT) + LS_RL2(ls) = NULL + if (LS_RXSTEP(ls) != NULL) + call mfree (LS_RXSTEP(ls), TY_INT) + LS_RXSTEP(ls) = NULL + if (LS_RYSTEP(ls) != NULL) + call mfree (LS_RYSTEP(ls), TY_INT) + LS_RYSTEP(ls) = NULL + + # Free the statistics buffers. + if (LS_RBUF(ls) != NULL) + call mfree (LS_RBUF(ls), TY_REAL) + if (LS_RMEAN(ls) != NULL) + call mfree (LS_RMEAN(ls), TY_REAL) + LS_RMEAN(ls) = NULL + if (LS_RMEDIAN(ls) != NULL) + call mfree (LS_RMEDIAN(ls), TY_REAL) + LS_RMEDIAN(ls) = NULL + if (LS_RMODE(ls) != NULL) + call mfree (LS_RMODE(ls), TY_REAL) + LS_RMODE(ls) = NULL + if (LS_RSIGMA(ls) != NULL) + call mfree (LS_RSIGMA(ls), TY_REAL) + LS_RSIGMA(ls) = NULL + if (LS_RSKY(ls) != NULL) + call mfree (LS_RSKY(ls), TY_REAL) + LS_RSKY(ls) = NULL + if (LS_RSKYERR(ls) != NULL) + call mfree (LS_RSKYERR(ls), TY_REAL) + LS_RSKYERR(ls) = NULL + if (LS_RMAG(ls) != NULL) + call mfree (LS_RMAG(ls), TY_REAL) + LS_RMAG(ls) = NULL + if (LS_RMAGERR(ls) != NULL) + call mfree (LS_RMAGERR(ls), TY_REAL) + LS_RMAGERR(ls) = NULL + if (LS_RNPTS(ls) != NULL) + call mfree (LS_RNPTS(ls), TY_INT) + LS_RNPTS(ls) = NULL + + if (LS_IBUF(ls) != NULL) + call mfree (LS_IBUF(ls), TY_REAL) + if (LS_IMEAN(ls) != NULL) + call mfree (LS_IMEAN(ls), TY_REAL) + LS_IMEAN(ls) = NULL + if (LS_IMEDIAN(ls) != NULL) + call mfree (LS_IMEDIAN(ls), TY_REAL) + LS_IMEDIAN(ls) = NULL + if (LS_IMODE(ls) != NULL) + call mfree (LS_IMODE(ls), TY_REAL) + LS_IMODE(ls) = NULL + if (LS_ISIGMA(ls) != NULL) + call mfree (LS_ISIGMA(ls), TY_REAL) + LS_ISIGMA(ls) = NULL + if (LS_ISKY(ls) != NULL) + call mfree (LS_ISKY(ls), TY_REAL) + LS_ISKY(ls) = NULL + if (LS_ISKYERR(ls) != NULL) + call mfree (LS_ISKYERR(ls), TY_REAL) + LS_ISKYERR(ls) = NULL + if (LS_IMAG(ls) != NULL) + call mfree (LS_IMAG(ls), TY_REAL) + LS_IMAG(ls) = NULL + if (LS_IMAGERR(ls) != NULL) + call mfree (LS_IMAGERR(ls), TY_REAL) + LS_IMAGERR(ls) = NULL + if (LS_INPTS(ls) != NULL) + call mfree (LS_INPTS(ls), TY_INT) + LS_INPTS(ls) = NULL + + # Free the answers buffers. + if (LS_RBSCALE(ls) != NULL) + call mfree (LS_RBSCALE(ls), TY_REAL) + LS_RBSCALE(ls) = NULL + if (LS_RBSCALEERR(ls) != NULL) + call mfree (LS_RBSCALEERR(ls), TY_REAL) + LS_RBSCALEERR(ls) = NULL + if (LS_RBZERO(ls) != NULL) + call mfree (LS_RBZERO(ls), TY_REAL) + LS_RBZERO(ls) = NULL + if (LS_RBZEROERR(ls) != NULL) + call mfree (LS_RBZEROERR(ls), TY_REAL) + LS_RBZEROERR(ls) = NULL + if (LS_RDELETE(ls) != NULL) + call mfree (LS_RDELETE(ls), TY_INT) + LS_RDELETE(ls) = NULL + if (LS_RCHI(ls) != NULL) + call mfree (LS_RCHI(ls), TY_REAL) + LS_RCHI(ls) = NULL +end + + +# RG_LFREE -- Free the linscale structure. + +procedure rg_lfree (ls) + +pointer ls #I/O pointer to the intensity scaling structure + +begin + # Free the regions dependent pointers. + call rg_lrfree (ls) + + call mfree (ls, TY_STRUCT) +end + + +# RG_LSTATI -- Fetch the value of an integer parameter. + +int procedure rg_lstati (ls, param) + +pointer ls #I pointer to the intensity scaling structure +int param #I parameter to be fetched + +begin + switch (param) { + case CNREGION: + return (LS_CNREGION(ls)) + case NREGIONS: + return (LS_NREGIONS(ls)) + case MAXNREGIONS: + return (LS_MAXNREGIONS(ls)) + case BZALGORITHM: + return (LS_BZALGORITHM(ls)) + case BSALGORITHM: + return (LS_BSALGORITHM(ls)) + case DNX: + return (LS_DNX(ls)) + case DNY: + return (LS_DNY(ls)) + case MAXITER: + return (LS_MAXITER(ls)) + case NREJECT: + return (LS_NREJECT(ls)) + default: + call error (0, "RG_LSTATI: Unknown integer parameter.") + } +end + + +# RG_LSTATP -- Fetch the value of a pointer parameter. + +pointer procedure rg_lstatp (ls, param) + +pointer ls #I pointer to the intensity scaling structure +int param #I parameter to be fetched + +begin + switch (param) { + + case RC1: + return (LS_RC1(ls)) + case RC2: + return (LS_RC2(ls)) + case RL1: + return (LS_RL1(ls)) + case RL2: + return (LS_RL2(ls)) + case RXSTEP: + return (LS_RXSTEP(ls)) + case RYSTEP: + return (LS_RYSTEP(ls)) + + case RBUF: + return (LS_RBUF(ls)) + case RMEAN: + return (LS_RMEAN(ls)) + case RMEDIAN: + return (LS_RMEDIAN(ls)) + case RMODE: + return (LS_RMODE(ls)) + case RSIGMA: + return (LS_RSIGMA(ls)) + case RSKY: + return (LS_RSKY(ls)) + case RSKYERR: + return (LS_RSKYERR(ls)) + case RMAG: + return (LS_RMAG(ls)) + case RMAGERR: + return (LS_RMAGERR(ls)) + case RNPTS: + return (LS_RNPTS(ls)) + + case IBUF: + return (LS_IBUF(ls)) + case IMEAN: + return (LS_IMEAN(ls)) + case IMEDIAN: + return (LS_IMEDIAN(ls)) + case IMODE: + return (LS_IMODE(ls)) + case ISIGMA: + return (LS_ISIGMA(ls)) + case ISKY: + return (LS_ISKY(ls)) + case ISKYERR: + return (LS_ISKYERR(ls)) + case IMAG: + return (LS_IMAG(ls)) + case IMAGERR: + return (LS_IMAGERR(ls)) + case INPTS: + return (LS_INPTS(ls)) + + case RBSCALE: + return (LS_RBSCALE(ls)) + case RBSCALEERR: + return (LS_RBSCALEERR(ls)) + case RBZERO: + return (LS_RBZERO(ls)) + case RBZEROERR: + return (LS_RBZEROERR(ls)) + case RDELETE: + return (LS_RDELETE(ls)) + case RCHI: + return (LS_RCHI(ls)) + + default: + call error (0, "RG_LSTATP: Unknown pointer parameter.") + } +end + + +# RG_LSTATR -- Fetch the value of a real parameter. + +real procedure rg_lstatr (ls, param) + +pointer ls #I pointer to the intensity scaling structure +int param #I parameter to be fetched + +begin + switch (param) { + + case XSHIFT: + return (LS_XSHIFT(ls)) + case YSHIFT: + return (LS_YSHIFT(ls)) + case SXSHIFT: + return (LS_SXSHIFT(ls)) + case SYSHIFT: + return (LS_SYSHIFT(ls)) + + case CBZERO: + return (LS_CBZERO(ls)) + case CBSCALE: + return (LS_CBSCALE(ls)) + case DATAMIN: + return (LS_DATAMIN(ls)) + case DATAMAX: + return (LS_DATAMAX(ls)) + case LOREJECT: + return (LS_LOREJECT(ls)) + case HIREJECT: + return (LS_HIREJECT(ls)) + case GAIN: + return (LS_GAIN(ls)) + case RGAIN: + return (LS_RGAIN(ls)) + case IGAIN: + return (LS_IGAIN(ls)) + case READNOISE: + return (LS_READNOISE(ls)) + case RREADNOISE: + return (LS_RREADNOISE(ls)) + case IREADNOISE: + return (LS_IREADNOISE(ls)) + + case TBZERO: + return (LS_TBZERO(ls)) + case TBZEROERR: + return (LS_TBZEROERR(ls)) + case TBSCALE: + return (LS_TBSCALE(ls)) + case TBSCALEERR: + return (LS_TBSCALEERR(ls)) + + default: + call error (0, "RG_LSTATR: Unknown real parameter.") + } +end + + +# RG_LSTATS -- Fetch the value of a string parameter. + +procedure rg_lstats (ls, param, str, maxch) + +pointer ls #I pointer to the intensity scaling structure +int param #I parameter to be fetched +char str[ARB] #I the output string +int maxch #I maximum number of characters + +begin + switch (param) { + case BZSTRING: + call strcpy (LS_BZSTRING(ls), str, maxch) + case BSSTRING: + call strcpy (LS_BSSTRING(ls), str, maxch) + case CCDGAIN: + call strcpy (LS_CCDGAIN(ls), str, maxch) + case CCDREAD: + call strcpy (LS_CCDREAD(ls), str, maxch) + case IMAGE: + call strcpy (LS_IMAGE(ls), str, maxch) + case REFIMAGE: + call strcpy (LS_REFIMAGE(ls), str, maxch) + case REGIONS: + call strcpy (LS_REGIONS(ls), str, maxch) + case DATABASE: + call strcpy (LS_DATABASE(ls), str, maxch) + case OUTIMAGE: + call strcpy (LS_OUTIMAGE(ls), str, maxch) + case SHIFTSFILE: + call strcpy (LS_SHIFTSFILE(ls), str, maxch) + case PHOTFILE: + call strcpy (LS_PHOTFILE(ls), str, maxch) + case RECORD: + call strcpy (LS_RECORD(ls), str, maxch) + default: + call error (0, "RG_LSTATS: Unknown string parameter.") + } +end + + +# RG_LSETI -- Set the value of an integer parameter. + +procedure rg_lseti (ls, param, value) + +pointer ls # pointer to the intensity scaling structure +int param # parameter to be fetched +int value # value of the integer parameter + +begin + switch (param) { + + case NREGIONS: + LS_NREGIONS(ls) = value + case CNREGION: + LS_CNREGION(ls) = value + case MAXNREGIONS: + LS_MAXNREGIONS(ls) = value + + case BZALGORITHM: + LS_BZALGORITHM(ls) = value + switch (value) { + case LS_MEAN: + call strcpy ("mean", LS_BZSTRING(ls), SZ_FNAME) + case LS_MEDIAN: + call strcpy ("median", LS_BZSTRING(ls), SZ_FNAME) + case LS_MODE: + call strcpy ("mode", LS_BZSTRING(ls), SZ_FNAME) + case LS_FIT: + call strcpy ("fit", LS_BZSTRING(ls), SZ_FNAME) + case LS_PHOTOMETRY: + call strcpy ("photometry", LS_BZSTRING(ls), SZ_FNAME) + case LS_NUMBER: + ; + case LS_FILE: + call strcpy ("file", LS_BZSTRING(ls), SZ_FNAME) + LS_BSALGORITHM(ls) = value + call strcpy ("file", LS_BSSTRING(ls), SZ_FNAME) + default: + LS_BZALGORITHM(ls) = LS_NUMBER + call strcpy ("0.0", LS_BZSTRING(ls), SZ_FNAME) + LS_CBZERO(ls) = 0.0 + } + + case BSALGORITHM: + LS_BSALGORITHM(ls) = value + switch (value) { + case LS_MEAN: + call strcpy ("mean", LS_BSSTRING(ls), SZ_FNAME) + case LS_MEDIAN: + call strcpy ("median", LS_BSSTRING(ls), SZ_FNAME) + case LS_MODE: + call strcpy ("mode", LS_BSSTRING(ls), SZ_FNAME) + case LS_FIT: + call strcpy ("fit", LS_BSSTRING(ls), SZ_FNAME) + case LS_PHOTOMETRY: + call strcpy ("photometry", LS_BSSTRING(ls), SZ_FNAME) + case LS_NUMBER: + ; + case LS_FILE: + call strcpy ("file", LS_BSSTRING(ls), SZ_FNAME) + LS_BZALGORITHM(ls) = value + call strcpy ("file", LS_BZSTRING(ls), SZ_FNAME) + default: + LS_BSALGORITHM(ls) = LS_NUMBER + call strcpy ("1.0", LS_BSSTRING(ls), SZ_FNAME) + LS_CBSCALE(ls) = 1.0 + } + + case DNX: + LS_DNX(ls) = value + case DNY: + LS_DNY(ls) = value + case MAXITER: + LS_MAXITER(ls) = value + case NREJECT: + LS_NREJECT(ls) = value + + default: + call error (0, "RG_LSETI: Unknown integer parameter.") + } +end + + +# RG_LSETP -- Set the value of a pointer parameter. + +procedure rg_lsetp (ls, param, value) + +pointer ls #I pointer to the linscale structure +int param #I parameter to be fetched +pointer value #I value of the pointer parameter + +begin + switch (param) { + + case RC1: + LS_RC1(ls) = value + case RC2: + LS_RC2(ls) = value + case RL1: + LS_RL1(ls) = value + case RL2: + LS_RL2(ls) = value + case RXSTEP: + LS_RXSTEP(ls) = value + case RYSTEP: + LS_RYSTEP(ls) = value + + case RBUF: + LS_RBUF(ls) = value + case RMEAN: + LS_RMEAN(ls) = value + case RMEDIAN: + LS_RMEDIAN(ls) = value + case RMODE: + LS_RMODE(ls) = value + case RSIGMA: + LS_RSIGMA(ls) = value + case RSKY: + LS_RSKY(ls) = value + case RSKYERR: + LS_RSKYERR(ls) = value + case RMAG: + LS_RMAG(ls) = value + case RMAGERR: + LS_RMAGERR(ls) = value + case RNPTS: + LS_RNPTS(ls) = value + + case IBUF: + LS_IBUF(ls) = value + case IMEAN: + LS_IMEAN(ls) = value + case IMEDIAN: + LS_IMEDIAN(ls) = value + case IMODE: + LS_IMODE(ls) = value + case ISIGMA: + LS_ISIGMA(ls) = value + case ISKY: + LS_ISKY(ls) = value + case ISKYERR: + LS_ISKYERR(ls) = value + case IMAG: + LS_IMAG(ls) = value + case IMAGERR: + LS_IMAGERR(ls) = value + case INPTS: + LS_INPTS(ls) = value + + case RBSCALE: + LS_RBSCALE(ls) = value + case RBSCALEERR: + LS_RBSCALEERR(ls) = value + case RBZERO: + LS_RBZERO(ls) = value + case RBZEROERR: + LS_RBZEROERR(ls) = value + case RDELETE: + LS_RDELETE(ls) = value + case RCHI: + LS_RCHI(ls) = value + + default: + call error (0, "RG_LSETP: Unknown pointer parameter.") + } +end + + +# RG_LSETR -- Set the value of a real parameter. + +procedure rg_lsetr (ls, param, value) + +pointer ls #I pointer to iscale structure +int param #I parameter to be fetched +real value #I real parameter + +begin + switch (param) { + case XSHIFT: + LS_XSHIFT(ls) = value + case YSHIFT: + LS_YSHIFT(ls) = value + case SXSHIFT: + LS_SXSHIFT(ls) = value + case SYSHIFT: + LS_SYSHIFT(ls) = value + case CBZERO: + LS_CBZERO(ls) = value + case CBSCALE: + LS_CBSCALE(ls) = value + case DATAMIN: + LS_DATAMIN(ls) = value + case DATAMAX: + LS_DATAMAX(ls) = value + case LOREJECT: + LS_LOREJECT(ls) = value + case HIREJECT: + LS_HIREJECT(ls) = value + case GAIN: + LS_GAIN(ls) = value + case RGAIN: + LS_RGAIN(ls) = value + case IGAIN: + LS_IGAIN(ls) = value + case READNOISE: + LS_READNOISE(ls) = value + case RREADNOISE: + LS_RREADNOISE(ls) = value + case IREADNOISE: + LS_IREADNOISE(ls) = value + case TBSCALE: + LS_TBSCALE(ls) = value + case TBSCALEERR: + LS_TBSCALEERR(ls) = value + case TBZERO: + LS_TBZERO(ls) = value + case TBZEROERR: + LS_TBZEROERR(ls) = value + default: + call error (0, "RG_LSETR: Unknown real parameter.") + } +end + + +# RG_LSETS -- Set the value of a string parameter. + +procedure rg_lsets (ls, param, str) + +pointer ls # pointer to the intensity scaling structure +int param # parameter to be fetched +char str[ARB] # output string + +int index, ip +pointer sp, temp +real rval +int fnldir(), strdic(), ctor(), rg_lstati() + +begin + call smark (sp) + call salloc (temp, SZ_LINE, TY_CHAR) + + switch (param) { + + case BZSTRING: + ip = 1 + index = strdic (str, str, SZ_LINE, LS_SCALING) + if (index > 0) { + if (rg_lstati (ls, BSALGORITHM) == LS_NUMBER) { + call strcpy (str, LS_BZSTRING(ls), SZ_FNAME) + call rg_lseti (ls, BZALGORITHM, index) + } else { + call strcpy (LS_BSSTRING(ls), LS_BZSTRING(ls), SZ_FNAME) + call rg_lseti (ls, BZALGORITHM, rg_lstati (ls, BSALGORITHM)) + } + } else if (ctor (str, ip, rval) > 0) { + call strcpy (str, LS_BZSTRING(ls), SZ_FNAME) + call rg_lsetr (ls, CBZERO, rval) + call rg_lseti (ls, BZALGORITHM, LS_NUMBER) + } else { + call strcpy ("0.0", LS_BZSTRING(ls), SZ_FNAME) + call rg_lsetr (ls, CBZERO, 0.0) + call rg_lseti (ls, BZALGORITHM, LS_NUMBER) + } + case BSSTRING: + ip = 1 + index = strdic (str, str, SZ_LINE, LS_SCALING) + if (index > 0) { + call strcpy (str, LS_BSSTRING(ls), SZ_FNAME) + call rg_lseti (ls, BSALGORITHM, index) + } else if (ctor (str, ip, rval) > 0) { + call strcpy (str, LS_BSSTRING(ls), SZ_FNAME) + call rg_lsetr (ls, CBSCALE, rval) + call rg_lseti (ls, BSALGORITHM, LS_NUMBER) + } else { + call strcpy ("1.0", LS_BSSTRING(ls), SZ_FNAME) + call rg_lsetr (ls, CBSCALE, 1.0) + call rg_lseti (ls, BSALGORITHM, LS_NUMBER) + } + case CCDGAIN: + ip = 1 + if (ctor (str, ip, rval) > 0) { + call strcpy (str, LS_CCDGAIN(ls), SZ_FNAME) + call rg_lsetr (ls, RGAIN, rval) + if (ctor (str, ip, rval) > 0) + call rg_lsetr (ls, IGAIN, rval) + else + call rg_lsetr (ls, IGAIN, 1.0) + call rg_lsetr (ls, GAIN, INDEFR) + } else { + call sscan (str) + call gargwrd (Memc[temp], SZ_LINE) + call strcpy (Memc[temp], LS_CCDGAIN(ls), SZ_FNAME) + call rg_lsetr (ls, RGAIN, 1.0) + call rg_lsetr (ls, IGAIN, 1.0) + call rg_lsetr (ls, GAIN, INDEFR) + } + case CCDREAD: + ip = 1 + if (ctor (str, ip, rval) > 0) { + call strcpy (str, LS_CCDREAD(ls), SZ_FNAME) + call rg_lsetr (ls, RREADNOISE, rval) + if (ctor (str, ip, rval) > 0) + call rg_lsetr (ls, IREADNOISE, rval) + else + call rg_lsetr (ls, IREADNOISE, 0.0) + call rg_lsetr (ls, READNOISE, INDEFR) + } else { + call sscan (str) + call gargwrd (Memc[temp], SZ_LINE) + call strcpy (Memc[temp], LS_CCDREAD(ls), SZ_FNAME) + call rg_lsetr (ls, RREADNOISE, 0.0) + call rg_lsetr (ls, IREADNOISE, 0.0) + call rg_lsetr (ls, READNOISE, INDEFR) + } + + case IMAGE: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], LS_IMAGE(ls), SZ_FNAME) + call strcpy (Memc[temp+index], LS_IMAGE(ls), SZ_FNAME) + case REFIMAGE: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], LS_REFIMAGE(ls), SZ_FNAME) + call strcpy (Memc[temp+index], LS_REFIMAGE(ls), SZ_FNAME) + case REGIONS: + call strcpy (str, LS_REGIONS(ls), SZ_FNAME) + case DATABASE: + index = fnldir (str, LS_DATABASE(ls), SZ_FNAME) + call strcpy (str[index+1], LS_DATABASE(ls), SZ_FNAME) + case OUTIMAGE: + call strcpy (str, LS_OUTIMAGE(ls), SZ_FNAME) + case SHIFTSFILE: + call strcpy (str, LS_SHIFTSFILE(ls), SZ_FNAME) + case PHOTFILE: + call strcpy (str, LS_PHOTFILE(ls), SZ_FNAME) + case RECORD: + call strcpy (str, LS_RECORD(ls), SZ_FNAME) + + default: + call error (0, "RG_LSETS: Unknown string parameter.") + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/linmatch/t_linmatch.x b/pkg/images/immatch/src/linmatch/t_linmatch.x new file mode 100644 index 00000000..d48f2c03 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/t_linmatch.x @@ -0,0 +1,544 @@ +include <fset.h> +include <imhdr.h> +include <imset.h> +include <error.h> +include "linmatch.h" + +# T_LINMATCH -- Compute the parameters required to match the intensity scale +# of an image to that of a reference image using an expression of the form +# I(ref) = a + b * I(image) + +procedure t_linmatch() + +pointer freglist #I pointer to reference regions list +pointer database #I pointer to database file +int dformat #I write the output file in database format +int interactive #I interactive mode ? +int verbose #I verbose mode + +int list1, listr, list2, reglist, reclist, stat, nregions, shiftslist +int rpfd, ipfd, sfd +pointer sp, reference, imager, image1, imtemp, image2, str, str1, shifts +pointer ls, db, gd, id, imr, im1, im2 +bool clgetb() +int imtopen(), fntopnb(), imtlen(), fntlenb(), access(), btoi(), open() +int rg_lstati(), imtgetim(), fntgfnb(), rg_lregions(), rg_lscale() +int rg_lrphot(), rg_liscale() +pointer dtmap(), gopen(), immap() +real rg_lstatr() +errchk gopen() + +begin + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate temporary space. + call smark (sp) + + call salloc (reference, SZ_FNAME, TY_CHAR) + call salloc (freglist, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (database, SZ_FNAME, TY_CHAR) + call salloc (shifts, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (str1, SZ_LINE, TY_CHAR) + + # Open the input and output image lists. + call clgstr ("input", Memc[str], SZ_LINE) + list1 = imtopen (Memc[str]) + call clgstr ("reference", Memc[reference], SZ_LINE) + call clgstr ("regions", Memc[freglist], SZ_LINE) + call clgstr ("lintransform", Memc[database], SZ_LINE) + call clgstr ("output", Memc[str], SZ_LINE) + list2 = imtopen (Memc[str]) + call clgstr ("records", Memc[str], SZ_LINE) + if (Memc[str] == EOS) + reclist = NULL + else + reclist = fntopnb (Memc[str], NO) + call clgstr ("shifts", Memc[shifts], SZ_LINE) + + + # Open the cross correlation fitting structure. + call rg_glpars (ls) + + # Test the reference image list length + if ((rg_lstati (ls, BZALGORITHM) == LS_FILE || rg_lstati(ls, + BSALGORITHM) == LS_FILE) || (rg_lstati(ls, BZALGORITHM) == + LS_NUMBER && rg_lstati(ls, BSALGORITHM) == LS_NUMBER)) { + listr = NULL + reglist = NULL + shiftslist = NULL + call rg_lsets (ls, REGIONS, "") + } else if (rg_lstati(ls, BZALGORITHM) == LS_PHOTOMETRY || rg_lstati (ls, + BSALGORITHM) == LS_PHOTOMETRY) { + listr = fntopnb (Memc[reference], NO) + if (fntlenb (listr) <= 0) + call error (0, "The reference photometry list is empty.") + reglist = fntopnb (Memc[freglist], NO) + if (fntlenb (listr) > 1 && fntlenb (listr) != imtlen (list1)) { + call eprintf ("The number of reference photometry files") + call eprintf (" and input images is not the same.\n") + call erract (EA_FATAL) + } + if (fntlenb(reglist) != imtlen(list1)) { + call eprintf ("The number of input photometry files and") + call eprintf ("images are not the same.\n") + call erract (EA_FATAL) + } + shiftslist = NULL + call rg_lsets (ls, REGIONS, Memc[freglist]) + } else { + listr = imtopen (Memc[reference]) + if (imtlen (listr) <= 0) + call error (0, "The reference image list is empty.") + if (imtlen (listr) > 1 && imtlen (listr) != imtlen (list1)) + call error (0, + "The number of reference and input images is not the same.") + iferr { + reglist = fntopnb (Memc[freglist], NO) + } then + reglist = NULL + if (Memc[shifts] == EOS) + shiftslist = NULL + else { + shiftslist = fntopnb (Memc[shifts], NO) + if (imtlen(listr) != fntlenb (shiftslist)) + call error (0, + "The number of shifts files and images is not the same.") + } + call rg_lsets (ls, REGIONS, Memc[freglist]) + } + + + # Close the output image list if it is empty. + if (imtlen (list2) <= 0) { + call imtclose (list2) + list2 = NULL + } + + # Check that the output image list is the same as the input image + # list. + if (list2 != NULL) { + if (imtlen (list1) != imtlen (list2)) + call error (0, + "The number of input and output images are not the same.") + } + + # Check that the record list is the same length as the input image + # list length. + if (reclist != NULL) { + if (fntlenb (reclist) != imtlen (list1)) + call error (0, + "Input image and record lists are not the same length") + } + + # Open the database file. + dformat = btoi (clgetb ("databasefmt")) + if (rg_lstati(ls, BZALGORITHM) == LS_FILE && rg_lstati(ls, + BSALGORITHM) == LS_FILE) { + if (dformat == YES) + db = dtmap (Memc[database], READ_ONLY) + else + db = open (Memc[database], READ_ONLY, TEXT_FILE) + } else if (clgetb ("append")) { + if (dformat == YES) + db = dtmap (Memc[database], APPEND) + else + db = open (Memc[database], NEW_FILE, TEXT_FILE) + } else if (access(Memc[database], 0, 0) == YES) { + call error (0, "The shifts database file already exists") + } else { + if (dformat == YES) + db = dtmap (Memc[database], NEW_FILE) + else + db = open (Memc[database], NEW_FILE, TEXT_FILE) + } + call rg_lsets (ls, DATABASE, Memc[database]) + + if ((rg_lstati(ls, BZALGORITHM) == LS_FILE || rg_lstati(ls, + BSALGORITHM) == LS_FILE) || (rg_lstati(ls, BZALGORITHM) == + LS_NUMBER && rg_lstati(ls, BSALGORITHM) == LS_NUMBER)) + interactive = NO + else + interactive = btoi (clgetb ("interactive")) + if (interactive == YES) { + call clgstr ("graphics", Memc[str], SZ_FNAME) + iferr (gd = gopen (Memc[str], NEW_FILE, STDGRAPH)) + gd = NULL + call clgstr ("display", Memc[str], SZ_FNAME) + iferr (id = gopen (Memc[str], APPEND, STDIMAGE)) + id = NULL + verbose = YES + } else { + gd = NULL + id = NULL + verbose = btoi (clgetb ("verbose")) + } + + # Initialize the reference image pointer. + imr = NULL + sfd = NULL + rpfd = NULL + ipfd = NULL + + # Do each set of input and output images. + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF)) { + + # Open the reference image and associated regions files + # if the correlation function is not file. + if (rg_lstati(ls, BZALGORITHM) == LS_PHOTOMETRY || rg_lstati(ls, + BSALGORITHM) == LS_PHOTOMETRY) { + if (fntgfnb(listr, Memc[str], SZ_FNAME) != EOF) { + if (rpfd != NULL) + call close (rpfd) + rpfd = open (Memc[str], READ_ONLY, TEXT_FILE) + call rg_lsets (ls, REFIMAGE, Memc[str]) + call rg_lsetr (ls, RGAIN, rg_lstatr (ls,GAIN)) + call rg_lsetr (ls, RREADNOISE, rg_lstatr (ls,READNOISE)) + nregions = rg_lrphot (rpfd, ls, 1, rg_lstati(ls, + MAXNREGIONS), YES) + if (nregions <= 0 && interactive == NO) + call error (0, + "The reference photometry file is empty.") + } + } else if ((rg_lstati(ls, BZALGORITHM) == LS_FILE || rg_lstati(ls, + BSALGORITHM) == LS_FILE) || (rg_lstati(ls,BZALGORITHM) == + LS_NUMBER && rg_lstati(ls,BSALGORITHM) == LS_NUMBER)) { + call rg_lsets (ls, REFIMAGE, "reference") + } else { + if (imtgetim(listr, Memc[str], SZ_FNAME) != EOF) { + if (imr != NULL) + call imunmap (imr) + imr = immap (Memc[str], READ_ONLY, 0) + if (IM_NDIM(imr) > 2) + call error (0, "Referenc image must be 1D or 2D") + call rg_lgain (imr, ls) + if (!IS_INDEFR(rg_lstatr(ls,GAIN))) + call rg_lsetr (ls, RGAIN, rg_lstatr (ls,GAIN)) + call rg_lrdnoise (imr, ls) + if (!IS_INDEFR(rg_lstatr(ls,READNOISE))) + call rg_lsetr (ls, RREADNOISE, rg_lstatr (ls,READNOISE)) + call rg_lsets (ls, REFIMAGE, Memc[str]) + nregions = rg_lregions (reglist, imr, ls, 1, NO) + if (nregions <= 0 && interactive == NO) + call error (0, "The regions list is empty.") + if (shiftslist != NULL) { + if (sfd != NULL) + call close (sfd) + if (fntgfnb (shiftslist, Memc[str], SZ_FNAME) == EOF) { + call rg_lsets (ls, SHIFTSFILE, "") + sfd = NULL + } else { + call rg_lsets (ls, SHIFTSFILE, Memc[str]) + sfd = open (Memc[str], READ_ONLY, TEXT_FILE) + } + } + } + } + + # Open the input image. + if (list2 == NULL && imr == NULL) + im1 = NULL + else { + im1 = immap (Memc[image1], READ_ONLY, 0) + if (IM_NDIM(im1) > 2) { + call error (0, "Input images must be 1D or 2D") + } else if (imr != NULL) { + if (IM_NDIM(im1) != IM_NDIM(imr)) { + call eprintf ("Input images must have same") + call eprintf (" dimensionality as reference images.\n") + call erract (EA_FATAL) + } + } + call rg_lgain (im1, ls) + if (!IS_INDEFR(rg_lstatr(ls,GAIN))) + call rg_lsetr (ls, IGAIN, rg_lstatr (ls, GAIN)) + call rg_lrdnoise (im1, ls) + if (!IS_INDEFR(rg_lstatr(ls,READNOISE))) + call rg_lsetr (ls, IREADNOISE, rg_lstatr (ls, READNOISE)) + } + call rg_lsets (ls, IMAGE, Memc[image1]) + + # Open the input photometry file. + if (rpfd != NULL) { + if (fntgfnb (reglist, Memc[str], SZ_FNAME) != EOF) { + ipfd = open (Memc[str], READ_ONLY, TEXT_FILE) + call rg_lsets (ls, PHOTFILE, Memc[str]) + } + nregions = rg_lrphot (ipfd, ls, 1, rg_lstati (ls, + NREGIONS), NO) + if (nregions <= 0 && interactive == NO) + call error (0, + "The input photometry file is empty.") + if (nregions < rg_lstati (ls, NREGIONS) && interactive == NO) { + call eprintf ("The input photometry file has fewer") + call eprintf (" objects than the reference photoemtry") + call eprintf (" file.\n") + call erract (EA_FATAL) + } + } + + # Open the output image if any. + if (list2 == NULL) { + im2 = NULL + Memc[image2] = EOS + } else if (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF) { + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + im2 = immap (Memc[image2], NEW_COPY, im1) + } else { + im2 = NULL + Memc[image2] = EOS + } + call rg_lsets (ls, OUTIMAGE, Memc[image2]) + + # Get the record names. + if (reclist == NULL) + call strcpy (Memc[image1], Memc[str], SZ_FNAME) + else if (fntgfnb (reclist, Memc[str], SZ_FNAME) == EOF) + call strcpy (Memc[image1], Memc[str], SZ_FNAME) + call rg_lsets (ls, RECORD, Memc[str]) + + # Compute the initial shift. + if (sfd != NULL) { + call rg_lgshift (sfd, ls) + } else { + call rg_lsetr (ls, SXSHIFT, rg_lstatr (ls, XSHIFT)) + call rg_lsetr (ls, SYSHIFT, rg_lstatr (ls, YSHIFT)) + } + + # Compute the scaling factors. + if (interactive == YES) { + stat = rg_liscale (imr, im1, im2, db, dformat, reglist, + rpfd, ipfd, sfd, ls, gd, id) + } else { + stat = rg_lscale (imr, im1, db, dformat, ls) + if (verbose == YES) { + if (rg_lstati(ls,BSALGORITHM) == LS_PHOTOMETRY || + rg_lstati(ls,BZALGORITHM) == LS_PHOTOMETRY) + call rg_lstats (ls, PHOTFILE, Memc[str1], SZ_FNAME) + else + call strcpy (Memc[image1], Memc[str1], SZ_FNAME) + call rg_lstats (ls, REFIMAGE, Memc[str], SZ_LINE) + call printf ( + "Average scale factors from %s to %s are %g %g\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str]) + call pargr (rg_lstatr (ls, TBSCALE)) + call pargr (rg_lstatr (ls, TBZERO)) + } + } + + # Scale the image. + if (im2 != NULL && stat == NO) { + if (verbose == YES) { + call printf ( + "\tScaling image %s to image %s ...\n") + call pargstr (Memc[image1]) + call pargstr (Memc[imtemp]) + } + call imseti (im1, IM_CANCEL, YES) + call rg_limscale (im1, im2, rg_lstatr (ls, TBSCALE), + rg_lstatr (ls, TBZERO)) + } + + # Close up the input and output images. + if (im1 != NULL) + call imunmap (im1) + if (im2 != NULL) { + call imunmap (im2) + if (stat == YES) + call imdelete (Memc[image2]) + else + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + + if (stat == YES) + break + } + + # Close up the files and images. + if (imr != NULL) + call imunmap (imr) + + # Close up the lists. + if (list1 != NULL) + call imtclose (list1) + if (listr != NULL) { + if (rg_lstati (ls, BZALGORITHM) == LS_PHOTOMETRY || rg_lstati(ls, + BSALGORITHM) == LS_PHOTOMETRY) + call fntclsb (listr) + else + call imtclose (listr) + } + if (list2 != NULL) + call imtclose (list2) + if (sfd != NULL) + call close (sfd) + if (rpfd != NULL) + call close (rpfd) + if (ipfd != NULL) + call close (ipfd) + if (shiftslist != NULL) + call fntclsb (shiftslist) + if (reglist != NULL) + call fntclsb (reglist) + if (reclist != NULL) + call fntclsb (reclist) + if (dformat == YES) + call dtunmap (db) + else + call close (db) + + # Close up the graphics and image display devices. + if (gd != NULL) + call gclose (gd) + if (id != NULL) + call gclose (id) + + # Free the matching structure. + call rg_lfree (ls) + + call sfree (sp) +end + + +# RG_LGAIN -- Fetch the gain parameter from the image header. + +procedure rg_lgain (im, ls) + +pointer im #I pointer to the input image +pointer ls #I pointer to the intensity matching structure + +int ip +pointer sp, key +real epadu +int ctor() +real imgetr() +errchk imgetr() + +begin + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + + call rg_lstats (ls, CCDGAIN, Memc[key], SZ_FNAME) + ip = 1 + if (ctor (Memc[key], ip, epadu) <= 0) { + iferr { + epadu = imgetr (im, Memc[key]) + } then { + epadu = INDEFR + call eprintf ("Warning: Image %s Keyword %s not found.\n") + call pargstr (IM_HDRFILE(im)) + call pargstr (Memc[key]) + } + } else + epadu = INDEFR + if (IS_INDEFR(epadu) || epadu <= 0.0) + call rg_lsetr (ls, GAIN, INDEFR) + Else + call rg_lsetr (ls, GAIN, epadu) + + call sfree (sp) +end + + +# LG_LRDNOISE -- Fetch the readout noise from the image header. + +procedure rg_lrdnoise (im, ls) + +pointer im #I pointer to the input image +pointer ls #I pointer to the intensity matching structure + +int ip +pointer sp, key +real rdnoise +int ctor() +real imgetr() +errchk imgetr() + +begin + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + + call rg_lstats (ls, CCDREAD, Memc[key], SZ_FNAME) + ip = 1 + if (ctor (Memc[key], ip, rdnoise) <= 0) { + iferr { + rdnoise = imgetr (im, Memc[key]) + } then { + rdnoise = INDEFR + call eprintf ("Warning: Image %s Keyword %s not found.\n") + call pargstr (IM_HDRFILE(im)) + call pargstr (Memc[key]) + } + } else + rdnoise = INDEFR + if (IS_INDEFR(rdnoise) || rdnoise <= 0.0) + call rg_lsetr (ls, READNOISE, INDEFR) + else + call rg_lsetr (ls, READNOISE, rdnoise) + + call sfree (sp) +end + + +# RG_LGSHIFT -- Read the x and y shifts from a file + +procedure rg_lgshift (fd, ls) + +int fd #I input shifts file descriptor +pointer ls #I pointer to the intensity matching structure + +real xshift, yshift +int fscan(), nscan() + +begin + xshift = 0.0 + yshift = 0.0 + + while (fscan(fd) != EOF) { + call gargr (xshift) + call gargr (yshift) + if (nscan() >= 2) + break + xshift = 0.0 + yshift = 0.0 + } + + call rg_lsetr (ls, SXSHIFT, xshift) + call rg_lsetr (ls, SYSHIFT, yshift) +end + + +# RG_LIMSCALE -- Linearly scale the input image. + +procedure rg_limscale (im1, im2, bscale, bzero) + +pointer im1 #I pointer to the input image +pointer im2 #I pointer to the output image +real bscale #I the bscale value +real bzero #I the bzero value + +int ncols +pointer sp, v1, v2, buf1, buf2 +int imgnlr(), impnlr() + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + + ncols = IM_LEN(im1,1) + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + while (imgnlr (im1, buf1, Meml[v1]) != EOF) { + if (impnlr (im2, buf2, Meml[v2]) != EOF) + call altmr (Memr[buf1], Memr[buf2], ncols, bscale, bzero) + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/listmatch/mkpkg b/pkg/images/immatch/src/listmatch/mkpkg new file mode 100644 index 00000000..1d9f42c5 --- /dev/null +++ b/pkg/images/immatch/src/listmatch/mkpkg @@ -0,0 +1,12 @@ +# Make the XYXYMATCH/IMCENTROID tasks + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + + +libpkg.a: + t_imctroid.x <error.h> <mach.h> <imhdr.h> + t_xyxymatch.x <fset.h> "../../../lib/xyxymatch.h" + ; diff --git a/pkg/images/immatch/src/listmatch/t_imctroid.x b/pkg/images/immatch/src/listmatch/t_imctroid.x new file mode 100644 index 00000000..157e41ca --- /dev/null +++ b/pkg/images/immatch/src/listmatch/t_imctroid.x @@ -0,0 +1,1016 @@ +include <fset.h> +include <imhdr.h> +include <error.h> +include <mach.h> + +define LEN_CP 32 # center structure pointer + +# task parameters +define SMALLBOX Memi[($1)] +define BIGBOX Memi[($1)+1] +define VERBOSE Memi[($1)+2] +define NEGATIVE Memi[($1)+3] +define BACKGROUND Memr[P2R(($1)+4)] +define LO_THRESH Memr[P2R(($1)+5)] +define HI_THRESH Memr[P2R(($1)+6)] +define MAX_TRIES Memi[($1)+7] +define TOL Memi[($1)+8] +define MAX_SHIFT Memr[P2R(($1)+9)] + +# other scalars +define IM Memi[($1)+10] +define BOXSIZE Memi[($1)+11] +define BACK_LOCAL Memr[P2R(($1)+12)] +define LO_LOCAL Memr[P2R(($1)+13)] +define HI_LOCAL Memr[P2R(($1)+14)] +define NIMAGES Memi[($1)+15] +define NCOORDS Memi[($1)+16] + +# expensive, but the indexing isn't done excessively many times +define OFF1D (($1)-1) +define OFF2D ((($2)-1)*NCOORDS($1)+(($3)-1)) + +# vectors and matrices +define XINIT_PT Memi[($1)+20] # need space for NCOORDS of these +define YINIT_PT Memi[($1)+21] +define XINIT Memr[XINIT_PT($1)+OFF1D($2)] +define YINIT Memr[YINIT_PT($1)+OFF1D($2)] + +define XSHIFT_PT Memi[($1)+22] # space for NIMAGES of these +define YSHIFT_PT Memi[($1)+23] +define XSHIFT Memr[XSHIFT_PT($1)+OFF1D($2)] +define YSHIFT Memr[YSHIFT_PT($1)+OFF1D($2)] + +define XSIZE_PT Memi[($1)+24] # space for NIMAGES+1 +define YSIZE_PT Memi[($1)+25] +define XSIZE Memr[XSIZE_PT($1)+OFF1D($2)] +define YSIZE Memr[YSIZE_PT($1)+OFF1D($2)] + +define XCENTER_PT Memi[($1)+26] # space for (NIMAGES+1)*NCOORDS +define YCENTER_PT Memi[($1)+27] +define XCENTER Memr[XCENTER_PT($1)+OFF2D($1,$2,$3)] +define YCENTER Memr[YCENTER_PT($1)+OFF2D($1,$2,$3)] + +define XSIGMA_PT Memi[($1)+28] +define YSIGMA_PT Memi[($1)+29] +define XSIGMA Memr[XSIGMA_PT($1)+OFF2D($1,$2,$3)] +define YSIGMA Memr[YSIGMA_PT($1)+OFF2D($1,$2,$3)] + +define REJECTED_PT Memi[($1)+30] +define REJECTED Memi[REJECTED_PT($1)+OFF2D($1,$2,$3)] + + +# list "template" structure, currently just read the file +define LEN_LP 2 + +define LP_FD Memi[($1)] +define LP_LEN Memi[($1)+1] + +# T_IMCENTROID -- Find the centroids of a list of sources in a list of +# images and compute the average shifts relative to a reference image. + +procedure t_imcentroid() + +pointer imlist, coordlist, shiftlist +pointer img, ref, refer, cp, im, sp +int nimages, ncoords, nshifts, ncentered, i, j +real x, y, junk +bool error_seen, firsttime + +pointer imtopenp(), immap(), ia_openp2r(), ia_init() +int imtlen(), imtgetim(), ia_len(), ia_center(), strmatch() + +errchk imtopenp, immap, imunmap +errchk ia_init, ia_openp2r, ia_len, ia_close, ia_center + +begin + call smark (sp) + call salloc (img, SZ_FNAME, TY_CHAR) + call salloc (refer, SZ_FNAME, TY_CHAR) + + error_seen = false + imlist = NULL + coordlist = NULL + shiftlist = NULL + ref = NULL + cp = NULL + + iferr { + # Flush on new line to avoid eprint output from appear + # in the middle of regular output. + call fseti (STDOUT, F_FLUSHNL, YES) + + # Open the input image list. + imlist = imtopenp ("input") + nimages = imtlen (imlist) + if (nimages <= 0) + call error (1, "No images specified") + + # Get the reference image and check name for whitespace. + call clgstr ("reference", Memc[refer], SZ_FNAME) + if (Memc[refer] != EOS && strmatch (Memc[refer], "^#$") == 0) + iferr (ref = immap (Memc[refer], READ_ONLY, 0)) { + ref = NULL + call error (1, "Reference not found") + } + + # Open the coordinate list. + coordlist = ia_openp2r ("coords") + ncoords = ia_len (coordlist) + if (ncoords <= 0) + call error (1, "No coordinates found") + + # Open the shifts file. + shiftlist = ia_openp2r ("shifts") + nshifts = ia_len (shiftlist) + if (nshifts <= 0) + call ia_close (shiftlist) + else if (nshifts != nimages) + call error (1, "Number of shifts doesn't match images") + + # Initialize the centering structure. + cp = ia_init (shiftlist, nimages, coordlist, ncoords) + + if (ref == NULL) + VERBOSE(cp) = YES + + if (VERBOSE(cp) == YES) { + call printf ("#Coords%16tImage X-center Err") + call printf (" Y-center Err Num\n") + call flush (STDOUT) + } + + # Loop over all the images + ncentered = 0 + for (i=1; imtgetim (imlist, Memc[img], SZ_FNAME) != EOF; i=i+1) { + im = immap (Memc[img], READ_ONLY, 0) + IM(cp) = im + + if (IM_NDIM(im) != 2) { + call eprintf ("%s: ") + call pargstr (Memc[img]) + call error (1, "Image is not 2 dimensional") + } + + XSIZE(cp,i) = real (IM_LEN(im,1)) + YSIZE(cp,i) = real (IM_LEN(im,2)) + + if (nshifts == 0) { + BOXSIZE(cp) = BIGBOX(cp) + if (ia_center (cp, XINIT(cp,1), YINIT(cp,1), x, y, + junk, junk) == ERR) + call error (1, "Problem with coarse centering") + XSHIFT(cp,i) = XINIT(cp,1) - x + YSHIFT(cp,i) = YINIT(cp,1) - y + } + + firsttime = true + do j = 1, ncoords { + x = XINIT(cp,j) - XSHIFT(cp,i) + y = YINIT(cp,j) - YSHIFT(cp,i) + + if (x < 1 || x > XSIZE(cp,i) || y < 1 || y > YSIZE(cp,i)) { + REJECTED(cp,i,j) = YES + next + } + + BOXSIZE(cp) = SMALLBOX(cp) + if (ia_center (cp, x, y, XCENTER(cp,i,j), YCENTER(cp,i,j), + XSIGMA(cp,i,j), YSIGMA(cp,i,j)) == ERR) { + REJECTED(cp,i,j) = YES + next + } + + if (abs (XCENTER(cp,i,j) - x) > MAX_SHIFT(cp)) { + REJECTED(cp,i,j) = YES + next + } + if (abs (YCENTER(cp,i,j) - y) > MAX_SHIFT(cp)) { + REJECTED(cp,i,j) = YES + next + } + + if (firsttime) + firsttime = false + + if (VERBOSE(cp) == YES) { + call printf ( + "%20s %9.3f (%.3f) %9.3f (%.3f) %4d\n") + call pargstr (Memc[img]) + call pargr (XCENTER(cp,i,j)) + call pargr (XSIGMA(cp,i,j)) + call pargr (YCENTER(cp,i,j)) + call pargr (YSIGMA(cp,i,j)) + call pargi (j) + } + } + + if (firsttime) { + call eprintf ("Warning: no sources centered in %s\n") + call pargstr (Memc[img]) + call flush (STDERR) + } else + ncentered = ncentered + 1 + + if (VERBOSE(cp) == YES) { + call printf ("\n") + call flush (STDOUT) + } + + call imunmap (im) + } + + # Measure the reference coordinates if any. + if (ref != NULL) { + IM(cp) = ref + + if (IM_NDIM(ref) != 2) { + call eprintf ("%s: ") + call pargstr (Memc[refer]) + call error (1, "Reference image is not 2 dimensional") + } + + XSIZE(cp,nimages+1) = real (IM_LEN(ref,1)) + YSIZE(cp,nimages+1) = real (IM_LEN(ref,2)) + + firsttime = true + do j = 1, ncoords { + x = XINIT(cp,j) + y = YINIT(cp,j) + + if (x < 1 || x > XSIZE(cp,nimages+1) || + y < 1 || y > YSIZE(cp,nimages+1)) { + REJECTED(cp,nimages+1,j) = YES + next + } + + BOXSIZE(cp) = SMALLBOX(cp) + if (ia_center (cp, x, y, XCENTER(cp,nimages+1,j), + YCENTER(cp,nimages+1,j), XSIGMA(cp,nimages+1,j), + YSIGMA(cp,nimages+1,j)) == ERR) { + REJECTED(cp,nimages+1,j) = YES + next + } + + if (abs (XCENTER(cp,nimages+1,j) - x) > MAX_SHIFT(cp)) { + REJECTED(cp,nimages+1,j) = YES + next + } + if (abs (YCENTER(cp,nimages+1,j) - y ) > MAX_SHIFT(cp)) { + REJECTED(cp,nimages+1,j) = YES + next + } + + if (firsttime) { + if (VERBOSE(cp) == YES) { + call printf ( + "#Refcoords%12tReference X-center Err") + call printf (" Y-center Err Num\n") + } + firsttime = false + } + + if (VERBOSE(cp) == YES) { + call printf ( + "%20s %9.3f (%0.3f) %9.3f (%.3f) %4d\n") + call pargstr (Memc[refer]) + call pargr (XCENTER(cp,nimages+1,j)) + call pargr (XSIGMA(cp,nimages+1,j)) + call pargr (YCENTER(cp,nimages+1,j)) + call pargr (YSIGMA(cp,nimages+1,j)) + call pargi (j) + } + } + + if (firsttime) { + call eprintf ("Warning: no sources centered in reference\n") + call flush (STDERR) + + } else { + if (VERBOSE(cp) == YES) { + call printf ("\n") + call flush (STDOUT) + } + + call imtrew (imlist) + call ia_stats (cp, imlist) + + if (ncentered > 1) + call ia_trim (cp) + } + } + + } then + error_seen = true + + call ia_free (cp) + + if (shiftlist != NULL) + call ia_close (shiftlist) + if (ref != NULL) + call imunmap (ref) + if (coordlist != NULL) + call ia_close (coordlist) + if (imlist != NULL) + call imtclose (imlist) + + call sfree (sp) + + if (error_seen) + call erract (EA_WARN) +end + + +# IA_INIT -- Initialize the centering structure. + +pointer procedure ia_init (shiftlist, nshifts, coordlist, ncoords) + +pointer shiftlist #I shift "template" pointer +int nshifts #I number of shifts in list (or # images) +pointer coordlist #I coordinate "template" pointer +int ncoords #I number of coordinates in list + +pointer cp +int boxsize, i +real x, y + +int clgeti(), btoi(), ia_get2r() +real clgetr() +bool clgetb() + +errchk ia_get2r + +begin + call calloc (cp, LEN_CP, TY_STRUCT) + + boxsize = clgeti ("boxsize") + if (mod (boxsize, 2) == 0) { + boxsize = boxsize + 1 + call eprintf ("Warning: boxsize must be odd, using %d\n") + call pargi (boxsize) + } + SMALLBOX(cp) = (boxsize - 1) / 2 + + if (shiftlist == NULL) { + boxsize = clgeti ("bigbox") + if (mod (boxsize, 2) == 0) { + boxsize = boxsize + 1 + call eprintf ("Warning: bigbox must be odd, using %d\n") + call pargi (boxsize) + } + BIGBOX(cp) = (boxsize - 1) / 2 + } + + NEGATIVE(cp) = btoi (clgetb ("negative")) + BACKGROUND(cp) = clgetr ("background") + + x = clgetr ("lower") + y = clgetr ("upper") + + if (IS_INDEFR(x) || IS_INDEFR(y)) { + LO_THRESH(cp) = x + HI_THRESH(cp) = y + } else { + LO_THRESH(cp) = min (x, y) + HI_THRESH(cp) = max (x, y) + } + + MAX_TRIES(cp) = max (clgeti ("niterate"), 2) + TOL(cp) = abs (clgeti ("tolerance")) + MAX_SHIFT(cp) = clgetr ("maxshift") + if (IS_INDEFR(MAX_SHIFT(cp))) + MAX_SHIFT(cp) = MAX_REAL + else + MAX_SHIFT(cp) = abs (MAX_SHIFT(cp)) + VERBOSE(cp) = btoi (clgetb ("verbose")) + + IM(cp) = NULL + + NIMAGES(cp) = nshifts + NCOORDS(cp) = ncoords + + call malloc (XINIT_PT(cp), ncoords, TY_REAL) + call malloc (YINIT_PT(cp), ncoords, TY_REAL) + call malloc (XSHIFT_PT(cp), nshifts, TY_REAL) + call malloc (YSHIFT_PT(cp), nshifts, TY_REAL) + call malloc (XSIZE_PT(cp), nshifts+1, TY_REAL) + call malloc (YSIZE_PT(cp), nshifts+1, TY_REAL) + call malloc (XCENTER_PT(cp), (nshifts+1)*ncoords, TY_REAL) + call malloc (YCENTER_PT(cp), (nshifts+1)*ncoords, TY_REAL) + call malloc (XSIGMA_PT(cp), (nshifts+1)*ncoords, TY_REAL) + call malloc (YSIGMA_PT(cp), (nshifts+1)*ncoords, TY_REAL) + call calloc (REJECTED_PT(cp), (nshifts+1)*ncoords, TY_INT) + + for (i=1; ia_get2r (coordlist, x, y) != EOF; i=i+1) { + if (i > ncoords) + call error (1, "problem reading coordinate file") + XINIT(cp,i) = x + YINIT(cp,i) = y + } + + for (i=1; ia_get2r (shiftlist, x, y) != EOF; i=i+1) { + if (i > nshifts) + call error (1, "problem reading shifts file") + XSHIFT(cp,i) = x + YSHIFT(cp,i) = y + } + + return (cp) +end + + +# IA_FREE -- Free the structure pointer. + +procedure ia_free (cp) + +pointer cp #O center structure pointer + +begin + if (cp == NULL) + return + + if (REJECTED_PT(cp) != NULL) + call mfree (REJECTED_PT(cp), TY_INT) + if (XSIGMA_PT(cp) != NULL) + call mfree (XSIGMA_PT(cp), TY_REAL) + if (YSIGMA_PT(cp) != NULL) + call mfree (YSIGMA_PT(cp), TY_REAL) + if (XCENTER_PT(cp) != NULL) + call mfree (XCENTER_PT(cp), TY_REAL) + if (YCENTER_PT(cp) != NULL) + call mfree (YCENTER_PT(cp), TY_REAL) + if (XSIZE_PT(cp) != NULL) + call mfree (XSIZE_PT(cp), TY_REAL) + if (YSIZE_PT(cp) != NULL) + call mfree (YSIZE_PT(cp), TY_REAL) + if (XSHIFT_PT(cp) != NULL) + call mfree (XSHIFT_PT(cp), TY_REAL) + if (YSHIFT_PT(cp) != NULL) + call mfree (YSHIFT_PT(cp), TY_REAL) + if (XINIT_PT(cp) != NULL) + call mfree (XINIT_PT(cp), TY_REAL) + if (YINIT_PT(cp) != NULL) + call mfree (YINIT_PT(cp), TY_REAL) + + call mfree (cp, TY_STRUCT) + cp = NULL # just in case... +end + + +# IA_CENTER -- Compute star center using MPC algorithm. + +int procedure ia_center (cp, xinit, yinit, xcenter, ycenter, xsigma, ysigma) + +pointer cp #I center structure pointer +real xinit, yinit #I initial x and y coordinates +real xcenter, ycenter #O centered x and y coordinates +real xsigma, ysigma #O centering errors + +int x1, x2, y1, y2, nx, ny, try +pointer im, buf, xbuf, ybuf, sp +real xold, yold, xnew, ynew +bool converged + +pointer imgs2r() +real ia_ctr1d() + +errchk imgs2r, ia_threshold, ia_rowsum, ia_colsum, ia_ctr1d + +begin + im = IM(cp) + xold = xinit + yold = yinit + converged = false + + do try = 1, MAX_TRIES(cp) { + x1 = max (nint(xold) - BOXSIZE(cp), 1) + x2 = min (nint(xold) + BOXSIZE(cp), IM_LEN(im,1)) + y1 = max (nint(yold) - BOXSIZE(cp), 1) + y2 = min (nint(yold) + BOXSIZE(cp), IM_LEN(im,2)) + + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + + # inside the loop in case we're near an edge + call smark (sp) + call salloc (xbuf, nx, TY_REAL) + call salloc (ybuf, ny, TY_REAL) + + iferr { + buf = imgs2r (im, x1, x2, y1, y2) + + call ia_threshold (cp, Memr[buf], nx*ny) + call ia_rowsum (cp, Memr[buf], Memr[xbuf], nx, ny) + call ia_colsum (cp, Memr[buf], Memr[ybuf], nx, ny) + + xnew = x1 + ia_ctr1d (Memr[xbuf], nx, xsigma) + ynew = y1 + ia_ctr1d (Memr[ybuf], ny, ysigma) + } then { + call sfree (sp) + call erract (EA_WARN) + return (ERR) + } + + call sfree (sp) + + if (abs (nint(xnew) - nint(xold)) <= TOL(cp) && + abs (nint(ynew) - nint(yold)) <= TOL(cp)) { + + converged = true + break + } + + xold = xnew + yold = ynew + } + + if (converged) { + xcenter = xnew + ycenter = ynew + return (OK) + } else { + call eprintf ("Warning: failed to converge near (%d,%d)\n") + call pargi (nint (xinit)) + call pargi (nint (yinit)) + call flush (STDERR) + return (ERR) + } +end + + +# IA_THRESHOLD -- Find the low and high thresholds for the subraster. + +procedure ia_threshold (cp, raster, npix) + +pointer cp #I center structure pointer +real raster[ARB] #I 2-D subraster +int npix #I size of the (apparently) 1-D subraster + +real lo, hi, junk + +int awvgr() + +errchk alimr, awvgr + +begin + # use the local data min or max for thresholds that are INDEF. + if (IS_INDEFR(LO_THRESH(cp)) || IS_INDEFR(HI_THRESH(cp))) + call alimr (raster, npix, lo, hi) + if (! IS_INDEFR(LO_THRESH(cp))) + lo = LO_THRESH(cp) + if (! IS_INDEFR(HI_THRESH(cp))) + hi = HI_THRESH(cp) + + if (IS_INDEFR(BACKGROUND(cp))) { + if (awvgr (raster, npix, BACK_LOCAL(cp), junk, lo, hi) <= 0) + call error (1, "no pixels between thresholds") + } else + BACK_LOCAL(cp) = BACKGROUND(cp) + + if (NEGATIVE(cp) == YES) { + LO_LOCAL(cp) = lo + HI_LOCAL(cp) = min (hi, BACK_LOCAL(cp)) + } else { + LO_LOCAL(cp) = max (lo, BACK_LOCAL(cp)) + HI_LOCAL(cp) = hi + } +end + + +# IA_ROWSUM -- Sum all rows in a raster, subject to the thresholds, the +# background, and other parameters. + +procedure ia_rowsum (cp, raster, row, nx, ny) + +pointer cp #I center structure pointer +real raster[nx,ny] #I 2-D subraster +real row[ARB] #O 1-D squashed row vector +int nx, ny #I dimensions of the subraster + +int i, j +real lo, hi, back, pix + +begin + call aclrr (row, nx) + + back = BACK_LOCAL(cp) + lo = LO_LOCAL(cp) + hi = HI_LOCAL(cp) + + do j = 1, ny + do i = 1, nx { + pix = raster[i,j] + if (lo <= pix && pix <= hi) + row[i] = row[i] + pix - back + } + + if (NEGATIVE(cp) == YES) + call adivkr (row, -real(ny), row, nx) + else + call adivkr (row, real(ny), row, nx) + + # recycle lo (and hi) + call alimr (row, nx, lo, hi) + if (lo < 0.) + call error (1, "Negative value in marginal row\n") +end + + +# IA_COLSUM -- Sum all columns in a raster, subject to the thresholds, the +# background, and other parameters. + +procedure ia_colsum (cp, raster, col, nx, ny) + +pointer cp #I center structure pointer +real raster[nx,ny] #I 2-D subraster +real col[ARB] #O 1-D squashed col vector +int nx, ny #I dimensions of the subraster + +int i, j +real lo, hi, back, pix + +begin + call aclrr (col, ny) + + back = BACK_LOCAL(cp) + lo = LO_LOCAL(cp) + hi = HI_LOCAL(cp) + + do j = 1, ny + do i = 1, nx { + pix = raster[i,j] + if (lo <= pix && pix <= hi) + col[j] = col[j] + pix - back + } + + if (NEGATIVE(cp) == YES) + call adivkr (col, -real(nx), col, ny) + else + call adivkr (col, real(nx), col, ny) + + # recycle lo (and hi) + call alimr (col, ny, lo, hi) + if (lo < 0.) + call error (1, "Negative value in marginal column\n") +end + + +# IA_CNTR1D -- Compute the the first moment. + +real procedure ia_ctr1d (a, npix, err) + +real a[ARB] #I marginal vector +int npix #I size of the vector +real err #O error in the centroid + +real centroid, pix, sumi, sumix, sumix2 +int i + +bool fp_equalr() + +begin + sumi = 0. + sumix = 0. + sumix2 = 0. + + do i = 1, npix { + pix = a[i] + sumi = sumi + pix + sumix = sumix + pix * (i-1) + sumix2 = sumix2 + pix * (i-1) ** 2 + } + + if (fp_equalr (sumi, 0.)) + call error (1, "zero marginal vector") + + else { + centroid = sumix / sumi + err = sumix2 / sumi - centroid ** 2 + if (err > 0.) + err = sqrt (err / sumi) + else + err = 0. + } + + return (centroid) +end + + +# IA_OPENP2R -- Open a list file from which two real values per line +# are expected. + +pointer procedure ia_openp2r (param) + +char param[ARB] #I parameter name + +int fd, length +pointer lp, fname, sp +real x1, x2 + +int open(), fscan(), nscan(), strmatch() + +errchk open + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + call clgstr (param, Memc[fname], SZ_FNAME) + + # Whitespace in the name ? + if (strmatch (Memc[fname], "^#$") != 0) { + call sfree (sp) + return (NULL) + } + + # This should be replaced by some template mechanism. + ifnoerr (fd = open (Memc[fname], READ_ONLY, TEXT_FILE)) { + length = 0 + while (fscan (fd) != EOF) { + call gargr (x1) + call gargr (x2) + + switch (nscan()) { + case 2: + length = length + 1 + case 1: + call error (1, "Reading file, only one value on line") + default: + # read another line + } + } + call seek (fd, BOF) + } else { + fd = NULL + length = 0 + } + + call sfree (sp) + + call malloc (lp, LEN_LP, TY_STRUCT) + LP_FD(lp) = fd + LP_LEN(lp) = length + + return (lp) +end + + +# IA_LEN -- Return the length of a list file, given its descriptor. + +int procedure ia_len (lp) + +pointer lp #I list file descriptor + +begin + if (lp == NULL) + return (0) + else + return (LP_LEN(lp)) +end + + +# IA_GET2R -- Get two real numbers from the next line of the list file. + +int procedure ia_get2r (lp, x1, x2) + +pointer lp #I list file descriptor +real x1, x2 #O values to read + +int fscan(), nscan() + +begin + if (lp == NULL) { + x1 = INDEFR + x2 = INDEFR + return (EOF) + } + + while (fscan (LP_FD(lp)) != EOF) { + call gargr (x1) + call gargr (x2) + + switch (nscan()) { + case 2: + return (2) + case 1: + call error (1, "only one value on line") + default: + # read another line + } + } + + x1 = INDEFR + x2 = INDEFR + return (EOF) +end + + +# IA_CLOSE -- Close a list file descriptor. + +procedure ia_close (lp) + +pointer lp #I list file descriptor + +errchk close + +begin + if (lp == NULL) + return + + if (LP_FD(lp) != NULL) + call close (LP_FD(lp)) + + call mfree (lp, TY_STRUCT) + lp = NULL # just in case... +end + + +# IA_STATS -- Compute the x and y shifts. + +procedure ia_stats (cp, imlist) + +pointer cp #I center structure pointer +pointer imlist #I image template (for labeling) + +real xshift, yshift, xsum, ysum +real xsum2, ysum2, xsig2, ysig2 +real xvar, yvar, xerr, yerr, xprop, yprop +int nim, ncoo, nsources, i, j +pointer img, sp +bool firsttime + +int imtgetim() + +begin + call smark (sp) + call salloc (img, SZ_FNAME, TY_CHAR) + + nim = NIMAGES(cp) + ncoo = NCOORDS(cp) + + firsttime = true + for (i=1; imtgetim (imlist, Memc[img], SZ_FNAME) != EOF; i=i+1) { + xsum = 0. + ysum = 0. + xsum2 = 0. + ysum2 = 0. + xsig2 = 0. + ysig2 = 0. + nsources = 0 + + do j = 1, ncoo { + if (REJECTED(cp,i,j) == YES || REJECTED(cp,nim+1,j) == YES) + next + + xshift = XCENTER(cp,nim+1,j) - XCENTER(cp,i,j) + yshift = YCENTER(cp,nim+1,j) - YCENTER(cp,i,j) + + xsum = xsum + xshift + ysum = ysum + yshift + + # internal errors + xsum2 = xsum2 + xshift*xshift + ysum2 = ysum2 + yshift*yshift + + xsig2 = xsig2 + XSIGMA(cp,nim+1,j)**2 + XSIGMA(cp,i,j)**2 + ysig2 = ysig2 + YSIGMA(cp,nim+1,j)**2 + YSIGMA(cp,i,j)**2 + + nsources = nsources + 1 + } + + if (nsources == 0) { + XSHIFT(cp,i) = INDEFR + YSHIFT(cp,i) = INDEFR + next + } + + XSHIFT(cp,i) = xsum / nsources + YSHIFT(cp,i) = ysum / nsources + + if (nsources > 1) { + xvar = (nsources*xsum2 - xsum*xsum) / (nsources * (nsources-1)) + yvar = (nsources*ysum2 - ysum*ysum) / (nsources * (nsources-1)) + xerr = sqrt (max (xvar/nsources, 0.)) + yerr = sqrt (max (yvar/nsources, 0.)) + } else { + xerr = INDEFR + yerr = INDEFR + } + + xprop = sqrt (max (xsig2, 0.)) / nsources + yprop = sqrt (max (ysig2, 0.)) / nsources + + if (firsttime) { + call printf ("#Shifts%16tImage X-shift Err ") + call printf ("Y-shift Err N Internal\n") + firsttime = false + } + + call printf ( + "%20s %8.3f (%.3f) %8.3f (%.3f) %4d (%.3f,%.3f)\n") + call pargstr (Memc[img]) + call pargr (XSHIFT(cp,i)) + call pargr (xprop) + call pargr (YSHIFT(cp,i)) + call pargr (yprop) + call pargi (nsources) + call pargr (xerr) + call pargr (yerr) + } + + call flush (STDOUT) + call sfree (sp) +end + + +# IA_TRIM -- Compute the trim section. + +procedure ia_trim (cp) + +pointer cp #I center structure pointer + +real xlo, xhi, ylo, yhi, xmin, ymin +int ixlo, ixhi, iylo, iyhi, ixlonew, ixhinew, iylonew, iyhinew, i +int vxlo, vxhi, vylo, vyhi # vignetted versions +bool firsttime + +begin + firsttime = true + do i = 1, NIMAGES(cp) { + + if (IS_INDEFR(XSHIFT(cp,i)) || IS_INDEFR(YSHIFT(cp,i))) + next + + # Compute limits. + xlo = 1. + XSHIFT(cp,i) + ylo = 1. + YSHIFT(cp,i) + xhi = XSIZE(cp,i) + XSHIFT(cp,i) + yhi = YSIZE(cp,i) + YSHIFT(cp,i) + + ixlonew = int (xlo) + if (xlo > ixlonew) # round up + ixlonew = ixlonew + 1 + + ixhinew = int (xhi) + if (xhi < ixhinew) # round down + ixhinew = ixhinew - 1 + + iylonew = int (ylo) # round up + if (ylo > iylonew) + iylonew = iylonew + 1 + + iyhinew = int (yhi) # round down + if (yhi < iyhinew) + iyhinew = iyhinew - 1 + + if (firsttime) { + ixlo = ixlonew + ixhi = ixhinew + iylo = iylonew + iyhi = iyhinew + + xmin = XSIZE(cp,i) + ymin = YSIZE(cp,i) + + firsttime = false + } else { + ixlo = max (ixlo, ixlonew) + ixhi = min (ixhi, ixhinew) + iylo = max (iylo, iylonew) + iyhi = min (iyhi, iyhinew) + + xmin = min (XSIZE(cp,i), xmin) + ymin = min (YSIZE(cp,i), ymin) + } + } + + # Don't bother to complain. + if (firsttime) + return + + call printf ("\n") + + # Vignetting is possible downstream since imshift and other tasks + # preserve the size of the input image. + + vxlo = max (1, min (ixlo, int(xmin))) + vxhi = max (1, min (ixhi, int(xmin))) + vylo = max (1, min (iylo, int(ymin))) + vyhi = max (1, min (iyhi, int(ymin))) + if (vxlo != ixlo || vxhi != ixhi || vylo != iylo || vyhi != iyhi) { + call eprintf ("#Vignette_Section = [%d:%d,%d:%d]\n") + call pargi (vxlo) + call pargi (vxhi) + call pargi (vylo) + call pargi (vyhi) + } + + # Output the trim section. + call printf ("#Trim_Section = [%d:%d,%d:%d]\n") + call pargi (ixlo) + call pargi (ixhi) + call pargi (iylo) + call pargi (iyhi) + + call flush (STDOUT) +end diff --git a/pkg/images/immatch/src/listmatch/t_xyxymatch.x b/pkg/images/immatch/src/listmatch/t_xyxymatch.x new file mode 100644 index 00000000..1c8a16c5 --- /dev/null +++ b/pkg/images/immatch/src/listmatch/t_xyxymatch.x @@ -0,0 +1,406 @@ +include <fset.h> +include "../../../lib/xyxymatch.h" + +# T_XYXYMATCH -- This task computes the intersection of a set of +# of coordinate lists with a reference coordinate list. The output is +# the set of objects common to both lists. In its simplest form LINXYMATCH +# uses a matching tolerance to generate the common list. Alternatively +# XYXYMATCH can use coordinate transformation information derived from the +# positions of one to three stars common to both lists, a sorting algorithm, +# and a matching tolerance to generate the common list. A more sophisticated +# pattern matching algorithm is also available which requires no coordinate +# transformation input from the user but is expensive computationally. + +procedure t_xyxymatch() + +bool interactive, verbose +int ilist, rlist, olist, rfd, rpfd, ifd, ofd +int xcol, ycol, xrefcol, yrefcol, maxntriangles, nreftie, nintie +int ntie, match, nrefstars, nliststars, ninter, nrmaxtri, nreftri +int ninmaxtri, nintri, ntrefstars, ntliststars, nreject +pointer sp, inname, refname, outname, refpoints, str, xreftie, yreftie +pointer xintie, yintie, coeff, xref, yref, rlineno, rsindex, reftri, reftrirat +pointer xlist, ylist, listindex, ilineno, xtrans, ytrans, intri, intrirat +pointer xformat, yformat +real tolerance, separation, xin, yin, xmag, ymag, xrot, yrot, xout, yout +real ratio + +bool clgetb() +int clpopnu(), clplen(), clgeti(), clgfil(), open(), clgwrd() +int rg_getreftie(), rg_lincoeff(), fstati(), rg_rdxyi(), rg_sort() +int rg_intersection(), rg_factorial(), rg_triangle(), rg_match() +int rg_mlincoeff() +real clgetr() + +begin + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate working space. + call smark (sp) + call salloc (inname, SZ_FNAME, TY_CHAR) + call salloc (refname, SZ_FNAME, TY_CHAR) + call salloc (outname, SZ_FNAME, TY_CHAR) + call salloc (refpoints, SZ_FNAME, TY_CHAR) + call salloc (xreftie, MAX_NTIE, TY_REAL) + call salloc (yreftie, MAX_NTIE, TY_REAL) + call salloc (xintie, MAX_NTIE, TY_REAL) + call salloc (yintie, MAX_NTIE, TY_REAL) + call salloc (coeff, MAX_NCOEFF, TY_REAL) + call salloc (xformat, SZ_FNAME, TY_CHAR) + call salloc (yformat, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Get the input, output, and reference lists. + ilist = clpopnu ("input") + rlist = clpopnu ("reference") + olist = clpopnu ("output") + tolerance = clgetr ("tolerance") + call clgstr ("refpoints", Memc[refpoints], SZ_FNAME) + + # Check the input and output file lengths. + if (clplen (rlist) > 1 && clplen (rlist) != clplen (ilist)) + call error (0, + "The number of input and reference lists are not the same") + if (clplen (ilist) != clplen (olist)) + call error (0, + "The number of input and output lists are not the same") + + xcol = clgeti ("xcolumn") + ycol = clgeti ("ycolumn") + xrefcol = clgeti ("xrcolumn") + yrefcol = clgeti ("yrcolumn") + + # Get the matching parameters. + match = clgwrd ("matching", Memc[str], SZ_LINE, RG_MATCHSTR) + xin = clgetr ("xin") + if (IS_INDEFR(xin)) + xin = 0.0 + yin = clgetr ("yin") + if (IS_INDEFR(yin)) + yin = 0.0 + xmag = clgetr ("xmag") + if (IS_INDEFR(xmag)) + xmag = 1.0 + ymag = clgetr ("ymag") + if (IS_INDEFR(ymag)) + ymag = 1.0 + xrot = clgetr ("xrotation") + if (IS_INDEFR(xrot)) + xrot = 0.0 + yrot = clgetr ("yrotation") + if (IS_INDEFR(yrot)) + yrot = 0.0 + xout = clgetr ("xref") + if (IS_INDEFR(xout)) + xout = 0.0 + yout = clgetr ("yref") + if (IS_INDEFR(yout)) + yout = 0.0 + + # Get the algorithm parameters. + separation = clgetr ("separation") + maxntriangles = clgeti ("nmatch") + ratio = clgetr ("ratio") + nreject = clgeti ("nreject") + + # Get the output formatting parameters. + call clgstr ("xformat", Memc[xformat], SZ_FNAME) + call clgstr ("yformat", Memc[yformat], SZ_FNAME) + + interactive = clgetb ("interactive") + verbose = clgetb ("verbose") + + # Open the reference list file if any. + rfd = NULL + if (Memc[refpoints] == EOS) + rpfd = NULL + else + rpfd = open (Memc[refpoints], READ_ONLY, TEXT_FILE) + + # Initialize. + xref = NULL + yref = NULL + rsindex = NULL + rlineno = NULL + + # Loop over the input lists. + while (clgfil (ilist, Memc[inname], SZ_FNAME) != EOF && + clgfil (olist, Memc[outname], SZ_FNAME) != EOF) { + + # Open the input list. + ifd = open (Memc[inname], READ_ONLY, TEXT_FILE) + + # Open the output list. + ofd = open (Memc[outname], NEW_FILE, TEXT_FILE) + + # Open the reference list and get the coordinates. + while (clgfil (rlist, Memc[refname], SZ_FNAME) != EOF) { + + # Open the reference file. + if (rfd != NULL) + call close (rfd) + rfd = open (Memc[refname], READ_ONLY, TEXT_FILE) + + # Fetch the reference tie points. + if (interactive || rpfd != NULL) + nreftie = rg_getreftie (rpfd, Memr[xreftie], + Memr[yreftie], 3, RG_REFFILE, interactive) + else + nreftie = 0 + + # Read the reference data. + if (xref != NULL) + call mfree (xref, TY_REAL) + if (yref != NULL) + call mfree (yref, TY_REAL) + if (rlineno != NULL) + call mfree (rlineno, TY_INT) + if (rsindex != NULL) + call mfree (rsindex, TY_INT) + ntrefstars = rg_rdxyi (rfd, xref, yref, rlineno, xrefcol, + yrefcol) + call malloc (rsindex, ntrefstars, TY_INT) + + # Prepare the reference list for the merge algorithm. If a tie + # point matching algorithm is selected, sort the list in the + # y and then the x coordinate and remove coincident points. + # If the pattern matching algorithm is used then construct the + # triangles used for matching and sort them in order of + # increasing ratio. + + nrefstars = rg_sort (Memr[xref], Memr[yref], Memi[rsindex], + ntrefstars, separation, YES, YES) + if (match != RG_TRIANGLES) { + reftri = NULL + reftrirat = NULL + nreftri = nrefstars + } else if (nrefstars > 2) { + nrmaxtri = rg_factorial (min (nrefstars, maxntriangles), 3) + call calloc (reftri, SZ_TRIINDEX * nrmaxtri, TY_INT) + call calloc (reftrirat, SZ_TRIPAR * nrmaxtri, TY_REAL) + nreftri = rg_triangle (Memr[xref], Memr[yref], + Memi[rsindex], nrefstars, Memi[reftri], + Memr[reftrirat], nrmaxtri, maxntriangles, + tolerance, ratio) + } else { + nreftri = 0 + reftri = NULL + reftrirat = NULL + } + + break + } + + # Fetch the input tie points and compute the coefficients. + if (interactive || rpfd != NULL) + nintie = rg_getreftie (rpfd, Memr[xintie], + Memr[yintie], nreftie, RG_INFILE, interactive) + else + nintie = 0 + ntie = min (nreftie, nintie) + if (ntie <= 0) + call rg_lmkcoeff (xin, yin, xmag, ymag, xrot, yrot, + xout, yout, Memr[coeff], MAX_NCOEFF) + else if (rg_lincoeff (Memr[xreftie], Memr[yreftie], + Memr[xintie], Memr[yintie], ntie, Memr[coeff], + MAX_NCOEFF) == ERR) + call rg_lmkcoeff (xin, yin, xmag, ymag, xrot, yrot, + xout, yout, Memr[coeff], MAX_NCOEFF) + + # Print the header. + if (verbose) { + call printf ("\nInput: %s Reference: %s ") + call pargstr (Memc[inname]) + call pargstr (Memc[refname]) + call printf ("Number of tie points: %d\n") + call pargi (ntie) + } + call fprintf (ofd, "\n# Input: %s Reference: %s ") + call pargstr (Memc[inname]) + call pargstr (Memc[refname]) + call fprintf (ofd, "Number of tie points: %d\n") + call pargi (ntie) + + # Print the coordinate transformation information. + if (verbose) + call rg_plincoeff ("xref", "yref", Memr[xreftie], + Memr[yreftie], Memr[xintie], Memr[yintie], ntie, + Memr[coeff], MAX_NCOEFF) + call rg_wlincoeff (ofd, "xref", "yref", Memr[xreftie], + Memr[yreftie], Memr[xintie], Memr[yintie], ntie, + Memr[coeff], MAX_NCOEFF) + + # Read in the input list. + xtrans = NULL + ytrans = NULL + listindex = NULL + ntliststars = rg_rdxyi (ifd, xlist, ylist, ilineno, xcol, ycol) + + # Compute the intersection of the two lists using either an + # algorithm depending on common tie points or on a more + # sophisticated pattern matching algorithm. + + if (ntrefstars <= 0) { + if (verbose) + call printf (" The reference coordinate list is empty\n") + ninter = 0 + } else if (ntliststars <= 0) { + if (verbose) + call printf (" The input coordinate list is empty\n") + ninter = 0 + } else if (nreftri <= 0) { + if (verbose) + call printf ( + " No valid reference triangles can be defined\n") + } else { + call malloc (xtrans, ntliststars, TY_REAL) + call malloc (ytrans, ntliststars, TY_REAL) + call malloc (listindex, ntliststars, TY_INT) + call rg_compute (Memr[xlist], Memr[ylist], Memr[xtrans], + Memr[ytrans], ntliststars, Memr[coeff], MAX_NCOEFF) + nliststars = rg_sort (Memr[xtrans], Memr[ytrans], + Memi[listindex], ntliststars, separation, YES, YES) + if (match != RG_TRIANGLES) { + intri = NULL + intrirat = NULL + nintri = nliststars + call rg_pxycolumns (ofd) + ninter = rg_intersection (ofd, Memr[xref], Memr[yref], + Memi[rsindex], Memi[rlineno], nrefstars, Memr[xlist], + Memr[ylist], Memr[xtrans], Memr[ytrans], + Memi[listindex], Memi[ilineno], nliststars, tolerance, + Memc[xformat], Memc[yformat]) + } else if (nliststars > 2) { + ninmaxtri = rg_factorial (min (max(nliststars,nrefstars), + maxntriangles), 3) + call calloc (intri, SZ_TRIINDEX * ninmaxtri, TY_INT) + call calloc (intrirat, SZ_TRIPAR * ninmaxtri, TY_REAL) + nintri = rg_triangle (Memr[xtrans], Memr[ytrans], + Memi[listindex], nliststars, Memi[intri], + Memr[intrirat], ninmaxtri, maxntriangles, + tolerance, ratio) + if (nintri <= 0) { + if (verbose) + call printf ( + " No valid input triangles can be defined\n") + } else { + ninter = rg_match (Memr[xref], Memr[yref], nrefstars, + Memr[xtrans], Memr[ytrans], nliststars, + Memi[reftri], Memr[reftrirat], nreftri, nrmaxtri, + ntrefstars, Memi[intri], Memr[intrirat], nintri, + ninmaxtri, ntliststars, tolerance, tolerance, + ratio, nreject) + } + if (nrefstars <= maxntriangles && nliststars <= + maxntriangles) { + call rg_pxycolumns (ofd) + call rg_mwrite (ofd, Memr[xref], Memr[yref], + Memi[rlineno], Memr[xlist], Memr[ylist], + Memi[ilineno], Memi[reftri], nrmaxtri, + Memi[intri], ninmaxtri, ninter, Memc[xformat], + Memc[yformat]) + } else { + if (rg_mlincoeff (Memr[xref], Memr[yref], Memr[xlist], + Memr[ylist], Memi[reftri], nrmaxtri, + Memi[intri], ninmaxtri, ninter, Memr[coeff], + MAX_NCOEFF) == ERR) + call rg_lmkcoeff (xin, yin, xmag, ymag, xrot, yrot, + xout, yout, Memr[coeff], MAX_NCOEFF) + call rg_compute (Memr[xlist], Memr[ylist], + Memr[xtrans], Memr[ytrans], ntliststars, + Memr[coeff], MAX_NCOEFF) + nliststars = rg_sort (Memr[xtrans], Memr[ytrans], + Memi[listindex], ntliststars, separation, + YES, YES) + if (verbose) + call rg_pmlincoeff ("xref", "yref", Memr[coeff], + MAX_NCOEFF) + call rg_wmlincoeff (ofd, "xref", "yref", Memr[coeff], + MAX_NCOEFF) + call rg_pxycolumns (ofd) + ninter = rg_intersection (ofd, Memr[xref], Memr[yref], + Memi[rsindex], Memi[rlineno], nrefstars, + Memr[xlist], Memr[ylist], Memr[xtrans], + Memr[ytrans], Memi[listindex], Memi[ilineno], + nliststars, tolerance, Memc[xformat], Memc[yformat]) + } + } else { + if (verbose) + call printf ( + "\tThe input coordinate list has < 3 stars\n") + intri = NULL + intrirat = NULL + nintri = 0 + ninter = 0 + } + } + + # Print out the number of stars matched in the two lists. + if (verbose) { + call printf ("%d reference coordinates matched\n") + call pargi (ninter) + } + + # Free space used by input list. + call mfree (xlist, TY_REAL) + call mfree (ylist, TY_REAL) + call mfree (ilineno, TY_INT) + call mfree (listindex, TY_INT) + if (xtrans != NULL) + call mfree (xtrans, TY_REAL) + if (ytrans != NULL) + call mfree (ytrans, TY_REAL) + if (intri != NULL) + call mfree (intri, TY_INT) + if (intrirat != NULL) + call mfree (intrirat, TY_REAL) + + # Close the input and output lists. + call close (ifd) + call close (ofd) + } + + # Release the memory used to store the reference list. + call mfree (xref, TY_REAL) + call mfree (yref, TY_REAL) + call mfree (rlineno, TY_INT) + call mfree (rsindex, TY_INT) + if (reftri != NULL) + call mfree (reftri, TY_INT) + if (reftrirat != NULL) + call mfree (reftrirat, TY_REAL) + + # Close the reference file. + if (rfd != NULL) + call close (rfd) + + # Close the reference points file. + if (rpfd != NULL) + call close (rpfd) + + # Close the file lists. + call clpcls (ilist) + call clpcls (rlist) + call clpcls (olist) + + call sfree (sp) +end + + +# RG_PXYCOLUMNS -- Print the column descriptions in the output file. + +procedure rg_pxycolumns (ofd) + +int ofd #I the output file descriptor + +begin + call fprintf (ofd, "# Column definitions\n") + call fprintf (ofd, "# Column 1: X reference coordinate\n") + call fprintf (ofd, "# Column 2: Y reference coordinate\n") + call fprintf (ofd, "# Column 3: X input coordinate\n") + call fprintf (ofd, "# Column 4: Y input coordinate\n") + call fprintf (ofd, "# Column 5: Reference line number\n") + call fprintf (ofd, "# Column 6: Input line number\n") + call fprintf (ofd, "\n") +end diff --git a/pkg/images/immatch/src/mkpkg b/pkg/images/immatch/src/mkpkg new file mode 100644 index 00000000..ec8accec --- /dev/null +++ b/pkg/images/immatch/src/mkpkg @@ -0,0 +1,11 @@ +# Library for the IMMATCH Package. + +libpkg.a: + @geometry + @imcombine + @linmatch + @listmatch + @psfmatch + @wcsmatch + @xregister + ; diff --git a/pkg/images/immatch/src/psfmatch/mkpkg b/pkg/images/immatch/src/psfmatch/mkpkg new file mode 100644 index 00000000..da3951dc --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/mkpkg @@ -0,0 +1,21 @@ +# Make the PSFMATCH task + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + +libpkg.a: + rgpbckgrd.x <math.h> <math/gsurfit.h> "psfmatch.h" + rgpcolon.x <imhdr.h> <imset.h> <error.h> "psfmatch.h" + rgpconvolve.x <error.h> <imhdr.h> <imset.h> + rgpisfm.x <imhdr.h> <gset.h> <ctype.h> "psfmatch.h" + rgpfft.x + rgpfilter.x <math.h> + rgppars.x "psfmatch.h" + rgpregions.x <imhdr.h> <fset.h> "psfmatch.h" + rgpsfm.x <imhdr.h> <math/gsurfit.h> "psfmatch.h" + rgpshow.x "psfmatch.h" + rgptools.x "psfmatch.h" + t_psfmatch.x <fset.h> <imhdr.h> "psfmatch.h" + ; diff --git a/pkg/images/immatch/src/psfmatch/psfmatch.h b/pkg/images/immatch/src/psfmatch/psfmatch.h new file mode 100644 index 00000000..c6b7d563 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/psfmatch.h @@ -0,0 +1,274 @@ +# Header file for PSFMATCH + +define LEN_PSFSTRUCT (45 + 12 * SZ_FNAME + 12) + +# Define the psf fitting structure + +define PM_RC1 Memi[$1] # pointer to first column of region +define PM_RC2 Memi[$1+1] # pointer to last column of region +define PM_RL1 Memi[$1+2] # pointer to first line of region +define PM_RL2 Memi[$1+3] # pointer to last line of region +define PM_RZERO Memi[$1+4] # pointer to zero point of ref regions +define PM_RXSLOPE Memi[$1+5] # pointer to x slopes of ref regions +define PM_RYSLOPE Memi[$1+6] # pointer to y slopes of ref regions +define PM_NREGIONS Memi[$1+7] # total number of regions +define PM_CNREGION Memi[$1+8] # the current region + +define PM_CENTER Memi[$1+9] # the the psf objects +define PM_BACKGRD Memi[$1+10] # type of background subtraction +define PM_BVALUER Memr[P2R($1+11)] # reference background value +define PM_BVALUE Memr[P2R($1+12)] # image background value +define PM_LOREJECT Memr[P2R($1+13)] # low side rejection +define PM_HIREJECT Memr[P2R($1+14)] # high side rejection +define PM_APODIZE Memr[P2R($1+15)] # fraction of region to be apodized + +define PM_CONVOLUTION Memi[$1+16] # the convolution type +define PM_DNX Memi[$1+17] # x dimension of kernel +define PM_DNY Memi[$1+18] # y dimension of kernel +define PM_PNX Memi[$1+19] # x dimension of user kernel +define PM_PNY Memi[$1+20] # y dimension of user kernel +define PM_KNX Memi[$1+21] # x size of kernel +define PM_KNY Memi[$1+22] # x size of kernel + +define PM_POWER Memi[$1+23] # save power spectrum of kernel ? + +define PM_UFLUXRATIO Memr[P2R($1+24)] # the user ref / input flux ratio +define PM_FLUXRATIO Memr[P2R($1+25)] # ref / input flux ratio +define PM_FILTER Memi[$1+26] # background filtering +define PM_SXINNER Memr[P2R($1+27)] # inner radius for cosine bell +define PM_SXOUTER Memr[P2R($1+28)] # outer radius for cosine bell +define PM_SYINNER Memr[P2R($1+29)] # inner radius for cosine bell +define PM_SYOUTER Memr[P2R($1+30)] # outer radius for cosine bell +define PM_RADSYM Memi[$1+31] # radial symmetry in convolution +define PM_THRESHOLD Memr[P2R($1+32)] # threshold in divisor for model + +define PM_NORMFACTOR Memr[P2R($1+34)] # the normalization factor + +#define PM_PRATIO Memr[P2R($1+24)] # power ration threshold +#define PM_XSHIFTS Memi[$1+26] # pointer to x shifts +#define PM_YSHIFTS Memi[$1+27] # pointer to y shifts + +define PM_REFFFT Memi[$1+35] # pointer to reference fft +define PM_IMFFT Memi[$1+36] # pointer to image fft +define PM_FFT Memi[$1+37] # pointer to unfiltered fft +define PM_CONV Memi[$1+38] # pointer to kernel +define PM_ASFFT Memi[$1+39] # pointer to power spectrum +define PM_NXFFT Memi[$1+40] # x dimension of FFT +define PM_NYFFT Memi[$1+41] # y dimension of FFT + +define PM_BSTRING Memc[P2C($1+42)] # background string +define PM_CSTRING Memc[P2C($1+42+SZ_FNAME+1)] # convolution string +define PM_FSTRING Memc[P2C($1+42+2*SZ_FNAME+2)] # convolution string + +define PM_IMAGE Memc[P2C($1+42+4*SZ_FNAME+4)] # input image +define PM_REFIMAGE Memc[P2C($1+42+5*SZ_FNAME+5)] # reference image +define PM_PSFDATA Memc[P2C($1+42+6*SZ_FNAME+6)] # psf data +define PM_PSFIMAGE Memc[P2C($1+42+7*SZ_FNAME+7)] # psf image if any +define PM_OBJLIST Memc[P2C($1+42+8*SZ_FNAME+8)] # object list if any +define PM_KERNEL Memc[P2C($1+42+9*SZ_FNAME+9)] # kernel image +define PM_OUTIMAGE Memc[P2C($1+42+10*SZ_FNAME+10)] # output convolved image + +# Define the paramerter ids + +define RC1 1 +define RC2 2 +define RL1 3 +define RL2 4 +define RZERO 5 +define RXSLOPE 6 +define RYSLOPE 7 +define NREGIONS 8 +define CNREGION 9 + +define CENTER 10 +define BACKGRD 11 +define BVALUER 12 +define BVALUE 13 +define LOREJECT 15 +define HIREJECT 16 +define APODIZE 17 + +define CONVOLUTION 18 +define DNX 19 +define DNY 20 +define PNX 21 +define PNY 22 +define KNX 23 +define KNY 24 +define POWER 25 + +#define XSHIFTS 20 +#define YSHIFTS 21 + +define REFFFT 26 +define IMFFT 27 +define FFT 28 +define CONV 29 +define ASFFT 30 +define NXFFT 31 +define NYFFT 32 + +define UFLUXRATIO 33 +define FLUXRATIO 34 +define FILTER 35 +define SXINNER 36 +define SXOUTER 37 +define SYINNER 38 +define SYOUTER 39 +define RADSYM 40 +define THRESHOLD 41 + +define NORMFACTOR 43 + +#define PRATIO 34 + +define BSTRING 44 +define CSTRING 45 +define FSTRING 46 + +define REFIMAGE 48 +define IMAGE 49 +define PSFDATA 50 +define PSFIMAGE 51 +define OBJLIST 52 +define KERNEL 53 +define OUTIMAGE 54 + +# Define the default parameter values + +define DEF_CENTER YES +define DEF_BACKGRD PM_BMEDIAN +define DEF_LOREJECT INDEFR +define DEF_HIREJECT INDEFR + +define DEF_CONVOLUTION PM_CONIMAGE +define DEF_DNX 63 +define DEF_DNY 63 +define DEF_PNX 31 +define DEF_PNY 31 +define DEF_POWER NO + +define DEF_FILTER PM_FREPLACE +define DEF_SXINNER INDEFR +define DEF_SXOUTER INDEFR +define DEF_SYINNER INDEFR +define DEF_SYOUTER INDEFR +define DEF_RADSYM NO +define DEF_THRESHOLD 0.0 + +#define DEF_PRATIO 0.0 + +define DEF_NORMFACTOR 1.0 +define DEF_UFLUXRATIO INDEFR + +# Define the background fitting techniques + +define PM_BNONE 1 +define PM_BMEAN 2 +define PM_BMEDIAN 3 +define PM_BSLOPE 4 +define PM_BNUMBER 5 + +define PM_BTYPES "|none|mean|median|plane|" + +# Define the convolution computation options + +define PM_CONIMAGE 1 +define PM_CONPSF 2 +define PM_CONKERNEL 3 + +define PM_CTYPES "|image|psf|kernel|" + +# Define the filtering options + +define PM_FNONE 1 +define PM_FCOSBELL 2 +define PM_FREPLACE 3 +define PM_FMODEL 4 + +define PM_FTYPES "|none|cosbell|replace|model|" + +# Define the normalization options + +define PM_UNIT 1 +define PM_RATIO 2 +define PM_NUMBER 3 + +define PM_NTYPES "|unit|ratio|" + +# Miscellaneous + +define MAX_NREGIONS 100 + +# Commands + +define PMCMDS "|input|reference|psfdata|psfimage|kernel|output|dnx|dny|\ +pnx|pny|center|background|loreject|hireject|apodize|convolution|fluxratio|\ +filter|sx1|sx2|sy1|sy2|radsym|threshold|normfactor|show|mark|" + +define PMCMD_IMAGE 1 +define PMCMD_REFIMAGE 2 +define PMCMD_PSFDATA 3 +define PMCMD_PSFIMAGE 4 +define PMCMD_KERNEL 5 +define PMCMD_OUTIMAGE 6 + +define PMCMD_DNX 7 +define PMCMD_DNY 8 +define PMCMD_PNX 9 +define PMCMD_PNY 10 + +define PMCMD_CENTER 11 +define PMCMD_BACKGRD 12 +define PMCMD_LOREJECT 13 +define PMCMD_HIREJECT 14 +define PMCMD_APODIZE 15 + +define PMCMD_CONVOLUTION 16 +define PMCMD_UFLUXRATIO 17 +define PMCMD_FILTER 18 +define PMCMD_SXINNER 19 +define PMCMD_SXOUTER 20 +define PMCMD_SYINNER 21 +define PMCMD_SYOUTER 22 +define PMCMD_RADSYM 23 +define PMCMD_THRESHOLD 24 + +define PMCMD_NORMFACTOR 25 + +define PMCMD_SHOW 26 +define PMCMD_MARK 27 + +# Keywords + +define KY_IMAGE "input" +define KY_REFIMAGE "reference" +define KY_PSFDATA "psfdata" +define KY_PSFIMAGE "psfimage" +define KY_KERNEL "kernel" +define KY_OUTIMAGE "output" + +define KY_DNX "dnx" +define KY_DNY "dny" +define KY_PNX "pnx" +define KY_PNY "pny" + +define KY_CENTER "center" +define KY_BACKGRD "background" +define KY_LOREJECT "loreject" +define KY_HIREJECT "hireject" +define KY_APODIZE "apodize" + +define KY_CONVOLUTION "convolution" + +define KY_UFLUXRATIO "fluxratio" +define KY_FILTER "filter" +define KY_SXINNER "sx1" +define KY_SXOUTER "sx2" +define KY_SYINNER "sy1" +define KY_SYOUTER "sy2" +define KY_RADSYM "radsym" +define KY_THRESHOLD "threshold" + +define KY_NORMFACTOR "normfactor" + diff --git a/pkg/images/immatch/src/psfmatch/psfmatch.key b/pkg/images/immatch/src/psfmatch/psfmatch.key new file mode 100644 index 00000000..57ef3b2e --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/psfmatch.key @@ -0,0 +1,50 @@ + Interactive Keystroke Commands + + +? Print help +: Colon commands +k Draw a contour plot of the psf matching kernel +p Draw a contour plot of the psf matching kernel power spectrum +x Draw a column plot of the psf matching kernel / power spectrum +y Draw a line plot of the psf matching kernel / power spectrum +r Redraw the current plot +f Recompute the psf matching kernel +w Update the task parameters +q Exit + + + Colon Commands + + +:mark [file] Mark objects on the display +:show Show current values of the parameters + + + Show/Set Parameters + +:input [string] Show/set the current input image name +:reference [string] Show/set the current reference image/psf name +:psf [file/string] Show/set the objects/input psf list +:psfimage [string] Show/set the current input psf name +:kernel [string] Show/set the current psf matching kernel name +:output [string] Show/set the current output image name + +:dnx [value] Show/set x width of data region(s) to extract +:dny [value] Show/set y width of data region(s) to extract +:pnx [value] Show/set x width of psf matching kernel +:pny [value] Show/set y width of psf matching kernel +:center [yes/no] Show/set the centering switch +:background [string] Show/set the background fitting function +:loreject [value] Show/set low side k-sigma rejection parameter +:hireject [value] Show/set high side k-sigma rejection parameter +:apodize [value] Show/set percent of endpoints to apodize + +:filter [string] Show/set the filtering algorithm +:fluxratio [value] Show/set the reference/input psf flux ratio +:sx1 [value] Show/set inner x frequency for cosbell filter +:sx2 [value] Show/set outer x frequency for cosbell filter +:sy1 [value] Show/set inner y frequency for cosbell filter +:sy2 [value] Show/set outer y frequency for cosbell filter +:radsym [yes/no] Show/set radial symmetry for cosbell filter +:threshold [value] Show/set %threshold for replace/modeling filter +:normfactor [value] Show/set the kernel normalization factor diff --git a/pkg/images/immatch/src/psfmatch/rgpbckgrd.x b/pkg/images/immatch/src/psfmatch/rgpbckgrd.x new file mode 100644 index 00000000..1670b943 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpbckgrd.x @@ -0,0 +1,70 @@ +include <math.h> +include <math/gsurfit.h> +include "psfmatch.h" + +# RG_PSCALE -- Compute the background offset and x and y slope. + +procedure rg_pscale (pm, data, npts, nx, ny, pnx, pny, offset, coeff) + +pointer pm #I pointer to the psfmatch structure +real data[ARB] #I the input data +int npts #I the number of points +int nx, ny #I the dimensions of the original subraster +int pnx, pny #I the dimensions of the data region +real offset #I the input offset +real coeff[ARB] #O the output coefficients + +int wxborder, wyborder +pointer gs +real loreject, hireject, zero +int rg_pstati(), rg_znsum(), rg_znmedian(), rg_slope() +real rg_pstatr() + +begin + loreject = rg_pstatr (pm, LOREJECT) + hireject = rg_pstatr (pm, HIREJECT) + + switch (rg_pstati (pm, BACKGRD)) { + case PM_BNONE: + coeff[1] = 0.0 + coeff[2] = 0.0 + coeff[3] = 0.0 + case PM_BNUMBER: + coeff[1] = offset + coeff[2] = 0.0 + coeff[3] = 0.0 + case PM_BMEAN: + if (rg_znsum (data, npts, zero, loreject, hireject) <= 0) + zero = 0.0 + coeff[1] = zero + coeff[2] = 0.0 + coeff[3] = 0.0 + case PM_BMEDIAN: + if (rg_znmedian (data, npts, zero, loreject, hireject) <= 0) + zero = 0.0 + coeff[1] = zero + coeff[2] = 0.0 + coeff[3] = 0.0 + case PM_BSLOPE: + call gsinit (gs, GS_POLYNOMIAL, 2, 2, GS_XNONE, 1.0, real (nx), 1.0, + real (ny)) + wxborder = (nx - pnx) / 2 + wyborder = (ny - pny) / 2 + if (rg_slope (gs, data, npts, nx, ny, wxborder, wyborder, loreject, + hireject) == ERR) { + coeff[1] = 0.0 + coeff[2] = 0.0 + coeff[3] = 0.0 + } else { + call gssave (gs, coeff) + coeff[1] = coeff[GS_SAVECOEFF+1] + coeff[2] = coeff[GS_SAVECOEFF+2] + coeff[3] = coeff[GS_SAVECOEFF+3] + } + call gsfree (gs) + default: + coeff[1] = 0.0 + coeff[2] = 0.0 + coeff[3] = 0.0 + } +end diff --git a/pkg/images/immatch/src/psfmatch/rgpcolon.x b/pkg/images/immatch/src/psfmatch/rgpcolon.x new file mode 100644 index 00000000..8eefb22d --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpcolon.x @@ -0,0 +1,501 @@ +include <imhdr.h> +include <imset.h> +include <error.h> +include "psfmatch.h" + +# RG_PCOLON -- Show/set the psfmatch task algorithm parameters. + +procedure rg_pcolon (gd, pm, imr, reglist, impsf, im1, imk, imfourier, im2, + cmdstr, newref, newdata, newfourier, newfilter) + +pointer gd #I pointer to the graphics stream +pointer pm #I pointer to psfmatch structure +pointer imr #I pointer to the reference image +int reglist #I the regions / psf list descriptor +pointer impsf #I pointer to the regions list +pointer im1 #I pointer to the input image +pointer imk #I pointer to kernel image +pointer imfourier #I pointer to fourier spectrum image +pointer im2 #I pointer to the output image +char cmdstr[ARB] #I command string +int newref #I/O new reference image +int newdata #I/O new input image +int newfourier #I/O new FFT +int newfilter #I/O new filter + +bool bval +int ncmd, ival, stat, fd, ip +pointer sp, cmd, str +real rval +bool itob() +bool streq() +int strdic(), nscan(), rg_pstati(), btoi(), rg_pregions(), fntopnb() +int access(), rg_pmkregions(), open(), ctor() +pointer immap() +real rg_pstatr() +errchk immap(), fntopnb() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the command. + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call sfree (sp) + return + } + + # Process the command. + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, PMCMDS) + switch (ncmd) { + case PMCMD_REFIMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_pstats (pm, REFIMAGE, Memc[str], SZ_FNAME) + if (imr == NULL || Memc[cmd] == EOS || streq (Memc[cmd], + Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str]) + } else { + if (imr != NULL) { + call imunmap (imr) + imr = NULL + } + iferr { + imr = immap (Memc[cmd], READ_ONLY, 0) + } then { + call erract (EA_WARN) + imr = immap (Memc[str], READ_ONLY, 0) + } else if (IM_NDIM(imr) > 2 || IM_NDIM(imr) != IM_NDIM(im1)) { + call printf ( + "Reference image has the wrong number of dimensions\n") + call imunmap (imr) + imr = immap (Memc[str], READ_ONLY, 0) + } else { + call rg_psets (pm, REFIMAGE, Memc[cmd]) + newref = YES; newdata = YES + newfourier = YES; newfilter = YES + } + } + + case PMCMD_IMAGE: + + call gargwrd (Memc[cmd], SZ_LINE) + call rg_pstats (pm, IMAGE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + } else { + if (im1 != NULL) { + call imunmap (im1) + im1 = NULL + } + iferr { + im1 = immap (Memc[cmd], READ_ONLY, 0) + call imseti (im1, IM_TYBNDRY, BT_NEAREST) + if (IM_NDIM(im1) == 1) + call imseti (im1, IM_NBNDRYPIX, IM_LEN(im1,1)) + else + call imseti (im1, IM_NBNDRYPIX, + max (IM_LEN(im1,1), IM_LEN(im1,2))) + } then { + call erract (EA_WARN) + im1 = immap (Memc[str], READ_ONLY, 0) + call imseti (im1, IM_TYBNDRY, BT_NEAREST) + if (IM_NDIM(im1) == 1) + call imseti (im1, IM_NBNDRYPIX, IM_LEN(im1,1)) + else + call imseti (im1, IM_NBNDRYPIX, + max (IM_LEN(im1,1), IM_LEN(im1,2))) + } else if (IM_NDIM(im1) > 2 || IM_NDIM(im1) != IM_NDIM(imr)) { + call printf ( + "Reference image has the wrong number of dimensions\n") + call imunmap (im1) + im1 = immap (Memc[str], READ_ONLY, 0) + call imseti (im1, IM_TYBNDRY, BT_NEAREST) + if (IM_NDIM(im1) == 1) + call imseti (im1, IM_NBNDRYPIX, IM_LEN(im1,1)) + else + call imseti (im1, IM_NBNDRYPIX, + max (IM_LEN(im1,1), IM_LEN(im1,2))) + } else { + call rg_psets (pm, IMAGE, Memc[cmd]) + newdata = YES; newref = YES + newfourier = YES; newfilter = YES + } + } + + case PMCMD_PSFDATA: + + call gargwrd (Memc[cmd], SZ_LINE) + call rg_pstats (pm, PSFDATA, Memc[str], SZ_FNAME) + if (reglist == NULL || nscan() == 1 || (streq (Memc[cmd], + Memc[str]) && Memc[cmd] != EOS)) { + call printf ("%s [string/file]: %s\n") + call pargstr (KY_PSFDATA) + call pargstr (Memc[str]) + } else if (rg_pstati(pm, CONVOLUTION) == PM_CONIMAGE) { + call fntclsb (reglist) + iferr { + reglist = fntopnb (Memc[cmd], NO) + } then { + reglist = fntopnb (Memc[str], NO) + } else { + if (rg_pregions (reglist, imr, pm, 1, NO) > 0) + ; + call rg_psets (pm, PSFDATA, Memc[cmd]) + newdata = YES; newref = YES + newfourier = YES; newfilter = YES + } + } + + case PMCMD_PSFIMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_pstats (pm, PSFIMAGE, Memc[str], SZ_FNAME) + if (impsf == NULL || Memc[cmd] == EOS || streq (Memc[cmd], + Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_PSFIMAGE) + call pargstr (Memc[str]) + } else { + if (impsf != NULL) { + call imunmap (impsf) + impsf = NULL + } + iferr { + impsf = immap (Memc[cmd], READ_ONLY, 0) + } then { + call erract (EA_WARN) + impsf = immap (Memc[str], READ_ONLY, 0) + } else if (IM_NDIM(impsf) > 2 || IM_NDIM(impsf) != + IM_NDIM(imr)) { + call printf ( + "PSF image has the wrong number of dimensions\n") + call imunmap (impsf) + impsf = immap (Memc[str], READ_ONLY, 0) + } else { + call rg_psets (pm, PSFIMAGE, Memc[cmd]) + newref = YES; newdata = YES + newfourier = YES; newfilter = YES + } + } + + case PMCMD_KERNEL: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_pstats (pm, KERNEL, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_KERNEL) + call pargstr (Memc[str]) + } else { + if (imk != NULL) { + call imunmap (imk) + call imdelete (Memc[str]) + imk = NULL + } + iferr { + imk = immap (Memc[cmd], NEW_IMAGE, 0) + } then { + call erract (EA_WARN) + imk = NULL + call rg_psets (pm, KERNEL, "") + } else + call rg_psets (pm, KERNEL, Memc[cmd]) + } + + + case PMCMD_OUTIMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_pstats (pm, OUTIMAGE, Memc[str], SZ_FNAME) + if (im2 == NULL || Memc[cmd] == EOS || streq (Memc[cmd], + Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_OUTIMAGE) + call pargstr (Memc[str]) + } else { + if (im2 != NULL) { + call imunmap (im2) + im2 = NULL + } + iferr { + im2 = immap (Memc[cmd], NEW_COPY, im1) + } then { + call erract (EA_WARN) + im2 = immap (Memc[str], NEW_COPY, im1) + } else { + call rg_psets (pm, OUTIMAGE, Memc[cmd]) + } + } + + case PMCMD_DNX: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_DNX) + call pargi (rg_pstati (pm, DNX)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, DNX, ival) + newref = YES; newdata = YES; newfourier = YES; newfilter = YES + } + + case PMCMD_DNY: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_DNY) + call pargi (rg_pstati (pm, DNY)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, DNY, ival) + newref = YES; newdata = YES; newfourier = YES; newfilter = YES + } + + case PMCMD_PNX: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_PNX) + call pargi (rg_pstati (pm, PNX)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, PNX, min (ival, rg_pstati (pm, DNX))) + newref = YES; newdata = YES; newfourier = YES; newfilter = YES + } + + case PMCMD_PNY: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_PNY) + call pargi (rg_pstati (pm, PNY)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, PNY, min (ival, rg_pstati(pm, DNY))) + newref = YES; newdata = YES; newfourier = YES; newfilter = YES + } + + case PMCMD_CENTER: + call gargb (bval) + if (nscan() == 1) { + call printf ("%s = %b\n") + call pargstr (KY_CENTER) + call pargb (itob (rg_pstati (pm, CENTER))) + } else { + call rg_pseti (pm, CENTER, btoi (bval)) + newfourier = YES; newfilter = YES + } + + case PMCMD_BACKGRD: + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_pstats (pm, BSTRING, Memc[str], SZ_FNAME) + call printf ("%s: %s\n") + call pargstr (KY_BACKGRD) + call pargstr (Memc[str]) + } else { + stat = strdic (Memc[cmd], Memc[cmd], SZ_LINE, PM_BTYPES) + ip = 1 + if (stat > 0) { + call rg_pseti (pm, BACKGRD, stat) + call rg_psets (pm, BSTRING, Memc[cmd]) + newfourier = YES; newfilter = YES + } else if (ctor (str, ip, rval) > 0) { + call rg_psetr (pm, BVALUE, rval) + if (ctor (str, ip, rval) > 0) { + call rg_psetr (pm, BVALUER, rval) + call strcpy (str, PM_BSTRING(pm), SZ_FNAME) + call rg_pseti (pm, BACKGRD, PM_NUMBER) + } else { + call rg_psetr (pm, BVALUE, 0.0) + call rg_psetr (pm, BVALUER, 0.0) + } + } + } + + case PMCMD_LOREJECT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_LOREJECT) + call pargr (rg_pstatr (pm, LOREJECT)) + } else { + call rg_psetr (pm, LOREJECT, rval) + newfourier = YES; newfilter = YES + } + + case PMCMD_HIREJECT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_HIREJECT) + call pargr (rg_pstatr (pm, HIREJECT)) + } else { + call rg_psetr (pm, HIREJECT, rval) + newfourier = YES; newfilter = YES + } + + case PMCMD_APODIZE: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_APODIZE) + call pargr (rg_pstatr (pm, APODIZE)) + } else { + call rg_psetr (pm, APODIZE, rval) + newfourier = YES; newfilter = YES + } + + case PMCMD_CONVOLUTION: + if (Memc[cmd] == EOS) { + call rg_pstats (pm, CSTRING, Memc[str], SZ_LINE) + call printf ("%s: %s\n") + call pargstr (KY_CONVOLUTION) + call pargstr (Memc[str]) + } + + case PMCMD_UFLUXRATIO: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_UFLUXRATIO) + call pargr (rg_pstatr (pm, UFLUXRATIO)) + } else { + call rg_psetr (pm, UFLUXRATIO, rval) + newfourier = YES; newfilter = YES + } + + case PMCMD_FILTER: + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_pstats (pm, FSTRING, Memc[str], SZ_LINE) + call printf ("%s: %s\n") + call pargstr (KY_FILTER) + call pargstr (Memc[str]) + } else { + stat = strdic (Memc[cmd], Memc[cmd], SZ_LINE, PM_FTYPES) + if (stat > 0) { + call rg_pseti (pm, FILTER, stat) + call rg_psets (pm, FSTRING, Memc[cmd]) + } + newfilter = YES + } + + case PMCMD_SXINNER: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_SXINNER) + call pargr (rg_pstatr (pm, SXINNER)) + } else { + call rg_psetr (pm, SXINNER, rval) + newfilter = YES + } + + case PMCMD_SXOUTER: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_SXOUTER) + call pargr (rg_pstatr (pm, SXOUTER)) + } else { + call rg_psetr (pm, SXOUTER, rval) + newfilter = YES + } + + case PMCMD_SYINNER: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_SYINNER) + call pargr (rg_pstatr (pm, SYINNER)) + } else { + call rg_psetr (pm, SYINNER, rval) + newfilter = YES + } + + case PMCMD_SYOUTER: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_SYOUTER) + call pargr (rg_pstatr (pm, SYOUTER)) + } else { + call rg_psetr (pm, SYOUTER, rval) + newfilter = YES + } + + case PMCMD_RADSYM: + call gargb (bval) + if (nscan() == 1) { + call printf ("%s = %b\n") + call pargstr (KY_RADSYM) + call pargb (itob (rg_pstati (pm, RADSYM))) + } else { + call rg_pseti (pm, RADSYM, btoi (bval)) + newfilter = YES + } + + case PMCMD_THRESHOLD: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_THRESHOLD) + call pargr (rg_pstatr (pm, THRESHOLD)) + } else { + call rg_psetr (pm, THRESHOLD, rval) + newfilter = YES + } + + case PMCMD_NORMFACTOR: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_NORMFACTOR) + call pargr (rg_pstatr (pm, NORMFACTOR)) + } else { + call rg_psetr (pm, NORMFACTOR, rval) + newfilter = YES + } + + case PMCMD_SHOW: + call gdeactivate (gd, 0) + call rg_pshow (pm) + call greactivate (gd, 0) + + case PMCMD_MARK: + call gdeactivate (gd, 0) + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + fd = NULL + } else if (access (Memc[cmd], 0, 0) == YES) { + call printf ("Warning: file %s already exists\n") + call pargstr (Memc[cmd]) + fd = NULL + } else { + fd = open (Memc[cmd], NEW_FILE, TEXT_FILE) + } + call printf ("\n") + if (rg_pmkregions (fd, imr, pm, 1, MAX_NREGIONS) <= 0) + call printf ("The regions list is empty\n") + newdata = YES; newref = YES + newfourier = YES; newfilter = YES + call printf ("\n") + if (fd != NULL) + call close (fd) + call greactivate (gd, 0) + + default: + call printf ("Unknown or ambiguous colon command\7\n") + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/psfmatch/rgpconvolve.x b/pkg/images/immatch/src/psfmatch/rgpconvolve.x new file mode 100644 index 00000000..6b516a95 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpconvolve.x @@ -0,0 +1,106 @@ +include <error.h> +include <imhdr.h> +include <imset.h> + +# RG_PCONVOLVE -- Convolve an image with an nxk by nyk kernel. The kernel +# dimensions are assumed to be odd. + +procedure rg_pconvolve (im1, im2, kernel, nxk, nyk, boundary, constant) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image +real kernel[nxk,nyk] # the convolution kernel +int nxk, nyk # dimensions of the kernel +int boundary # type of boundary extension +real constant # constant for constant boundary extension + +int i, ncols, nlines, col1, col2, nincols, inline, outline +pointer sp, lineptrs, linebuf, outbuf, nkern +pointer imgs2r(), impl2r() +errchk imgs2r, impl2r + +begin + # Set up an array of line pointers. + call smark (sp) + call salloc (lineptrs, nyk, TY_POINTER) + call salloc (nkern, nxk * nyk, TY_REAL) + + # Set the number of image buffers. + call imseti (im1, IM_NBUFS, nyk) + + # Set the input image boundary conditions. + call imseti (im1, IM_TYBNDRY, boundary) + call imseti (im1, IM_NBNDRYPIX, max (nxk / 2 + 1, nyk / 2 + 1)) + if (boundary == BT_CONSTANT) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Define the number of output image lines and columns. + ncols = IM_LEN(im2,1) + if (IM_NDIM(im2) == 1) + nlines = 1 + else + nlines = IM_LEN(im2,2) + + # Set the input image column limits. + col1 = 1 - nxk / 2 + col2 = IM_LEN(im1,1) + nxk / 2 + nincols = col2 - col1 + 1 + + # Flip the kernel + call rg_pflip (kernel, Memr[nkern], nxk, nyk) + + # Initialise the line buffers. + inline = 1 - nyk / 2 + do i = 1 , nyk - 1 { + Memi[lineptrs+i] = imgs2r (im1, col1, col2, inline, inline) + inline = inline + 1 + } + + # Generate the output image line by line + call salloc (linebuf, nincols, TY_REAL) + do outline = 1, nlines { + + # Scroll the input buffers + do i = 1, nyk - 1 + Memi[lineptrs+i-1] = Memi[lineptrs+i] + + # Read in new image line + Memi[lineptrs+nyk-1] = imgs2r (im1, col1, col2, inline, + inline) + + # Get output image line + outbuf = impl2r (im2, outline) + if (outbuf == EOF) + call error (0, "Error writing output image.") + + # Generate output image line + call aclrr (Memr[outbuf], ncols) + do i = 1, nyk + call acnvr (Memr[Memi[lineptrs+i-1]], Memr[outbuf], ncols, + Memr[nkern+(i-1)*nxk], nxk) + + inline = inline + 1 + } + + # Free the image buffer pointers + call sfree (sp) +end + + +# RG_PFLIP -- Flip the kernel in preparation for convolution. + +procedure rg_pflip (inkern, outkern, nxk, nyk) + +real inkern[nxk,nyk] # the input kernel +real outkern[nxk,nyk] # the output kernel +int nxk, nyk # the kernel dimensions + +int i, j + +begin + do j = 1, nyk { + do i = 1, nxk { + outkern[i,j] = inkern[nxk+1-i,nyk+1-j] + } + } +end diff --git a/pkg/images/immatch/src/psfmatch/rgpfft.x b/pkg/images/immatch/src/psfmatch/rgpfft.x new file mode 100644 index 00000000..b5f36375 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpfft.x @@ -0,0 +1,443 @@ + +# RG_PG10F -- Fetch the 0 component of the fft. + +real procedure rg_pg10f (fft, nxfft, nyfft) + +real fft[nxfft,nyfft] #I array containing 2 real ffts +int nxfft #I x dimension of complex array +int nyfft #I y dimension of complex array + +int xcen, ycen + +begin + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + + return (fft[xcen,ycen]) +end + + +# RG_PG1NORM -- Estimate the normalization factor by computing the amplitude +# of the best fitting Gaussian. This routine may eventually be replaced by +# on which does a complete Gaussian fit. The Gaussian is assumed to be +# of the form g = a * exp (b * r * r). The input array is a 2D real array +# storing 1 fft of dimension nxfft by nyfft in complex order with the +# zero frequency in the center. + +real procedure rg_pg1norm (fft, nxfft, nyfft) + +real fft[nxfft,nyfft] #I array containing 2 real ffts +int nxfft #I x dimension of complex array +int nyfft #I y dimension of complex array + +int xcen, ycen +real ln1, ln2, cx, cy + +begin + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + + if (nxfft >= 8) { + ln1 = log (sqrt (fft[xcen-2,ycen] ** 2 + fft[xcen-1,ycen] ** 2)) + ln2 = log (sqrt (fft[xcen-4,ycen] ** 2 + fft[xcen-3,ycen] ** 2)) + cx = exp ((4.0 * ln1 - ln2) / 3.0) + } else + cx = 0.0 + + if (nyfft >= 4) { + ln1 = log (sqrt (fft[xcen,ycen-1] ** 2 + fft[xcen+1,ycen-1] ** 2)) + ln2 = log (sqrt (fft[xcen,ycen-2] ** 2 + fft[xcen+1,ycen-2] ** 2)) + cy = exp ((4.0 * ln1 - ln2) / 3.0) + } else + cy = 0.0 + + if (cx <= 0.0) + return (cy) + else if (cy <= 0.0) + return (cx) + else + return (0.5 * (cx + cy)) +end + + +# RG_PG20F -- Fetch the 0 component of the fft. + +real procedure rg_pg20f (fft, nxfft, nyfft) + +real fft[nxfft,nyfft] #I array containing 2 real ffts +int nxfft #I x dimension of complex array +int nyfft #I y dimension of complex array + +int xcen, ycen + +begin + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + + return (fft[xcen,ycen] / fft[xcen+1,ycen]) +end + + +# RG_PG2NORM -- Estimate the normalization factor by computing the amplitude +# of the best fitting Gaussian. This routine may eventually be replaced by +# on which does a complete Gaussian fit. The Gaussian is assumed to be +# of the form g = a * exp (b * r * r). The input array is a 2D real array +# storing 2 2D ffts of dimension nxfft by nyfft in complex order with the +# zero frequency in the center. + +real procedure rg_pg2norm (fft, nxfft, nyfft) + +real fft[nxfft,nyfft] #I array containing 2 real ffts +int nxfft #I x dimension of complex array +int nyfft #I y dimension of complex array + +int xcen, ycen +real fftr, ffti, ln1r, ln2r, ln1i, ln2i, cxr, cyr, cxi, cyi, ampr, ampi + +begin + + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + + # Compute the x amplitude for the first fft. + if (nxfft >= 8) { + + fftr = 0.5 * (fft[xcen+2,ycen] + fft[xcen-2,ycen]) + ffti = 0.5 * (fft[xcen+3,ycen] - fft[xcen-1,ycen]) + ln1r = log (sqrt (fftr ** 2 + ffti ** 2)) + fftr = 0.5 * (fft[xcen+4,ycen] + fft[xcen-4,ycen]) + ffti = 0.5 * (fft[xcen+5,ycen] - fft[xcen-3,ycen]) + ln2r = log (sqrt (fftr ** 2 + ffti ** 2)) + + fftr = 0.5 * (fft[xcen+3,ycen] + fft[xcen-1,ycen]) + ffti = -0.5 * (fft[xcen+2,ycen] - fft[xcen-2,ycen]) + ln1i = log (sqrt (fftr ** 2 + ffti ** 2)) + fftr = 0.5 * (fft[xcen+5,ycen] + fft[xcen-3,ycen]) + ffti = -0.5 * (fft[xcen+4,ycen] - fft[xcen-4,ycen]) + ln2i = log (sqrt (fftr ** 2 + ffti ** 2)) + + cxr = exp ((4.0 * ln1r - ln2r) / 3.0) + cxi = exp ((4.0 * ln1i - ln2i) / 3.0) + + } else { + + cxr = 0.0 + cxi = 0.0 + + } + + # Compute the y ratio. + if (nyfft >= 4) { + + fftr = 0.5 * (fft[xcen,ycen+1] + fft[xcen,ycen-1]) + ffti = 0.5 * (fft[xcen+1,ycen+1] - fft[xcen+1,ycen-1]) + ln1r = log (sqrt (fftr ** 2 + ffti ** 2)) + fftr = 0.5 * (fft[xcen,ycen+2] + fft[xcen,ycen-2]) + ffti = 0.5 * (fft[xcen+1,ycen+2] - fft[xcen+1,ycen-2]) + ln2r = log (sqrt (fftr ** 2 + ffti ** 2)) + + fftr = 0.5 * (fft[xcen+1,ycen+1] + fft[xcen+1,ycen-1]) + ffti = -0.5 * (fft[xcen,ycen+1] - fft[xcen,ycen-1]) + ln1i = log (sqrt (fftr ** 2 + ffti ** 2)) + fftr = 0.5 * (fft[xcen+1,ycen+2] + fft[xcen+1,ycen-2]) + ffti = -0.5 * (fft[xcen,ycen+2] - fft[xcen,ycen-2]) + ln2i = log (sqrt (fftr ** 2 + ffti ** 2)) + + cyr = exp ((4.0 * ln1r - ln2r) / 3.0) + cyi = exp ((4.0 * ln1i - ln2i) / 3.0) + + } else { + + cyr = 0.0 + cyi = 0.0 + + } + + if (cxr <= 0.0) + ampr = cyr + else if (cyr <= 0.0) + ampr = cxr + else + ampr = 0.5 * (cxr + cyr) + + if (cxi <= 0.0) + ampi = cyi + else if (cyi <= 0.0) + ampi = cxi + else + ampi = 0.5 * (cxi + cyi) + + if (ampi <= 0.0) + return (INDEFR) + else + return (ampr /ampi) +end + + +# RG_PDIVFFT -- Unpack the two fft's, save the first fft, and compute the +# quotient of the two ffts. + +procedure rg_pdivfft (fft1, fftnum, fftdenom, fft2, nxfft, nyfft) + +real fft1[nxfft,nyfft] # array containing 2 ffts of 2 real functions +real fftnum[nxfft,nyfft] # the numerator fft +real fftdenom[nxfft,nyfft] # the denominator fft +real fft2[nxfft,nyfft] # fft of psf matching function +int nxfft, nyfft # dimensions of fft + +int i, j, xcen, ycen, nxp2, nxp3, nyp2 +real c1, c2, h1r, h1i, h2r, h2i, denom + +begin + c1 = 0.5 + c2 = -0.5 + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + nxp2 = nxfft + 2 + nxp3 = nxfft + 3 + nyp2 = nyfft + 2 + + # Compute the 0 frequency point. + h1r = fft1[xcen,ycen] + h1i = 0.0 + h2r = fft1[xcen+1,ycen] + h2i = 0.0 + fftnum[xcen,ycen] = h1r + fftnum[xcen+1,ycen] = 0.0 + fftdenom[xcen,ycen] = h2r + fftdenom[xcen+1,ycen] = 0.0 + fft2[xcen,ycen] = h1r / h2r + fft2[xcen+1,ycen] = 0.0 + + #call eprintf ("fft11=%g fft21=%g\n") + #call pargr (fft1[1,1]) + #call pargr (fft1[2,1]) + + # Compute the first point. + h1r = c1 * (fft1[1,1] + fft1[1,1]) + h1i = 0.0 + h2r = -c2 * (fft1[2,1] + fft1[2,1]) + h2i = 0.0 + + fftnum[1,1] = h1r + fftnum[2,1] = h1i + fftdenom[1,1] = h2r + fftdenom[2,1] = h2i + denom = h2r * h2r + h2i * h2i + if (denom == 0.0) { + fft2[1,1] = 1.0 + fft2[2,1] = 0.0 + } else { + fft2[1,1] = (h1r * h2r + h1i * h2i) / denom + fft2[2,1] = (h1i * h2r - h2i * h1r) / denom + } + + # Compute the x symmetry axis points. + do i = 3, xcen - 1, 2 { + + h1r = c1 * (fft1[i,ycen] + fft1[nxp2-i,ycen]) + h1i = c1 * (fft1[i+1,ycen] - fft1[nxp3-i,ycen]) + h2r = -c2 * (fft1[i+1,ycen] + fft1[nxp3-i,ycen]) + h2i = c2 * (fft1[i,ycen] - fft1[nxp2-i,ycen]) + + fftnum[i,ycen] = h1r + fftnum[i+1,ycen] = h1i + fftnum[nxp2-i,ycen] = h1r + fftnum[nxp3-i,ycen] = -h1i + + fftdenom[i,ycen] = h2r + fftdenom[i+1,ycen] = h2i + fftdenom[nxp2-i,ycen] = h2r + fftdenom[nxp3-i,ycen] = -h2i + + denom = h2r * h2r + h2i * h2i + if (denom == 0.0) { + fft2[i,ycen] = 1.0 + fft2[i+1,ycen] = 0.0 + } else { + fft2[i,ycen] = (h1r * h2r + h1i * h2i) / denom + fft2[i+1,ycen] = (h1i * h2r - h2i * h1r) / denom + } + fft2[nxp2-i,ycen] = fft2[i,ycen] + fft2[nxp3-i,ycen] = -fft2[i+1,ycen] + + } + + # Quit if the transform is 1D. + if (nyfft < 2) + return + + # Compute the x axis points. + do i = 3, xcen + 1, 2 { + + h1r = c1 * (fft1[i,1] + fft1[nxp2-i,1]) + h1i = c1 * (fft1[i+1,1] - fft1[nxp3-i,1]) + h2r = -c2 * (fft1[i+1,1] + fft1[nxp3-i,1]) + h2i = c2 * (fft1[i,1] - fft1[nxp2-i,1]) + + fftnum[i,1] = h1r + fftnum[i+1,1] = h1i + fftnum[nxp2-i,1] = h1r + fftnum[nxp3-i,1] = -h1i + + fftdenom[i,1] = h2r + fftdenom[i+1,1] = h2i + fftdenom[nxp2-i,1] = h2r + fftdenom[nxp3-i,1] = -h2i + + denom = h2r * h2r + h2i * h2i + if (denom == 0) { + fft2[i,1] = 1.0 + fft2[i+1,1] = 0.0 + } else { + fft2[i,1] = (h1r * h2r + h1i * h2i) / denom + fft2[i+1,1] = (h1i * h2r - h2i * h1r) / denom + } + fft2[nxp2-i,1] = fft2[i,1] + fft2[nxp3-i,1] = -fft2[i+1,1] + } + + # Compute the y symmetry axis points. + do i = 2, ycen - 1 { + + h1r = c1 * (fft1[xcen,i] + fft1[xcen, nyp2-i]) + h1i = c1 * (fft1[xcen+1,i] - fft1[xcen+1,nyp2-i]) + h2r = -c2 * (fft1[xcen+1,i] + fft1[xcen+1,nyp2-i]) + h2i = c2 * (fft1[xcen,i] - fft1[xcen,nyp2-i]) + + fftnum[xcen,i] = h1r + fftnum[xcen+1,i] = h1i + fftnum[xcen,nyp2-i] = h1r + fftnum[xcen+1,nyp2-i] = -h1i + + fftdenom[xcen,i] = h2r + fftdenom[xcen+1,i] = h2i + fftdenom[xcen,nyp2-i] = h2r + fftdenom[xcen+1,nyp2-i] = -h2i + + denom = h2r * h2r + h2i * h2i + if (denom == 0.0) { + fft2[xcen,i] = 1.0 + fft2[xcen+1,i] = 0.0 + } else { + fft2[xcen,i] = (h1r * h2r + h1i * h2i) / denom + fft2[xcen+1,i] = (h1i * h2r - h2i * h1r) / denom + } + fft2[xcen,nyp2-i] = fft2[xcen,i] + fft2[xcen+1,nyp2-i] = -fft2[xcen+1,i] + + } + + # Compute the y axis points. + do i = 2, ycen { + + h1r = c1 * (fft1[1,i] + fft1[1,nyp2-i]) + h1i = c1 * (fft1[2,i] - fft1[2,nyp2-i]) + h2r = -c2 * (fft1[2,i] + fft1[2,nyp2-i]) + h2i = c2 * (fft1[1,i] - fft1[1,nyp2-i]) + + fftnum[1,i] = h1r + fftnum[2,i] = h1i + fftnum[1,nyp2-i] = h1r + fftnum[2,nyp2-i] = -h1i + + fftdenom[1,i] = h2r + fftdenom[2,i] = h2i + fftdenom[1,nyp2-i] = h2r + fftdenom[2,nyp2-i] = -h2i + + denom = h2r * h2r + h2i * h2i + if (denom == 0.0) { + fft2[1,i] = 1.0 + fft2[2,i] = 0.0 + } else { + fft2[1,i] = (h1r * h2r + h1i * h2i) / denom + fft2[2,i] = (h1i * h2r - h2i * h1r) / denom + } + fft2[1,nyp2-i] = fft2[1,i] + fft2[2,nyp2-i] = -fft2[2,i] + } + + # Compute the remainder of the transform. + do j = 2, ycen - 1 { + + do i = 3, xcen - 1, 2 { + + h1r = c1 * (fft1[i,j] + fft1[nxp2-i, nyp2-j]) + h1i = c1 * (fft1[i+1,j] - fft1[nxp3-i,nyp2-j]) + h2r = -c2 * (fft1[i+1,j] + fft1[nxp3-i,nyp2-j]) + h2i = c2 * (fft1[i,j] - fft1[nxp2-i,nyp2-j]) + + fftnum[i,j] = h1r + fftnum[i+1,j] = h1i + fftnum[nxp2-i,nyp2-j] = h1r + fftnum[nxp3-i,nyp2-j] = -h1i + + fftdenom[i,j] = h2r + fftdenom[i+1,j] = h2i + fftdenom[nxp2-i,nyp2-j] = h2r + fftdenom[nxp3-i,nyp2-j] = -h2i + + denom = h2r * h2r + h2i * h2i + if (denom == 0.0) { + fft2[i,j] = 1.0 + fft2[i+1,j] = 0.0 + } else { + fft2[i,j] = (h1r * h2r + h1i * h2i) / denom + fft2[i+1,j] = (h1i * h2r - h2i * h1r) / denom + } + fft2[nxp2-i,nyp2-j] = fft2[i,j] + fft2[nxp3-i,nyp2-j] = - fft2[i+1,j] + } + + do i = xcen + 2, nxfft, 2 { + + h1r = c1 * (fft1[i,j] + fft1[nxp2-i, nyp2-j]) + h1i = c1 * (fft1[i+1,j] - fft1[nxp3-i,nyp2-j]) + h2r = -c2 * (fft1[i+1,j] + fft1[nxp3-i,nyp2-j]) + h2i = c2 * (fft1[i,j] - fft1[nxp2-i,nyp2-j]) + + fftnum[i,j] = h1r + fftnum[i+1,j] = h1i + fftnum[nxp2-i,nyp2-j] = h1r + fftnum[nxp3-i,nyp2-j] = -h1i + + fftdenom[i,j] = h2r + fftdenom[i+1,j] = h2i + fftdenom[nxp2-i,nyp2-j] = h2r + fftdenom[nxp3-i,nyp2-j] = -h2i + + denom = h2r * h2r + h2i * h2i + if (denom == 0.0) { + fft2[i,j] = 1.0 + fft2[i+1,j] = 0.0 + } else { + fft2[i,j] = (h1r * h2r + h1i * h2i) / denom + fft2[i+1,j] = (h1i * h2r - h2i * h1r) / denom + } + fft2[nxp2-i,nyp2-j] = fft2[i,j] + fft2[nxp3-i,nyp2-j] = - fft2[i+1,j] + + } + } +end + + +# RG_PNORM -- Insert the normalization value into the 0 frequency of the +# fft. The fft is a 2D fft stored in a real array in complex order. +# The fft is assumed to be centered. + +procedure rg_pnorm (fft, nxfft, nyfft, norm) + +real fft[ARB] #I the input fft +int nxfft #I the x dimension of fft (complex storage) +int nyfft #I the y dimension of the fft +real norm #I the flux ratio + +int index + +begin + index = nxfft + 1 + 2 * (nyfft / 2) * nxfft + fft[index] = norm + fft[index+1] = 0.0 +end diff --git a/pkg/images/immatch/src/psfmatch/rgpfilter.x b/pkg/images/immatch/src/psfmatch/rgpfilter.x new file mode 100644 index 00000000..63040b63 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpfilter.x @@ -0,0 +1,502 @@ +include <math.h> + +# RG_PCOSBELL -- Apply a cosine bell function to the data. + +procedure rg_pcosbell (fft, nxfft, nyfft, sx1, sx2, sy1, sy2, radsym) + +real fft[ARB] #I/O the ifft to be filtered +int nxfft #I the x dimension of the fft +int nyfft #I the y dimension of the fft +real sx1 #I inner x radius of the cosine bell filter +real sx2 #I outer x radius of the cosine bell filter +real sy1 #I inner y radius of the cosine bell filter +real sy2 #I outer y radius of the cosine bell filter +int radsym #I radial symmetry ? + +int i, j, index, xcen, ycen +real factorx, factory, r1, r2, r, rj, cos2 + +begin + # Compute the center of the fft. + xcen = (nxfft / 2) + 1 + ycen = (nyfft / 2) + 1 + + if (radsym == NO) { + + # Filter in the y direction independently. + if (IS_INDEFR(sy1)) + r1 = 0.0 + else + r1 = sy1 + if (IS_INDEFR(sy2)) + r2 = nyfft - ycen + 1 + else + r2 = sy2 + factory = HALFPI / (r2 - r1) + index = 1 + do j = 1, nyfft { + r = abs (ycen - j) + if (r >= r2) + cos2 = 0.0 + else if (r <= r1) + cos2 = 1.0 + else + cos2 = cos ((r - r1) * factory) ** 2 + call amulkr (fft[index], cos2, fft[index], 2 * nxfft) + index = index + 2 * nxfft + } + + # Filter in the x direction independently. + if (IS_INDEFR(sx1)) + r1 = 0.0 + else + r1 = sx1 + if (IS_INDEFR(sx2)) + r2 = nxfft - xcen + 1 + else + r2 = sx2 + factorx = HALFPI / (r2 - r1) + + do i = 1, nxfft { + r = abs (xcen - i) + if (r >= r2) + cos2 = 0.0 + else if (r <= r1) + cos2 = 1.0 + else + cos2 = cos ((r - r1) * factorx) ** 2 + do j = 2 * i - 1, 2 * nxfft * nyfft, 2 * nxfft { + fft[j] = fft[j] * cos2 + fft[j+1] = fft[j+1] * cos2 + } + } + + } else { + + if (IS_INDEFR(sx1) && IS_INDEFR(sy1)) + r1 = 0.0 + else if (IS_INDEFR(sx1)) + r1 = sy1 + else if (IS_INDEFR(sy1)) + r1 = sx1 + else + r1 = (sx1 + sy1) / 2.0 + if (IS_INDEFR(sx2) && IS_INDEFR(sy2)) + r2 = (nxfft - xcen + 1 + nyfft - ycen + 1) / 2.0 + else if (IS_INDEFR(sx2)) + r2 = sy2 + else if (IS_INDEFR(sy2)) + r2 = sx2 + else + r2 = (sx2 + sy2) / 2.0 + factorx = HALFPI / (r2 - r1) + + index = 0 + do j = 1, nyfft { + rj = (ycen - j) ** 2 + do i = 1, nxfft { + r = sqrt ((i - xcen) ** 2 + rj) + if (r >= r2) { + fft[index+2*i-1] = 0.0 + fft[index+2*i] = 0.0 + } else if (r > r1) { + fft[index+2*i-1] = fft[index+2*i-1] * cos ((r - r1) * + factorx) ** 2 + fft[index+2*i] = fft[index+2*i] * cos ((r - r1) * + factorx) ** 2 + } + } + index = index + 2 * nxfft + } + } +end + + +# RG_PREPLACE -- Replace low valued regions in the kernel fft with a Gaussian +# extension. + +procedure rg_preplace (fft, fftdiv, nxfft, nyfft, pthreshold, norm) + +real fft[ARB] #I/O the fft of the kernel +real fftdiv[ARB] #I the divisor fft +int nxfft #I x dimension of the fft (complex storage) +int nyfft #I y dimension of the fft +real pthreshold #I the minimum percent amplitude in the divisor +real norm #I the normalization value + +pointer sp, params +int xcen, ycen, i, j, ri, rj, index +real divpeak, a1, a2, a3, u, v, divisor, absv, phi + +begin + call smark (sp) + call salloc (params, 5, TY_REAL) + + # Compute the central amplitude peak. + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + divpeak = pthreshold * fftdiv[1+nxfft+2*(ycen-1)*nxfft] + + # Fit the parameters. + call rg_pgaussfit (fft, fftdiv, nxfft, nyfft, divpeak, norm, + Memr[params]) + + # Store the parameters in temporary variables. + a1 = Memr[params] + a2 = Memr[params+1] + a3 = Memr[params+2] + u = Memr[params+3] + v = Memr[params+4] + + # Perform the extension. + index = 0 + do j = 1, nyfft { + rj = j - ycen + do i = 1, nxfft { + ri = i - xcen + divisor = sqrt (fftdiv[index+2*i-1] ** 2 + + fftdiv[index+2*i] ** 2) + if (divisor < divpeak) { + absv = norm * exp (a1 * ri * ri + a2 * ri * rj + a3 * + rj * rj) + phi = u * ri + v * rj + fft[index+2*i-1] = absv * cos (phi) + fft[index+2*i] = absv * sin (phi) + } + } + index = index + 2 * nxfft + } + + # Correct the first row. + do i = 1, 2 * nxfft, 2 { + fft[i] = sqrt (fft[i] ** 2 + fft[i+1] ** 2) + fft[i+1] = 0.0 + } + + # Correct the first column. + index = 1 + do j = 2, nyfft { + fft[index] = sqrt (fft[index] ** 2 + fft[index+1] ** 2) + fft[index+1] = 0.0 + index = index + 2 * nxfft + } + + call sfree (sp) +end + + +# RG_PGMODEL -- Replace low values with a Gaussian mode. + +procedure rg_pgmodel (fft, fftdiv, nxfft, nyfft, pthreshold, norm) + +real fft[ARB] #I/O the fft of the kernel +real fftdiv[ARB] #I the divisor fft +int nxfft #I the x dimension of the fft +int nyfft #I the y dimension of the fft +real pthreshold #I the minimum percent amplitude in the divisor +real norm #I the normalization factor + +pointer sp, params +int xcen, ycen, i, j, index +real divpeak, a1, a2, a3, u, v, absv, phi, ri, rj + +begin + call smark (sp) + call salloc (params, 5, TY_REAL) + + # Compute the central amplitude peak. + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + divpeak = pthreshold * fftdiv[1+nxfft+2*(ycen-1)*nxfft] + + # Fit the parameters. + call rg_pgaussfit (fft, fftdiv, nxfft, nyfft, divpeak, norm, + Memr[params]) + + # Store the parameters in temporary variables + a1 = Memr[params] + a2 = Memr[params+1] + a3 = Memr[params+2] + u = Memr[params+3] + v = Memr[params+4] + + # Perform the extension. + index = 0 + do j = 1, nyfft { + rj = j - ycen + do i = 1, nxfft { + ri = i - xcen + absv = norm * exp (a1 * ri * ri + a2 * ri * rj + a3 * rj * rj) + phi = u * ri + v * rj + fft[index+2*i-1] = absv * cos (phi) + fft[index+2*i] = absv * sin (phi) + } + index = index + 2 * nxfft + } + + # Correct the first row. + do i = 1, 2 * nxfft, 2 { + fft[i] = sqrt (fft[i] ** 2 + fft[i+1] ** 2) + fft[i+1] = 0.0 + } + + # Correct the first column. + index = 1 + do j = 2, nyfft { + fft[index] = sqrt (fft[index] ** 2 + fft[index+1] ** 2) + fft[index+1] = 0.0 + index = index + 2 * nxfft + } + + call sfree (sp) +end + + +# RG_PGAUSSFIT -- Procedure to compute the Gaussian parameters + +procedure rg_pgaussfit (fft, fftdiv, nxfft, nyfft, divpeak, norm, param) + +real fft[ARB] #I the fft of the kernel +real fftdiv[ARB] #I the divisor fft +int nxfft #I the x dimension of the fft +int nyfft #I the y dimension of the fft +real divpeak #I the minimum value in the divisor +real norm #I the normalization value norm value +real param[ARB] #O the output fitted parameters + +int i, j, yj, xcen, ycen +double x, y, x2, xy, y2, z, wt, x2w, y2w, xyw, zw, xzw, yzw +double sxxxx, sxxxy, sxxyy, sxyyy, syyyy, sxxz, sxyz, syyz, sxx, sxy +double syy, sxz, syz +pointer sp, mat +real divisor + +begin + # Allocate temporary space. + call smark (sp) + call salloc (mat, 12, TY_DOUBLE) + + # Define the center of the fft. + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + + # Initialize. + sxxxx = 0.0d0 + sxxxy = 0.0d0 + sxxyy = 0.0d0 + sxyyy = 0.0d0 + syyyy = 0.0d0 + sxxz = 0.0d0 + sxyz = 0.0d0 + syyz = 0.0d0 + sxx = 0.0d0 + sxy = 0.0d0 + syy = 0.0d0 + sxz = 0.0d0 + syz = 0.0d0 + + do i = 1, nxfft { + x = i - xcen + yj = - ycen + do j = 2 * i - 1, 2 * nxfft * nyfft, 2 * nxfft { + yj = yj + 1 + y = yj + + # Skip low points in the fit. + divisor = sqrt (fftdiv[j] ** 2 + fftdiv[j+1] ** 2) + if (divisor < divpeak) + next + if (i == xcen || yj == ycen) + next + + # Accumulate the intermediate products. + divisor = sqrt (fft[j] ** 2 + fft[j+1] ** 2) + if (divisor <= 0.0) + next + z = log (divisor / norm) + x2 = x * x + y2 = y * y + wt = 1.0 / sqrt (x2 + y2) + xy = x * y + x2w = x2 * wt + y2w = y2 * wt + xyw = xy * wt + zw = z * wt + xzw = x * zw + yzw = y * zw + + # Accumulate the sums for the Gaussian. + sxxxx = sxxxx + x2 * x2w + sxxxy = sxxxy + x2 * xyw + sxxyy = sxxyy + x2 * y2w + sxyyy = sxyyy + xy * y2w + syyyy = syyyy + y2 * y2w + sxxz = sxxz + x * xzw + sxyz = sxyz + x * yzw + syyz = syyz + y * yzw + + # New weight and z point. + wt = sqrt (fft[j] ** 2 + fft[j+1] ** 2) / norm + z = atan2 (fft[j+1], fft[j]) + + # Accumulate the sums for the shift determinantion. + sxx = sxx + x2 * wt + sxy = sxy + xy * wt + syy = syy + y2 * wt + sxz = sxz + x * z * wt + syz = syz + y * z * wt + } + } + + # Solve for the gaussian. + Memd[mat] = sxxxx + Memd[mat+1] = sxxxy + Memd[mat+2] = sxxyy + Memd[mat+3] = sxxz + Memd[mat+4] = sxxxy + Memd[mat+5] = sxxyy + Memd[mat+6] = sxyyy + Memd[mat+7] = sxyz + Memd[mat+8] = sxxyy + Memd[mat+9] = sxyyy + Memd[mat+10] = syyyy + Memd[mat+11] = syyz + call rg_pgelim (Memd[mat], 3) + param[1] = Memd[mat+3] + param[2] = Memd[mat+7] + param[3] = Memd[mat+11] + + # Solve for the shift. + Memd[mat] = sxx + Memd[mat+1] = sxy + Memd[mat+2] = sxz + Memd[mat+3] = sxy + Memd[mat+4] = syy + Memd[mat+5] = syz + call rg_pgelim (Memd[mat], 2) + param[4] = Memd[mat+2] + param[5] = Memd[mat+5] + + call sfree (sp) +end + + +# RG_PGELIM -- Solve a matrix using Gaussian elimination. + +procedure rg_pgelim (a, n) + +double a[n+1,n] #I/O matrix to be solved +int n #I number of variables + +int i, j, k +double den, hold + +begin + do k = 1, n { + + den = a[k,k] + if (den == 0.0d0) { # look for non-zero switch + do j = k + 1, n { + if (a[k,k] != 0.0d0) { + do i = k, n + 1 { + hold = a[i,j] + a[i,j] = a[i,k] + a[i,k] = hold + } + den = a[k,k] + } + } + if (den == 0.0d0) # if still zero, skip + next + } + + do i = k, n + 1 + a[i,k] = a[i,k] / den + do j = 1, n { + if (j != k) { + den = a[k,j] + do i = k, n + 1 + a[i,j] = a[i,j] - a[i,k] * den + } + } + } +end + + +# RG_PNORMFILT -- Filter out any values greater than the normalization +# from the kernel fft. + +procedure rg_pnormfilt (fft, nxfft, nyfft, norm) + +real fft[ARB] #I/O the input fft +int nxfft #I the x length of the fft +int nyfft #I the y length of the fft +real norm #I the normalization factor + +int j, i_index + +begin + do j = 1, nyfft { + i_index = 1 + 2 * (j - 1) * nxfft + call rg_pnreplace (fft[i_index], nxfft, norm) + } +end + + +# RG_PFOURIER -- Compute the fourier spectrum of the convolution kernel. + +procedure rg_pfourier (fft, psfft, nxfft, nyfft) + +real fft[ARB] # the input fft +real psfft[ARB] # fourier spectrum of the fft +int nxfft # the x dimension of the fft +int nyfft # the y dimension of the fft + +int j, i_index, o_index + +begin + do j = 1, nyfft { + i_index = 1 + 2 * (j - 1) * nxfft + o_index = 1 + (j - 1) * nxfft + call rg_pvfourier (fft[i_index], psfft[o_index], nxfft) + } +end + + +# RG_PVFOURIER -- Procedure to compute the fourier spectrum of a vector. + +procedure rg_pvfourier (a, b, nxfft) + +real a[ARB] # input vector in complex storage order +real b[ARB] # output vector in real storage order +int nxfft # length of vector + +int i + +begin + do i = 1, nxfft + b[i] = sqrt (a[2*i-1] ** 2 + a[2*i] ** 2) +end + + +# RG_PNREPLACE -- Replace values whose absolute value is greater than the +# flux ratio. + +procedure rg_pnreplace (a, nxfft, norm) + +real a[ARB] #I/O ithe nput vector in complex storage order +int nxfft #I the length of the vector +real norm #I the flux ratio + +int i +real val + +begin + do i = 1, 2 * nxfft, 2 { + val = sqrt (a[i] ** 2 + a[i+1] ** 2) + if (val > norm) { + a[i] = a[i] / val * norm + a[i+1] = a[i+1] / val * norm + } + } +end diff --git a/pkg/images/immatch/src/psfmatch/rgpisfm.x b/pkg/images/immatch/src/psfmatch/rgpisfm.x new file mode 100644 index 00000000..24df8fd7 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpisfm.x @@ -0,0 +1,556 @@ +include <imhdr.h> +include <ctype.h> +include <gset.h> +include "psfmatch.h" + +define HELPFILE "immatch$src/psfmatch/psfmatch.key" + +# Define the plot functions + +define PM_PPOWER 1 +define PM_PKERNEL 2 + +# Define the plot types + +define PM_PCONTOUR 1 +define PM_PLINE 2 +define PM_PCOL 3 + +# RG_PISFM -- Procedure to compute the shifts interactively. + +int procedure rg_pisfm (pm, imr, reglist, impsf, im1, imk, imp, im2, gd, id) + +pointer pm #I pointer to the psfmatch structure +pointer imr #I/O pointer to the reference image/psf +pointer reglist #I/O pointer to the regions list +pointer impsf #I/O pointer to the input psf +pointer im1 #I/O pointer to the input image +pointer imp #I/O pointer to the fourier spectrum image +pointer imk #I/O pointer to the kernel image +pointer im2 #I/O pointer to the output image +pointer gd #I graphics stream pointer +pointer id #I display stream pointer + +int newref, newimage, newfourier, newfilter, plotfunc, plottype, wcs, key +int newplot, ncolr, nliner, ip +pointer sp, cmd +real wx, wy +int rg_pstati(), rg_psfm(), clgcur(), rg_pgqverify(), rg_pgtverify() +int ctoi(), rg_pregions() +pointer rg_pstatp() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + newref = YES + newimage = YES + newfourier = YES + newfilter = YES + ncolr = INDEFI + nliner = INDEFI + plotfunc = PM_PKERNEL + plottype = PM_PCONTOUR + + # Compute the convolution kernel for the current image. + if (rg_pstati (pm, CONVOLUTION) == PM_CONIMAGE && rg_pstati (pm, + NREGIONS) <= 0) { + call gclear (gd) + call gflush (gd) + call printf ("The objects list is empty\n") + } else { + if (rg_psfm (pm, imr, im1, impsf, imk, newref) == OK) { + call rg_pplot (gd, pm, ncolr, nliner, plotfunc, plottype) + newref = NO + newimage = NO + newfourier = NO + newfilter = NO + } else { + call gclear (gd) + call gflush (gd) + call rg_pstats (pm, IMAGE, Memc[cmd], SZ_FNAME) + call printf ("Error computing kernel for image %s\n") + call pargstr (Memc[cmd]) + } + } + newplot = NO + + # Loop over the cursor commands. + while (clgcur ("gcommands", wx, wy, wcs, key, Memc[cmd], SZ_LINE) != + EOF) { + + switch (key) { + + # Print the help page. + case '?': + call gpagefile (gd, HELPFILE, "") + + # Quit the task gracefully. + case 'q': + if (rg_pgqverify ("psfmatch", pm, imk, key) == YES) { + call sfree (sp) + return (rg_pgtverify (key)) + } + + # Process colon commands. + case ':': + for (ip = 1; IS_WHITE(Memc[cmd+ip-1]); ip = ip + 1) + ; + switch (Memc[cmd+ip-1]) { + + case 'x': + if (Memc[cmd+ip] != EOS && Memc[cmd+ip] != ' ') { + call rg_pcolon (gd, pm, imr, reglist, impsf, im1, imk, + NULL, im2, Memc[cmd], newref, newimage, + newfourier, newfilter) + } else { + ip = ip + 1 + if (ctoi (Memc[cmd], ip, ncolr) <= 0) { + switch (plotfunc) { + case PM_PPOWER: + ncolr = rg_pstati (pm, NXFFT) / 2 + 1 + case PM_PKERNEL: + ncolr = rg_pstati (pm, KNX) / 2 + 1 + default: + ncolr = rg_pstati (pm, KNX) / 2 + 1 + } + } + plottype = PM_PCOL + newplot = YES + } + + case 'y': + if (Memc[cmd+ip] != EOS && Memc[cmd+ip] != ' ') { + call rg_pcolon (gd, pm, imr, reglist, impsf, im1, imk, + NULL, im2, Memc[cmd], newref, newimage, + newfourier, newfilter) + } else { + ip = ip + 1 + if (ctoi (Memc[cmd], ip, nliner) <= 0) { + switch (plotfunc) { + case PM_PPOWER: + nliner = rg_pstati (pm, NYFFT) / 2 + 1 + case PM_PKERNEL: + nliner = rg_pstati (pm, KNY) / 2 + 1 + default: + nliner = rg_pstati (pm, KNY) / 2 + 1 + } + } + plottype = PM_PLINE + newplot = YES + } + + + default: + call rg_pcolon (gd, pm, imr, reglist, impsf, im1, imk, NULL, + im2, Memc[cmd], newref, newimage, newfourier, + newfilter) + } + + # Write the parameters to the parameter file. + case 'w': + call rg_pppars (pm) + + # Recompute the convolution kernel function. + case 'f': + + if (rg_pstati(pm,CONVOLUTION) == PM_CONIMAGE) { + if (newref == YES) + if (rg_pregions (reglist, imr, pm, 1, YES) > 0) + ; + else if (newimage == YES) + call rg_pindefr (pm) + } + + if (rg_pstati (pm, NREGIONS) > 0 || rg_pstati (pm, + CONVOLUTION) != PM_CONIMAGE) { + + if (newfourier == YES) { + call printf ( + "\nRecomputing convolution kernel ...\n") + if (rg_psfm (pm, imr, im1, impsf, imk, + newref) == OK) { + ncolr = INDEFI + nliner = INDEFI + call rg_pplot (gd, pm, ncolr, nliner, plotfunc, + plottype) + newref = NO + newimage = NO + newfourier = NO + newfilter = NO + newplot = NO + } else + call printf ( + "\nError computing new kernel ...\n") + } + + if (newfilter == YES) { + if (Memr[rg_pstatp(pm,FFT)] != NULL) { + call rg_pfilter (pm) + ncolr = INDEFI + nliner = INDEFI + call rg_pplot (gd, pm, ncolr, nliner, plotfunc, + plottype) + newfilter = NO + newplot = NO + } else + call printf ( + "The kernel fourier spectrum is undefined\n") + } + + } else + call printf ("The objects list is empty\n") + + # Draw a contour plot of the kernel. + case 'k': + if (plotfunc != PM_PKERNEL) + newplot = YES + if (plottype != PM_PCONTOUR) + newplot = YES + plotfunc = PM_PKERNEL + plottype = PM_PCONTOUR + ncolr = (1 + rg_pstati (pm, KNX)) / 2 + nliner = (1 + rg_pstati (pm, KNY)) / 2 + + # Draw a contour plot of the fourier spectrum. + case 'p': + if (plotfunc != PM_PPOWER) + newplot = YES + if (plottype != PM_PCONTOUR) + newplot = YES + plotfunc = PM_PPOWER + plottype = PM_PCONTOUR + ncolr = (1 + rg_pstati (pm, NXFFT)) / 2 + nliner = (1 + rg_pstati (pm, NYFFT)) / 2 + + # Plot a line of the current plot. + case 'x': + if (plottype != PM_PCOL) + newplot = YES + if (plottype == PM_PCONTOUR) { + ncolr = nint (wx) + nliner = nint (wy) + } else if (plottype == PM_PLINE) { + ncolr = nint (wx) + } + plottype = PM_PCOL + + # Plot a line of the current plot. + case 'y': + if (plottype != PM_PLINE) + newplot = YES + if (plottype == PM_PCONTOUR) { + ncolr = nint (wx) + nliner = nint (wy) + } else if (plottype == PM_PCOL) { + ncolr = nint (wx) + } + plottype = PM_PLINE + + # Redraw the current plot. + case 'r': + newplot = YES + + # Do nothing gracefully. + default: + ; + + } + + if (newplot == YES) { + if (rg_pstati (pm, CONVOLUTION) == PM_CONIMAGE && + rg_pstati (pm, NREGIONS) <= 0) { + call printf ("Warning: The objects list is empty\n") + } else if (newref == YES || newimage == YES || + newfourier == YES || newfilter == YES) { + call printf ( + "Warning: Convolution kernel should be refit\n") + } else if (rg_pstatp (pm, CONV) != NULL) { + call rg_pplot (gd, pm, ncolr, nliner, plotfunc, plottype) + newplot = NO + } else { + call printf ( + "Warning: The convolution kernel is undefined\n") + } + } + + } + + call sfree (sp) +end + + +define QUERY "[Hit return to continue, n next image, q quit, w quit and update parameters]" + +# RG_PGQVERIFY -- Print a message in the status line asking the user if they +# really want to quit, returning YES if they really want to quit, NO otherwise. + +int procedure rg_pgqverify (task, pm, imk, ch) + +char task[ARB] # task name +pointer pm # pointer to psfmatch structure +pointer imk # pointer to kernel image +int ch # character keystroke command + +int wcs, stat +pointer sp, cmd +real wx, wy +bool streq() +int clgcur(), rg_pstati() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Print the status line query in reverse video and get the keystroke. + call printf (QUERY) + if (clgcur ("gcommands", wx, wy, wcs, ch, Memc[cmd], SZ_LINE) == EOF) + ; + + # Process the command. + if (ch == 'q') { + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL) + call rg_pwrite (pm, imk, NULL) + stat = YES + } else if (ch == 'w') { + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL) + call rg_pwrite (pm, imk, NULL) + if (streq ("psfmatch", task)) + call rg_pppars (pm) + stat = YES + } else if (ch == 'n') { + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL) + call rg_pwrite (pm, imk, NULL) + stat = YES + } else { + stat = NO + } + + call sfree (sp) + + return (stat) +end + + +# RG_PGTVERIFY -- Verify whether or not the user truly wishes to quit the +# task. + +int procedure rg_pgtverify (ch) + +int ch #I the input keystroke command + +begin + if (ch == 'q') { + return (YES) + } else if (ch == 'w') { + return (YES) + } else if (ch == 'n') { + return (NO) + } else { + return (NO) + } +end + + +# RG_PPLOT -- Draw the default plot of the kernel fourier spectrum or the +# kernel itself. + +procedure rg_pplot (gd, pm, col, line, plotfunc, plottype) + +pointer gd #I pointer to the graphics stream +pointer pm #I pointer to the psfmatch structure +int col #I column of cross-correlation function to plot +int line #I line of cross-correlation function to plot +int plotfunc #I the default plot function type +int plottype #I the default plot type + +int nx, ny +pointer sp, title, str, data +int rg_pstati(), strlen() +pointer rg_pstatp() + +begin + if (gd == NULL) + return + + # Allocate working space. + call smark (sp) + call salloc (title, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Initialize the plot title and data. + switch (plotfunc) { + case PM_PPOWER: + call sprintf (Memc[title], SZ_LINE, + "Fourier Spectrum for Reference: %s Image: %s") + call rg_pstats (pm, REFIMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call rg_pstats (pm, IMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + data = rg_pstatp (pm, ASFFT) + nx = rg_pstati (pm, NXFFT) + ny = rg_pstati (pm, NYFFT) + case PM_PKERNEL: + call sprintf (Memc[title], SZ_LINE, + "Convolution Kernel for Reference: %s Image: %s") + call rg_pstats (pm, REFIMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call rg_pstats (pm, IMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + data = rg_pstatp (pm, CONV) + nx = rg_pstati (pm, KNX) + ny = rg_pstati (pm, KNY) + default: + call sprintf (Memc[title], SZ_LINE, + "Convolution Kernel for Reference: %s Image: %s") + call rg_pstats (pm, REFIMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call rg_pstats (pm, IMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + data = rg_pstatp (pm, CONV) + nx = rg_pstati (pm, KNX) + nx = rg_pstati (pm, KNY) + } + if (IS_INDEFI(col)) + col = 1 + nx / 2 + if (IS_INDEFI(line)) + line = 1 + ny / 2 + + # Draw the plot. + if (ny == 1) { + switch (plotfunc) { + case PM_PPOWER: + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nLine %d") + call pargi (1) + call rg_pcpline (gd, Memc[title], Memr[rg_pstatp(pm,ASFFT)], + nx, ny, 1) + case PM_PKERNEL: + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nLine %d") + call pargi (1) + call rg_pcpline (gd, Memc[title], Memr[rg_pstatp(pm,CONV)], + nx, ny, 1) + default: + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nLine %d") + call pargi (1) + call rg_pcpline (gd, Memc[title], Memr[rg_pstatp(pm,CONV)], + nx, ny, 1) + } + } else { + switch (plottype) { + case PM_PCONTOUR: + call rg_contour (gd, Memc[title], "", Memr[data], nx, ny) + case PM_PLINE: + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nLine %d") + call pargi (line) + call rg_pcpline (gd, Memc[title], Memr[data], nx, ny, line) + case PM_PCOL: + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nColumn %d") + call pargi (col) + call rg_pcpcol (gd, Memc[title], Memr[data], nx, ny, col) + default: + call rg_contour (gd, Memc[title], "", Memr[data], nx, ny) + } + } + + call sfree (sp) +end + + +# RG_PCPLINE -- Plot a line of a 2D function. + +procedure rg_pcpline (gd, title, data, nx, ny, nline) + +pointer gd #I pointer to the graphics stream +char title[ARB] #I title for the plot +real data[nx,ARB] #I the input data array +int nx, ny #I dimensions of the input data array +int nline #I the line number + +int i +pointer sp, str, x +real ymin, ymax + +begin + # Return if no graphics stream. + if (gd == NULL) + return + + # Check for valid line number. + if (nline < 1 || nline > ny) + return + + # Allocate some working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (x, nx, TY_REAL) + + # Initialize the data. + do i = 1, nx + Memr[x+i-1] = i + call alimr (data[1,nline], nx, ymin, ymax) + + # Set up the labels and the axes. + call gclear (gd) + call gswind (gd, 1.0, real (nx), ymin, ymax) + call glabax (gd, title, "X Lag", "X-Correlation Function") + + # Plot the line profile. + call gseti (gd, G_PLTYPE, GL_SOLID) + call gpline (gd, Memr[x], data[1,nline], nx) + call gflush (gd) + + call sfree (sp) +end + + +# RG_PCPCOL -- Plot a column of the cross-correlation function. + +procedure rg_pcpcol (gd, title, data, nx, ny, ncol) + +pointer gd #I pointer to the graphics stream +char title[ARB] #I title of the column plot +real data[nx,ARB] #I the input data array +int nx, ny #I the dimensions of the input data array +int ncol #I line number + +int i +pointer sp, x, y +real ymin, ymax + +begin + # Return if no graphics stream. + if (gd == NULL) + return + + # Check for valid column number. + if (ncol < 1 || ncol > nx) + return + + # Initialize. + call smark (sp) + call salloc (x, ny, TY_REAL) + call salloc (y, ny, TY_REAL) + + # Get the data to be plotted. + do i = 1, ny { + Memr[x+i-1] = i + Memr[y+i-1] = data[ncol,i] + } + call alimr (Memr[y], ny, ymin, ymax) + + # Set up the labels and the axes. + call gclear (gd) + call gswind (gd, 1.0, real (ny), ymin, ymax) + call glabax (gd, title, "Y Lag", "X-Correlation Function") + + # Plot the profile. + call gseti (gd, G_PLTYPE, GL_SOLID) + call gpline (gd, Memr[x], Memr[y], ny) + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/psfmatch/rgppars.x b/pkg/images/immatch/src/psfmatch/rgppars.x new file mode 100644 index 00000000..c8d49baa --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgppars.x @@ -0,0 +1,124 @@ +include "psfmatch.h" + +# RG_PGPARS -- Read in the psf matching algorithm parameters. + +procedure rg_pgpars (pm) + +pointer pm #I pointer to psfmatch structure + +int ival +pointer sp, str +bool clgetb() +int clgwrd(), clgeti(), btoi() +real clgetr() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Initialize the psf matching structure. + call rg_pinit (pm, clgwrd ("convolution", Memc[str], SZ_LINE, + PM_CTYPES)) + + # Define the data and kernel sizes. + ival = clgeti ("dnx") + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, DNX, ival) + ival = clgeti ("dny") + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, DNY, ival) + ival = clgeti ("pnx") + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, PNX, ival) + ival = clgeti ("pny") + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, PNY, ival) + + # Centering parameters. + call rg_pseti (pm, CENTER, btoi (clgetb ("center"))) + + # Background value computation. + call clgstr ("background", Memc[str], SZ_LINE) + call rg_psets (pm, BSTRING, Memc[str]) + call rg_psetr (pm, LOREJECT, clgetr ("loreject")) + call rg_psetr (pm, HIREJECT, clgetr ("hireject")) + call rg_psetr (pm, APODIZE, clgetr ("apodize")) + + # Filtering parameters. + call rg_psetr (pm, UFLUXRATIO, clgetr ("fluxratio")) + call clgstr ("filter", Memc[str], SZ_LINE) + call rg_psets (pm, FSTRING, Memc[str]) + call rg_psetr (pm, SXINNER, clgetr ("sx1")) + call rg_psetr (pm, SXOUTER, clgetr ("sx2")) + call rg_psetr (pm, SYINNER, clgetr ("sy1")) + call rg_psetr (pm, SYOUTER, clgetr ("sy2")) + call rg_pseti (pm, RADSYM, btoi (clgetb ("radsym"))) + call rg_psetr (pm, THRESHOLD, (clgetr ("threshold"))) + + # Normalization parameter. + call rg_psetr (pm, NORMFACTOR, clgetr ("normfactor")) + + #call rg_psetr (pm, PRATIO, clgetr ("pratio")) + + call sfree (sp) +end + + +# RG_PPPARS -- Put the parameters required for the psf matching from +# the cl to the parameter file. + +procedure rg_pppars (pm) + +pointer pm #I pointer to the psf matching structure + +pointer sp, str +bool itob() +int rg_pstati() +real rg_pstatr() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Store the psf data string. + call rg_pstats (pm, PSFDATA, Memc[str], SZ_LINE) + call clpstr ("psf", Memc[str]) + + # Store the size parameters. + call clputi ("dnx", rg_pstati (pm, DNX)) + call clputi ("dny", rg_pstati (pm, DNY)) + call clputi ("pnx", rg_pstati (pm, PNX)) + call clputi ("pny", rg_pstati (pm, PNY)) + + # Store the centering parameters. + call clputb ("center", itob (rg_pstati (pm, CENTER))) + + # Store the background fitting parameters. + call rg_pstats (pm, BSTRING, Memc[str], SZ_LINE) + call clpstr ("background", Memc[str]) + call clputr ("loreject", rg_pstatr (pm, LOREJECT)) + call clputr ("hireject", rg_pstatr (pm, HIREJECT)) + call clputr ("apodize", rg_pstatr (pm, APODIZE)) + + # Store the filtering parameters. + call clputr ("fluxratio", rg_pstatr(pm, UFLUXRATIO)) + call rg_pstats (pm, FSTRING, Memc[str], SZ_LINE) + call clpstr ("filter", Memc[str]) + call clputr ("sx1", rg_pstatr (pm, SXINNER)) + call clputr ("sx2", rg_pstatr (pm, SXOUTER)) + call clputr ("sy1", rg_pstatr (pm, SYINNER)) + call clputr ("sy2", rg_pstatr (pm, SYOUTER)) + call clputb ("radsym", itob (rg_pstati (pm, RADSYM))) + call clputr ("threshold", rg_pstatr (pm, THRESHOLD)) + + # Store the normalization parameters. + call clputr ("normfactor", rg_pstatr (pm, NORMFACTOR)) + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/psfmatch/rgpregions.x b/pkg/images/immatch/src/psfmatch/rgpregions.x new file mode 100644 index 00000000..c04dcf97 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpregions.x @@ -0,0 +1,464 @@ +include <fset.h> +include <imhdr.h> +include "psfmatch.h" + +# RG_PREGIONS -- Decoode the regions specification. If the sections +# string is NULL then a default region dnx by dny pixels wide centered +# on the reference image is used. Otherwise the section centers are +# read from the regions string or from the objects list. + +int procedure rg_pregions (list, im, pm, rp, reread) + +int list #I pointer to regions file list +pointer im #I pointer to the image +pointer pm #I pointer to the psfmatch structure +int rp #I region pointer +int reread #I reread the current file + +char fname[SZ_FNAME] +int nregions, fd +int open(), rg_prregions(), rg_pgregions(), fntgfnb() +int rg_pstati() +data fname[1] /EOS/ +errchk open(), fntgfnb(), close() + +begin + if (rp < 1 || rp > MAX_NREGIONS) { + nregions = 0 + } else if (rg_pgregions (im, pm, rp, MAX_NREGIONS) > 0) { + nregions = rg_pstati (pm, NREGIONS) + } else if (list != NULL) { + if (reread == NO) { + iferr { + if (fntgfnb (list, fname, SZ_FNAME) != EOF) { + fd = open (fname, READ_ONLY, TEXT_FILE) + nregions= rg_prregions (fd, im, pm, rp, MAX_NREGIONS) + call close (fd) + } + } then + nregions = 0 + } else if (fname[1] != EOS) { + iferr { + fd = open (fname, READ_ONLY, TEXT_FILE) + nregions= rg_prregions (fd, im, pm, rp, MAX_NREGIONS) + call close (fd) + } then + nregions = 0 + } + } else + nregions = 0 + + return (nregions) +end + + +# RG_PMKREGIONS -- Create a list of psf objects by selecting objects with +# the image display cursor. + +int procedure rg_pmkregions (fd, im, pm, rp, max_nregions) + +int fd #I the output coordinates file descriptor +pointer im #I pointer to the image +pointer pm #I pointer to the psf matching structure +int rp #I pointer to current region +int max_nregions #I maximum number of regions + +int nregions, wcs, key, x1, x2, y1, y2 +pointer sp, region, cmd +real x, y, xc, yc +int clgcur(), rg_pstati() +pointer rg_pstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_FNAME, TY_CHAR) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_prealloc (pm, max_nregions) + + nregions = min (rp-1, rg_pstati (pm, NREGIONS)) + while (nregions < max_nregions) { + + # Identify the object. + call printf ("Mark object %d [any key=mark,q=quit]:\n") + call pargi (nregions + 1) + if (clgcur ("icommands", x, y, wcs, key, Memc[cmd], SZ_LINE) == EOF) + break + if (key == 'q') + break + + # Center the object. + if (rg_pstati (pm, CENTER) == YES) { + call rg_pcntr (im, x, y, max (rg_pstati(pm, PNX), + rg_pstati(pm, PNY)), xc, yc) + } else { + xc = x + yc = y + } + + # Compute the data section. + x1 = xc - rg_pstati (pm, DNX) / 2 + x2 = x1 + rg_pstati (pm, DNX) - 1 + y1 = yc - rg_pstati (pm, DNY) / 2 + y2 = y1 + rg_pstati (pm, DNY) - 1 + + # Make sure that the region is on the image. + if (x1 < 1 || x2 > IM_LEN(im,1) || y1 < 1 || y2 > + IM_LEN(im,2)) + next + + if (fd != NULL) { + call fprintf (fd, "%0.3f %0.3f\n") + call pargr (xc) + call pargr (yc) + } + + Memi[rg_pstatp(pm,RC1)+nregions] = x1 + Memi[rg_pstatp(pm,RC2)+nregions] = x2 + Memi[rg_pstatp(pm,RL1)+nregions] = y1 + Memi[rg_pstatp(pm,RL2)+nregions] = y2 + Memr[rg_pstatp(pm,RZERO)+nregions] = INDEFR + Memr[rg_pstatp(pm,RXSLOPE)+nregions] = INDEFR + Memr[rg_pstatp(pm,RYSLOPE)+nregions] = INDEFR + nregions = nregions + 1 + + } + + # Reallocate the correct amount of space. + call rg_pseti (pm, NREGIONS, nregions) + if (nregions > 0) { + call rg_prealloc (pm, nregions) + if (fd != NULL) { + call fstats (fd, F_FILENAME, Memc[region], SZ_FNAME) + call rg_psets (pm, PSFDATA, Memc[region]) + } else + call rg_psets (pm, PSFDATA, "") + } else { + call rg_prfree (pm) + call rg_psets (pm, PSFDATA, "") + } + + call sfree (sp) + return (nregions) +end + + +# RG_PRREGIONS -- Procedure to read the regions from a file. + +int procedure rg_prregions (fd, im, pm, rp, max_nregions) + +int fd #I regions file descriptor +pointer im #I pointer to the image +pointer pm #I pointer to psf matching structure +int rp #I pointer to current region +int max_nregions #I maximum number of regions + +int nregions, x1, y1, x2, y2 +pointer sp, line +real x, y, xc, yc +int rg_pstati(), getline() +pointer rg_pstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_prealloc (pm, max_nregions) + + # Decode the regions string. + nregions = min (rp - 1, rg_pstati (pm, NREGIONS)) + while (getline (fd, Memc[line]) != EOF) { + + if (nregions >= max_nregions) + break + + call sscan (Memc[line]) + call gargr (x) + call gargr (y) + if (rg_pstati (pm, CENTER) == YES) { + call rg_pcntr (im, x, y, max (rg_pstati(pm, PNX), + rg_pstati(pm, PNY)), xc, yc) + } else { + xc = x + yc = y + } + + # Compute the data section. + x1 = xc - rg_pstati (pm, DNX) / 2 + x2 = x1 + rg_pstati (pm, DNX) - 1 + if (IM_NDIM(im) == 1) { + y1 = 1 + y2 = 1 + } else { + y1 = yc - rg_pstati (pm, DNY) / 2 + y2 = y1 + rg_pstati (pm, DNY) - 1 + } + + # Make sure that the region is on the image. + if (x1 < 1 || x2 > IM_LEN(im,1) || y1 < 1 || y2 > + IM_LEN(im,2)) + next + + # Add the new region to the list. + Memi[rg_pstatp(pm,RC1)+nregions] = x1 + Memi[rg_pstatp(pm,RC2)+nregions] = x2 + Memi[rg_pstatp(pm,RL1)+nregions] = y1 + Memi[rg_pstatp(pm,RL2)+nregions] = y2 + Memr[rg_pstatp(pm,RZERO)+nregions] = INDEFR + Memr[rg_pstatp(pm,RXSLOPE)+nregions] = INDEFR + Memr[rg_pstatp(pm,RYSLOPE)+nregions] = INDEFR + nregions = nregions + 1 + } + + call rg_pseti (pm, NREGIONS, nregions) + if (nregions > 0) + call rg_prealloc (pm, nregions) + else + call rg_prfree (pm) + + call sfree (sp) + return (nregions) +end + + +# RG_PGREGIONS -- Procedure to compute the column and line limits given +# an x and y position and a default size. + +int procedure rg_pgregions (im, pm, rp, max_nregions) + +pointer im #I pointer to the image +pointer pm #I pointer to psf matching structure +int rp #I pointer to the current region +int max_nregions #I maximum number of regions + +int ncols, nlines, nregions +int x1, x2, y1, y2 +pointer sp, region +real x, y, xc, yc +int rg_pstati(), nscan() +pointer rg_pstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information. + call rg_prealloc (pm, max_nregions) + + # Get the constants. + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + # Decode the center. + call rg_pstats (pm, PSFDATA, Memc[region], SZ_LINE) + nregions = min (rp - 1, rg_pstati (pm, NREGIONS)) + call sscan (Memc[region]) + call gargr (x) + call gargr (y) + + # Compute the data region. + if (nscan() >= 2) { + + # Compute a more accurate center. + if (rg_pstati (pm, CENTER) == YES) { + call rg_pcntr (im, x, y, max (rg_pstati(pm, PNX), + rg_pstati(pm, PNY)), xc, yc) + } else { + xc = x + yc = y + } + + # Compute the data section. + x1 = xc - rg_pstati (pm, DNX) / 2 + x2 = x1 + rg_pstati (pm, DNX) - 1 + if (IM_NDIM(im) == 1) { + y1 = 1 + y2 = 1 + } else { + y1 = yc - rg_pstati (pm, DNY) / 2 + y2 = y1 + rg_pstati (pm, DNY) - 1 + } + + # Make sure that the region is on the image. + if (x1 >= 1 && x2 <= IM_LEN(im,1) && y1 >= 1 && + y2 <= IM_LEN(im,2)) { + Memi[rg_pstatp(pm,RC1)+nregions] = x1 + Memi[rg_pstatp(pm,RC2)+nregions] = x2 + Memi[rg_pstatp(pm,RL1)+nregions] = y1 + Memi[rg_pstatp(pm,RL2)+nregions] = y2 + Memr[rg_pstatp(pm,RZERO)+nregions] = INDEFR + Memr[rg_pstatp(pm,RXSLOPE)+nregions] = INDEFR + Memr[rg_pstatp(pm,RYSLOPE)+nregions] = INDEFR + nregions = nregions + 1 + } + } + + + # Reallocate the correct amount of space. + call rg_pseti (pm, NREGIONS, nregions) + if (nregions > 0) + call rg_prealloc (pm, nregions) + else + call rg_prfree (pm) + + call sfree (sp) + + return (nregions) +end + + +# RG_PCNTR -- Compute star center using MPC algorithm. + +procedure rg_pcntr (im, xstart, ystart, boxsize, xcntr, ycntr) + +pointer im #I pointer to the input image +real xstart, ystart #I initial position +int boxsize #I width of the centering box +real xcntr, ycntr #O computed center + +int x1, x2, y1, y2, half_box +int ncols, nrows, nx, ny, try +real xinit, yinit +pointer bufptr, sp, x_vect, y_vect +int imgs2r() + +begin + # Inialize. + half_box = (boxsize - 1) / 2 + xinit = xstart + ncols = IM_LEN (im, 1) + if (IM_NDIM(im) == 1) { + yinit = 1 + nrows = 1 + } else { + yinit = ystart + nrows = IM_LEN (im, 2) + } + try = 0 + + # Iterate until pixel shifts are less than one. + repeat { + + # Define region to extract. + x1 = max (xinit - half_box, 1.0) +0.5 + x2 = min (xinit + half_box, real(ncols)) +0.5 + y1 = max (yinit - half_box, 1.0) +0.5 + y2 = min (yinit + half_box, real(nrows)) +0.5 + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + + # Extract region around center + bufptr = imgs2r (im, x1, x2, y1, y2) + + # Compute the new center. + call smark (sp) + if (IM_NDIM(im) == 1) { + call salloc (x_vect, nx, TY_REAL) + call aclrr (Memr[x_vect], nx) + call rg_prowsum (Memr[bufptr], Memr[x_vect], nx, ny) + call rg_pcenter (Memr[x_vect], nx, xcntr) + ycntr = 1 + } else { + call salloc (x_vect, nx, TY_REAL) + call salloc (y_vect, ny, TY_REAL) + call aclrr (Memr[x_vect], nx) + call aclrr (Memr[y_vect], ny) + call rg_prowsum (Memr[bufptr], Memr[x_vect], nx, ny) + call rg_pcolsum (Memr[bufptr], Memr[y_vect], nx, ny) + call rg_pcenter (Memr[x_vect], nx, xcntr) + call rg_pcenter (Memr[y_vect], ny, ycntr) + } + call sfree (sp) + + # Check for INDEF centers. + if (IS_INDEFR(xcntr) || IS_INDEFR(ycntr)) { + xcntr = xinit + ycntr = yinit + break + } + + # Add in offsets + xcntr = xcntr + x1 + ycntr = ycntr + y1 + + try = try + 1 + if (try == 1) { + if ((abs(xcntr-xinit) > 1.0) || (abs(ycntr-yinit) > 1.0)) { + xinit = xcntr + yinit = ycntr + } + } else + break + } +end + + +# RG_PROWSUM -- Sum all rows in a raster. + +procedure rg_prowsum (v, row, nx, ny) + +real v[nx,ny] #I the input subraster +real row[ARB] #O the output row sum +int nx, ny #I the dimensions of the subraster + +int i, j + +begin + do i = 1, ny + do j = 1, nx + row[j] = row[j] + v[j,i] +end + + +# RG_PCOLSUM -- Sum all columns in a raster. + +procedure rg_pcolsum (v, col, nx, ny) + +real v[nx,ny] #I the input subraster +real col[ARB] #O the output column sum +int nx, ny #I the dimensions of the subraster + +int i, j + +begin + do i = 1, ny + do j = 1, nx + col[j] = col[j] + v[i,j] +end + + +# RG_PCENTER -- Compute center of gravity of array. + +procedure rg_pcenter (v, nv, vc) + +real v[ARB] #I the input vector +int nv #I the length of the vector +real vc #O the output center + +int i +real sum1, sum2, sigma, cont + +begin + # Compute first moment + sum1 = 0.0 + sum2 = 0.0 + + call aavgr (v, nv, cont, sigma) + + do i = 1, nv + if (v[i] > cont) { + sum1 = sum1 + (i-1) * (v[i] - cont) + sum2 = sum2 + (v[i] - cont) + } + + # Determine center + if (sum2 == 0.0) + vc = INDEFR + else + vc = sum1 / sum2 +end diff --git a/pkg/images/immatch/src/psfmatch/rgpsfm.x b/pkg/images/immatch/src/psfmatch/rgpsfm.x new file mode 100644 index 00000000..493d48c9 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpsfm.x @@ -0,0 +1,815 @@ +include <imhdr.h> +include <math/gsurfit.h> +include "psfmatch.h" + +# RG_PSFM -- Procedure to match the psf functions of two images. + +int procedure rg_psfm (pm, imr, im1, impsf, imk, newref) + +pointer pm #I pointer to psf matching structure +pointer imr #I pointer to reference image +pointer im1 #I pointer to input image +pointer impsf #I pointer to the psf image +pointer imk #I pointer to kernel image +int newref #I new reference image ? + +int stat +int rg_pstati(), rg_pfget(), rg_psfget(), rg_kget() +pointer rg_pstatp() + +begin + # Compute the convolution kernel. + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL) { + + # Compute the kernel using raw image data or the psf image. + if (rg_pstati (pm,CONVOLUTION) == PM_CONIMAGE) { + + # Set the kernel size to the user specified kernel size. + call rg_pseti (pm, KNX, rg_pstati (pm, PNX)) + if (IM_NDIM(imr) == 1) + call rg_pseti (pm, KNY, 1) + else + call rg_pseti (pm, KNY, rg_pstati (pm, PNY)) + + # Compute the FFTS of the input and reference image. + stat = rg_pfget (pm, imr, im1, newref) + + } else { + + # Set the kernel size to the psf image size + call rg_pseti (pm, KNX, IM_LEN (impsf,1)) + if (IM_NDIM(imr) == 1) + call rg_pseti (pm, KNY, 1) + else + call rg_pseti (pm, KNY, IM_LEN(impsf,2)) + + # Compute the FFTS of the input and reference psf images. + stat = rg_psfget (pm, imr, impsf, newref) + } + + # Delete working arrays if an error occurs. + if (stat == ERR) { + if (rg_pstatp (pm, REFFFT) != NULL) + call mfree (rg_pstatp (pm, REFFFT), TY_REAL) + call rg_psetp (pm, REFFFT, NULL) + if (rg_pstatp (pm, IMFFT) != NULL) + call mfree (rg_pstatp (pm, IMFFT), TY_REAL) + call rg_psetp (pm, IMFFT, NULL) + if (rg_pstatp (pm, FFT) != NULL) + call mfree (rg_pstatp (pm, FFT), TY_REAL) + call rg_psetp (pm, FFT, NULL) + if (rg_pstatp (pm, CONV) != NULL) + call mfree (rg_pstatp (pm, CONV), TY_REAL) + call rg_psetp (pm, CONV, NULL) + if (rg_pstatp (pm, ASFFT) != NULL) + call mfree (rg_pstatp (pm, ASFFT), TY_REAL) + call rg_psetp (pm, ASFFT, NULL) + } + + # Do the filtering in frequency space. + if (rg_pstatp (pm, FFT) != NULL) + call rg_pfilter (pm) + + } else { + + # Set the kernel size. + call rg_pseti (pm, KNX, IM_LEN(imk,1)) + if (IM_NDIM(im1) == 1) + call rg_pseti (pm, KNY, 1) + else + call rg_pseti (pm, KNY, IM_LEN(imk,2)) + + # Read in the convolution kernel. + stat = rg_kget (pm, imk) + + # Delete working arrays if an error occurs. + if (stat == ERR) { + if (rg_pstatp (pm, REFFFT) != NULL) + call mfree (rg_pstatp (pm, REFFFT), TY_REAL) + call rg_psetp (pm, REFFFT, NULL) + if (rg_pstatp (pm, IMFFT) != NULL) + call mfree (rg_pstatp (pm, IMFFT), TY_REAL) + call rg_psetp (pm, IMFFT, NULL) + if (rg_pstatp (pm, FFT) != NULL) + call mfree (rg_pstatp (pm, FFT), TY_REAL) + call rg_psetp (pm, FFT, NULL) + if (rg_pstatp (pm, CONV) != NULL) + call mfree (rg_pstatp (pm, CONV), TY_REAL) + call rg_psetp (pm, CONV, NULL) + if (rg_pstatp (pm, ASFFT) != NULL) + call mfree (rg_pstatp (pm, ASFFT), TY_REAL) + call rg_psetp (pm, ASFFT, NULL) + } + } + + return (stat) +end + + +# RG_PFGET -- Compute the psfmatching function using Fourier techniques. + +int procedure rg_pfget (pm, imr, im1, newref) + +pointer pm #I pointer to psfmatch structure +pointer imr #I pointer to reference image +pointer im1 #I pointer to input image +int newref #I new reference image ? + +int i, nregions, nrimcols, nrimlines, nrcols, nrlines, nrpcols, nrplines +int nborder, stat, rc1, rc2, rl1, rl2, nxfft, nyfft +pointer sp, str, coeff, dim, rbuf, ibuf, rsum, isum, border +pointer prc1, prc2, prl1, prl2, przero, prxslope, pryslope, reffft, imfft, fft +real rwtsum, iwtsum, rscale, iscale, rnscale, inscale +bool fp_equalr() +int rg_pstati(), rg_border(), rg_szfft() +pointer rg_pstatp(), rg_pgdata() +real rg_pstatr(), rg_pnsum(), rg_pg1norm(), rg_pg2norm() +real rg_pg10f(), rg_pg20f() + +define nextimage_ 11 + +begin + # Assemble the PSF data by looping over the regions list. + nregions = rg_pstati (pm, NREGIONS) + if (nregions <= 0) + return (ERR) + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (coeff, max (GS_SAVECOEFF+6, 9), TY_REAL) + call salloc (dim, 2, TY_INT) + + # Get the reference region pointers. + prc1 = rg_pstatp (pm, RC1) + prc2 = rg_pstatp (pm, RC2) + prl1 = rg_pstatp (pm, RL1) + prl2 = rg_pstatp (pm, RL2) + przero = rg_pstatp (pm, RZERO) + prxslope = rg_pstatp (pm, RXSLOPE) + pryslope = rg_pstatp (pm, RYSLOPE) + + # Check to see if the reference / input images are 1D. + nrimcols = IM_LEN(imr,1) + nrpcols = rg_pstati (pm, PNX) + if (IM_NDIM(imr) == 1) { + nrimlines = 1 + nrplines = 1 + } else { + nrimlines = IM_LEN(imr,2) + nrplines = rg_pstati (pm, PNY) + } + + # Initialize + rwtsum = 0.0 + iwtsum = 0.0 + rnscale = INDEFR + inscale = INDEFR + rbuf = NULL + ibuf = NULL + stat = OK + if (newref == YES) + call calloc (rsum, rg_pstati (pm, DNX) * rg_pstati (pm, DNY), + TY_REAL) + call calloc (isum, rg_pstati (pm, DNX) * rg_pstati (pm, DNY), + TY_REAL) + + do i = 1, nregions { + + # Get the reference subraster regions. + rc1 = max (1, min (nrimcols, Memi[prc1+i-1])) + rc2 = min (nrimcols, max (1, Memi[prc2+i-1])) + rl1 = max (1, min (nrimlines, Memi[prl1+i-1])) + rl2 = min (nrimlines, max (1, Memi[prl2+i-1])) + nrcols = rc2 - rc1 + 1 + nrlines = rl2 - rl1 + 1 + + # Go to next object if reference region is off the image. + if (nrcols < rg_pstati (pm, DNX) || (IM_NDIM(imr) == 2 && + nrlines < rg_pstati(pm, DNY))) { + call rg_pstats (pm, REFIMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Reference object %d: %s[%d:%d,%d:%d] is off image.\n") + call pargi (i) + call pargstr (Memc[str]) + call pargi (rc1) + call pargi (rc2) + call pargi (rl1) + call pargi (rl2) + next + } + + if (newref == YES) { + + # Get the reference data. + rbuf = rg_pgdata (imr, rc1, rc2, rl1, rl2) + + # Do the reference image background subtraction. + border = NULL + nborder = rg_border (Memr[rbuf], nrcols, nrlines, nrpcols, + nrplines, border) + call rg_pscale (pm, Memr[border], nborder, nrcols, + nrlines, nrpcols, nrplines, rg_pstatr (pm, BVALUER), + Memr[coeff]) + if (border != NULL) + call mfree (border, TY_REAL) + + # Save the coefficients. + Memr[przero+i-1] = Memr[coeff] + Memr[prxslope+i-1] = Memr[coeff+1] + Memr[pryslope+i-1] = Memr[coeff+2] + + # Subtract the reference background. + call rg_subtract (Memr[rbuf], nrcols, nrlines, + Memr[przero+i-1], Memr[prxslope+i-1], Memr[pryslope+i-1]) + + # Apodize the reference image data. + if (rg_pstatr (pm, APODIZE) > 0.0) + call rg_apodize (Memr[rbuf], nrcols, nrlines, + rg_pstatr (pm, APODIZE), YES) + + # Compute the scale factors and accumulate the weighted sums. + rscale = rg_pnsum (Memr[rbuf], nrcols, nrlines, nrpcols, + nrplines) + if (! IS_INDEFR(rscale)) { + if (IS_INDEFR(rnscale)) + rnscale = 1.0 / rscale + } + if (IS_INDEFR(rscale)) + rscale = 1.0 + else + rscale = rscale / rnscale + + call amulkr (Memr[rbuf], rscale, Memr[rbuf], nrcols * + nrlines) + rwtsum = rwtsum + rscale + call aaddr (Memr[rsum], Memr[rbuf], Memr[rsum], nrcols * + nrlines) + + call mfree (rbuf, TY_REAL) + } + + # Get the input image data + ibuf = rg_pgdata (im1, rc1, rc2, rl1, rl2) + + # Compute the zero point, and the x and y slopes of input image. + border = NULL + nborder = rg_border (Memr[ibuf], nrcols, nrlines, nrpcols, + nrplines, border) + call rg_pscale (pm, Memr[border], nborder, nrcols, nrlines, + nrpcols, nrplines, rg_pstatr (pm, BVALUE), Memr[coeff]) + if (border != NULL) + call mfree (border, TY_REAL) + + # Subtract the background from the input image. + call rg_subtract (Memr[ibuf], nrcols, nrlines, Memr[coeff], + Memr[coeff+1], Memr[coeff+2]) + + # Apodize the data. + if (rg_pstatr (pm, APODIZE) > 0.0) + call rg_apodize (Memr[ibuf], nrcols, nrlines, rg_pstatr (pm, + APODIZE), YES) + + # Compute the scale factors and accumulate the weighted sums for + # input image. + iscale = rg_pnsum (Memr[ibuf], nrcols, nrlines, nrpcols, nrplines) + if (! IS_INDEFR(iscale)) { + if (IS_INDEFR(inscale)) + inscale = 1.0 / iscale + } + if (IS_INDEFR(iscale)) + iscale = 1.0 + else + iscale = iscale / inscale + + call amulkr (Memr[ibuf], iscale, Memr[ibuf], nrcols * nrlines) + iwtsum = iwtsum + iscale + call aaddr (Memr[isum], Memr[ibuf], Memr[isum], nrcols * nrlines) + + # Free the individual image buffers. + call mfree (ibuf, TY_REAL) + } + + # Check to see if any data was read. + if (iwtsum <= 0.0) { + stat = ERR + goto nextimage_ + } + + # Normalize the summed buffers by the weights. + if (newref == YES) { + if (! fp_equalr (rwtsum, 0.0)) + call adivkr (Memr[rsum], rwtsum, Memr[rsum], nrcols * nrlines) + } + if (! fp_equalr (iwtsum, 0.0)) + call adivkr (Memr[isum], iwtsum, Memr[isum], nrcols * nrlines) + + # Figure out how big the Fourier transform has to be, given + # the size of the reference subraster, the window size and + # the fact that the FFT must be a power of 2. + + nxfft = rg_szfft (nrcols, 0) + if (nrlines == 1) + nyfft = 1 + else + nyfft = rg_szfft (nrlines, 0) + call rg_pseti (pm, NXFFT, nxfft) + call rg_pseti (pm, NYFFT, nyfft) + + imfft = rg_pstatp (pm, IMFFT) + if (imfft != NULL) + call mfree (imfft, TY_REAL) + call calloc (imfft, 2 * nxfft * nyfft, TY_REAL) + call rg_psetp (pm, IMFFT, imfft) + + # Allocate space for the fft. + fft = rg_pstatp (pm, FFT) + if (fft != NULL) + call mfree (fft, TY_REAL) + call calloc (fft, 2 * nxfft * nyfft, TY_REAL) + call rg_psetp (pm, FFT, fft) + + # Allocate space for the reference and input image ffts + if (newref == YES) { + + reffft = rg_pstatp (pm, REFFFT) + if (reffft != NULL) + call mfree (reffft, TY_REAL) + call calloc (reffft, 2 * nxfft * nyfft, TY_REAL) + call rg_psetp (pm, REFFFT, reffft) + + # Load the reference image FFT. + call rg_rload (Memr[rsum], nrcols, nrlines, Memr[fft], nxfft, + nyfft) + call mfree (rsum, TY_REAL) + rsum = NULL + + # Load the input image FFT. + call rg_iload (Memr[isum], nrcols, nrlines, Memr[fft], nxfft, + nyfft) + call mfree (isum, TY_REAL) + isum = NULL + + # Shift the data for easy of filtering. + call rg_fshift (Memr[fft], Memr[fft], 2 * nxfft, nyfft) + + # Compute the Fourier Transform of the reference and input image + # data. + Memi[dim] = nxfft + Memi[dim+1] = nyfft + if (Memi[dim+1] == 1) + call rg_fourn (Memr[fft], Memi[dim], 1, 1) + else + call rg_fourn (Memr[fft], Memi[dim], 2, 1) + + # Compute the flux ratio between the two data sets. + if (IS_INDEFR(rg_pstatr(pm, UFLUXRATIO))) { + if (rg_pstati (pm, BACKGRD) == PM_BNONE) + call rg_psetr (pm, FLUXRATIO, rg_pg2norm (Memr[fft], + 2 * nxfft, nyfft)) + else + call rg_psetr (pm, FLUXRATIO, rg_pg20f (Memr[fft], + 2 * nxfft, nyfft)) + } else + call rg_psetr (pm, FLUXRATIO, rg_pstatr (pm, UFLUXRATIO)) + + # Separate the two transforms and compute the division. + call rg_pdivfft (Memr[fft], Memr[reffft], Memr[imfft], Memr[fft], + 2 * nxfft, nyfft) + + } else { + + + # Get the reference image FFT. + reffft = rg_pstatp (pm, REFFFT) + + # Load the input image FFT. + call rg_rload (Memr[isum], nrcols, nrlines, Memr[imfft], nxfft, + nyfft) + call mfree (isum, TY_REAL) + isum = NULL + + # Shift the data for easy of filtering. + call rg_fshift (Memr[imfft], Memr[imfft], 2 * nxfft, nyfft) + + # Compute the Fourier Transform of the input image data. + Memi[dim] = nxfft + Memi[dim+1] = nyfft + if (Memi[dim+1] == 1) + call rg_fourn (Memr[imfft], Memi[dim], 1, 1) + else + call rg_fourn (Memr[imfft], Memi[dim], 2, 1) + + # Compute the flux ratio between the two data sets. + if (IS_INDEFR(rg_pstatr(pm, UFLUXRATIO))) { + if (rg_pstati (pm, BACKGRD) == PM_BNONE) + call rg_psetr (pm, FLUXRATIO, rg_pg1norm (Memr[reffft], + 2 * nxfft, nyfft) / rg_pg1norm (Memr[imfft], 2 * nxfft, + nyfft)) + else + call rg_psetr (pm, FLUXRATIO, rg_pg10f (Memr[reffft], + 2 * nxfft, nyfft) / rg_pg10f (Memr[imfft], 2 * nxfft, + nyfft)) + } else + call rg_psetr (pm, FLUXRATIO, rg_pstatr (pm, UFLUXRATIO)) + + # Divide the two functions. + call adivx (Memr[reffft], Memr[imfft], Memr[fft], nxfft * nyfft) + } + + # Normalize the FFT. + call rg_pnorm (Memr[fft], nxfft, nyfft, rg_pstatr (pm, FLUXRATIO)) + + +nextimage_ + + if (rsum != NULL) + call mfree (rsum, TY_REAL) + if (isum != NULL) + call mfree (isum, TY_REAL) + call sfree (sp) + if (stat == ERR) + return (ERR) + else + return (OK) +end + + +# RG_PSFGET -- Compute the psfmatching function using Fourier techniques. + +int procedure rg_psfget (pm, imr, impsf, newref) + +pointer pm #I pointer to the psfmatch structure +pointer imr #I pointer to the reference psf +pointer impsf #I pointer to the input image psf +int newref #I new reference image + +int nrcols, nrlines, nxfft, nyfft +pointer sp, dim, rbuf, ibuf, imfft, fft, reffft +int rg_szfft() +pointer rg_pgdata(), rg_pstatp() +real rg_pstatr(), rg_pg2norm(), rg_pg1norm() + +begin + call smark (sp) + call salloc (dim, 2, TY_INT) + + nrcols = IM_LEN(imr,1) + if (IM_NDIM(imr) == 1) + nrlines = 1 + else + nrlines = IM_LEN(imr,2) + + # Get the psf data. + rbuf = NULL + ibuf = NULL + if (newref == YES) { + call calloc (rbuf, nrcols * nrlines, TY_REAL) + rbuf = rg_pgdata (imr, 1, nrcols, 1, nrlines) + } + call calloc (ibuf, nrcols * nrlines, TY_REAL) + ibuf = rg_pgdata (impsf, 1, nrcols, 1, nrlines) + + # Compute the size for the FFT buffers. + nxfft = rg_szfft (nrcols, 0) + if (nrlines == 1) + nyfft = 1 + else + nyfft = rg_szfft (nrlines, 0) + call rg_pseti (pm, NXFFT, nxfft) + call rg_pseti (pm, NYFFT, nyfft) + + imfft = rg_pstatp (pm, IMFFT) + if (imfft != NULL) + call mfree (imfft, TY_REAL) + call calloc (imfft, 2 * nxfft * nyfft, TY_REAL) + call rg_psetp (pm, IMFFT, imfft) + + # Allocate space for the fft. + fft = rg_pstatp (pm, FFT) + if (fft != NULL) + call mfree (fft, TY_REAL) + call calloc (fft, 2 * nxfft * nyfft, TY_REAL) + call rg_psetp (pm, FFT, fft) + + if (newref == YES) { + + reffft = rg_pstatp (pm, REFFFT) + if (reffft != NULL) + call mfree (reffft, TY_REAL) + call calloc (reffft, 2 * nxfft * nyfft, TY_REAL) + call rg_psetp (pm, REFFFT, reffft) + + # Load the reference image FFT. + call rg_rload (Memr[rbuf], nrcols, nrlines, Memr[fft], nxfft, + nyfft) + + # Load the input image FFT. + call rg_iload (Memr[ibuf], nrcols, nrlines, Memr[fft], nxfft, + nyfft) + + # Shift the data for easy of filtering. + call rg_fshift (Memr[fft], Memr[fft], 2 * nxfft, nyfft) + + # Compute the Fourier Transform of the reference and input image + # data. + Memi[dim] = nxfft + Memi[dim+1] = nyfft + if (Memi[dim+1] == 1) + call rg_fourn (Memr[fft], Memi[dim], 1, 1) + else + call rg_fourn (Memr[fft], Memi[dim], 2, 1) + + # Compute the flux ratio between the two data sets. + if (IS_INDEFR(rg_pstatr(pm, UFLUXRATIO))) + call rg_psetr (pm, FLUXRATIO, rg_pg2norm (Memr[fft], + 2 * nxfft, nyfft)) + else + call rg_psetr (pm, FLUXRATIO, rg_pstatr(pm, UFLUXRATIO)) + + # Separate the two transforms and compute the division. + call rg_pdivfft (Memr[fft], Memr[reffft], Memr[imfft], Memr[fft], + 2 * nxfft, nyfft) + + } else { + + # Get the reference image FFT. + reffft = rg_pstatp (pm, REFFFT) + + # Load the input image FFT. + call rg_rload (Memr[ibuf], nrcols, nrlines, Memr[imfft], nxfft, + nyfft) + + # Shift the data for easy of filtering. + call rg_fshift (Memr[imfft], Memr[imfft], 2 * nxfft, nyfft) + + # Compute the Fourier Transform of the input image data. + Memi[dim] = nxfft + Memi[dim+1] = nyfft + if (Memi[dim+1] == 1) + call rg_fourn (Memr[imfft], Memi[dim], 1, 1) + else + call rg_fourn (Memr[imfft], Memi[dim], 2, 1) + + # Compute the flux ratio between the two data sets. + if (IS_INDEFR(rg_pstatr(pm, UFLUXRATIO))) + call rg_psetr (pm, FLUXRATIO, rg_pg1norm (Memr[reffft], + 2 * nxfft, nyfft) / rg_pg1norm (Memr[imfft], 2 * nxfft, + nyfft)) + else + call rg_psetr (pm, FLUXRATIO, rg_pstatr(pm, UFLUXRATIO)) + + # Divide the two functions. + call adivx (Memr[reffft], Memr[imfft], Memr[fft], nxfft * nyfft) + + } + + # Normalize the FFT. + call rg_pnorm (Memr[fft], nxfft, nyfft, rg_pstatr (pm, FLUXRATIO)) + + # Free the data buffers. + if (rbuf != NULL) + call mfree (rbuf, TY_REAL) + if (ibuf != NULL) + call mfree (ibuf, TY_REAL) + + call sfree (sp) + + return (OK) +end + + +# RG_KGET -- Read in the convolution kernel. + +int procedure rg_kget (pm, imk) + +pointer pm #I pointer to the psfmatch structure +pointer imk #I pointer to the kernel image + +int nrlines +pointer conv +pointer rg_pstatp(), rg_pgdata() + +begin + if (IM_NDIM(imk) == 1) + nrlines = 1 + else + nrlines = IM_LEN(imk,2) + conv = rg_pstatp (pm, CONV) + if (conv != NULL) + call mfree (conv, TY_REAL) + conv = rg_pgdata (imk, 1, int(IM_LEN(imk,1)), 1, nrlines) + call rg_psetp (pm, CONV, conv) + + return (OK) +end + + +# RG_PFILTER -- Procedure to filter the FFT in frequency space. + +procedure rg_pfilter (pm) + +pointer pm #I pointer to the psf matching structure + +pointer sp, dim, psfft, conv +real nfactor +int rg_pstati() +pointer rg_pstatp() +real rg_pstatr(), asumr() + +begin + call smark (sp) + call salloc (dim, 2, TY_INT) + + # Allocate space for the fourier spectrum. + if (rg_pstatp (pm, ASFFT) != NULL) + call mfree (rg_pstatp (pm, ASFFT), TY_REAL) + call calloc (psfft, rg_pstati (pm, NXFFT) * rg_pstati (pm, NYFFT), + TY_REAL) + call rg_psetp (pm, ASFFT, psfft) + + # Allocate space for the convolution kernel. + if (rg_pstatp (pm, CONV) != NULL) + call mfree (rg_pstatp (pm, CONV), TY_REAL) + call malloc (conv, 2 * rg_pstati (pm, NXFFT) * rg_pstati (pm, NYFFT), + TY_REAL) + call rg_psetp (pm, CONV, conv) + call amovr (Memr[rg_pstatp(pm,FFT)], Memr[rg_pstatp(pm,CONV)], + 2 * rg_pstati (pm, NXFFT) * rg_pstati (pm, NYFFT)) + +# # Compute the zextend parameter. +# call rg_psetr (pm, THRESHOLD, rg_pstatr (pm, PRATIO) * +# rg_gnorm (Memr[rg_pstatp(pm,IMFFT)], rg_pstati(pm,NXFFT), +# rg_pstati(pm,NYFFT))) + + # Filter the frequency spectrum. + switch (rg_pstati(pm,FILTER)) { + case PM_FCOSBELL: + call rg_pcosbell (Memr[rg_pstatp(pm,CONV)], rg_pstati (pm, NXFFT), + rg_pstati (pm, NYFFT), rg_pstatr (pm, SXINNER), rg_pstatr (pm, + SXOUTER), rg_pstatr (pm, SYINNER), rg_pstatr (pm, SYOUTER), + rg_pstati (pm, RADSYM)) + case PM_FREPLACE: + call rg_preplace (Memr[rg_pstatp(pm,CONV)], Memr[rg_pstatp(pm, + IMFFT)], rg_pstati (pm, NXFFT), rg_pstati (pm, NYFFT), + rg_pstatr (pm,THRESHOLD), rg_pstatr (pm,FLUXRATIO)) + case PM_FMODEL: + call rg_pgmodel (Memr[rg_pstatp(pm,CONV)], Memr[rg_pstatp(pm, + IMFFT)], rg_pstati (pm, NXFFT), rg_pstati (pm, NYFFT), + rg_pstatr (pm, THRESHOLD), rg_pstatr (pm, FLUXRATIO)) + default: + ; + } + + # Filter out any values greater than the normalization. + call rg_pnormfilt (Memr[rg_pstatp(pm,CONV)], rg_pstati(pm,NXFFT), + rg_pstati(pm,NYFFT), rg_pstatr (pm, FLUXRATIO)) + + # Compute the fourier spectrum. + call rg_pfourier (Memr[rg_pstatp(pm,CONV)], Memr[rg_pstatp(pm,ASFFT)], + rg_pstati(pm,NXFFT), rg_pstati(pm,NYFFT)) + + Memi[dim] = rg_pstati (pm, NXFFT) + Memi[dim+1] = rg_pstati (pm, NYFFT) + call rg_fshift (Memr[rg_pstatp(pm,CONV)], Memr[rg_pstatp(pm,CONV)], + 2 * rg_pstati(pm, NXFFT), rg_pstati(pm, NYFFT)) + call rg_fourn (Memr[rg_pstatp(pm,CONV)], Memi[dim], 2, -1) + call rg_fshift (Memr[rg_pstatp(pm,CONV)], Memr[rg_pstatp(pm,CONV)], + 2 * rg_pstati(pm, NXFFT), rg_pstati(pm, NYFFT)) + call adivkr (Memr[rg_pstatp(pm,CONV)], real (rg_pstati(pm,NXFFT) * + rg_pstati(pm,NYFFT)), Memr[rg_pstatp(pm,CONV)], 2 * rg_pstati(pm, + NXFFT) * rg_pstati(pm,NYFFT)) + + # Unpack the convolution kernel. + call rg_movexr (Memr[rg_pstatp(pm,CONV)], rg_pstati(pm,NXFFT), + rg_pstati(pm,NYFFT), Memr[rg_pstatp(pm,CONV)], rg_pstati(pm,KNX), + rg_pstati(pm,KNY)) + + # Normalize the kernel. + if (! IS_INDEFR(rg_pstatr (pm, NORMFACTOR))) { + nfactor = rg_pstatr (pm, NORMFACTOR) / asumr (Memr[rg_pstatp(pm, + CONV)], rg_pstati (pm, KNX) * rg_pstati(pm,KNY)) + call amulkr (Memr[rg_pstatp (pm,CONV)], nfactor, + Memr[rg_pstatp(pm, CONV)], rg_pstati (pm, KNX) * + rg_pstati (pm, KNY)) + } + + # Reallocate the convolution kernel array + #conv = rg_pstatp (pm, CONV) + #if (conv != NULL) { + #call realloc (conv, rg_pstati(pm, KNX) * rg_pstati(pm, KNY), + #TY_REAL) + #call rg_psetp (pm, CONV, conv) + #} + + call sfree (sp) +end + + +# RG_PGDATA -- Fill a buffer from a specified region of the image. + +pointer procedure rg_pgdata (im, c1, c2, l1, l2) + +pointer im #I pointer to the iraf image +int c1, c2 #I column limits in the input image +int l1, l2 #I line limits in the input image + +int i, ncols, nlines, npts +pointer ptr, index, buf +pointer imgs1r(), imgs2r() + +begin + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + npts = ncols * nlines + call malloc (ptr, npts, TY_REAL) + + index = ptr + do i = l1, l2 { + if (IM_NDIM(im) == 1) + buf = imgs1r (im, c1, c2) + else + buf = imgs2r (im, c1, c2, i, i) + call amovr (Memr[buf], Memr[index], ncols) + index = index + ncols + } + + return (ptr) +end + + +# RG_PNSUM -- Compute the total intensity in the subtracted subraster. + +real procedure rg_pnsum (data, ncols, nlines, nxdata, nydata) + +real data[ncols,nlines] #I the input data subraster +int ncols, nlines #I the size of the input subraster +int nxdata, nydata #I the size of the data region + +int j, wxborder, wyborder, npts +real sum +bool fp_equalr() +real asumr() + +begin + wxborder = (ncols - nxdata) / 2 + wyborder = (nlines - nydata) / 2 + + sum = 0.0 + npts = 0 + do j = 1 + wyborder, nlines - wyborder { + sum = sum + asumr (data[1+wxborder,j], nxdata) + npts = npts + nxdata + } + if (npts <= 0 || fp_equalr (sum, 0.0)) + return (INDEFR) + else + return (sum) +end + + +# RG_PWRITE -- Save the convolution kernel and the fourier spectrum of the +# convolution kernel in an image. + +procedure rg_pwrite (pm, imk, imf) + +pointer pm #I pointer to psf matching structure +pointer imk #I pointer to kernel image +pointer imf #I pointer to fourier spectrum image + +int nx, ny +pointer buf +int rg_pstati() +pointer rg_pstatp(), imps2r() + +begin + # Write out the kernel image. + if (imk != NULL && rg_pstatp(pm, CONV) != NULL) { + nx = rg_pstati (pm, KNX) + ny = rg_pstati (pm, KNY) + IM_NDIM(imk) = 2 + IM_LEN(imk,1) = nx + IM_LEN(imk,2) = ny + IM_PIXTYPE(imk) = TY_REAL + buf = imps2r (imk, 1, nx, 1, ny) + if (rg_pstatp (pm, CONV) != NULL) + call amovr (Memr[rg_pstatp(pm,CONV)], Memr[buf], nx * ny) + else + call amovkr (0.0, Memr[buf], nx * ny) + } + + # Write out the fourier spectrum. + if (imf != NULL && rg_pstatp(pm,ASFFT) != NULL) { + nx = rg_pstati (pm, NXFFT) + ny = rg_pstati (pm, NYFFT) + IM_NDIM(imf) = 2 + IM_LEN(imf,1) = nx + IM_LEN(imf,2) = ny + IM_PIXTYPE(imf) = TY_REAL + buf = imps2r (imf, 1, nx, 1, ny) + if (rg_pstatp (pm, CONV) != NULL) + call amovr (Memr[rg_pstatp(pm,ASFFT)], Memr[buf], nx * ny) + else + call amovkr (0.0, Memr[buf], nx * ny) + } +end + diff --git a/pkg/images/immatch/src/psfmatch/rgpshow.x b/pkg/images/immatch/src/psfmatch/rgpshow.x new file mode 100644 index 00000000..c94349a6 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpshow.x @@ -0,0 +1,116 @@ +include "psfmatch.h" + +# RG_PSHOW -- Print the PSFMATCH task parameters. + +procedure rg_pshow (pm) + +pointer pm #I pointer to psfmatch structure + +pointer sp, str +bool itob() +int rg_pstati() +real rg_pstatr() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + call rg_pstats (pm, CSTRING, Memc[str], SZ_FNAME) + call printf ("\nConvolution: %s\n") + call pargstr (Memc[str]) + if (rg_pstati (pm, CONVOLUTION) == PM_CONIMAGE) { + call rg_pstats (pm, IMAGE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + call rg_pstats (pm, REFIMAGE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str]) + call rg_pstats (pm, PSFDATA, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_PSFDATA) + call pargstr (Memc[str]) + } else if (rg_pstati (pm, CONVOLUTION) == PM_CONPSF) { + call rg_pstats (pm, IMAGE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + call rg_pstats (pm, PSFIMAGE, Memc[str], SZ_FNAME) + call printf (" input psf: %s\n") + call pargstr (Memc[str]) + call rg_pstats (pm, REFIMAGE, Memc[str], SZ_FNAME) + call printf (" reference psf: %s\n") + call pargstr (Memc[str]) + } else { + call rg_pstats (pm, IMAGE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + } + + call rg_pstats (pm, KERNEL, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_KERNEL) + call pargstr (Memc[str]) + call rg_pstats (pm, OUTIMAGE, Memc[str], SZ_FNAME) + if (Memc[str] != EOS) { + call printf (" %s: %s\n") + call pargstr (KY_OUTIMAGE) + call pargstr (Memc[str]) + } + + call printf ("Centering and background fitting\n") + call printf (" %s: %b\n") + call pargstr (KY_CENTER) + call pargb (itob(rg_pstati(pm,CENTER))) + call rg_pstats (pm, BSTRING, Memc[str], SZ_LINE) + call printf (" %s: %s\n") + call pargstr (KY_BACKGRD) + call pargstr (Memc[str]) + call printf (" %s = %g %s = %g\n") + call pargstr (KY_LOREJECT) + call pargr (rg_pstatr (pm, LOREJECT)) + call pargstr (KY_HIREJECT) + call pargr (rg_pstatr (pm, HIREJECT)) + call printf (" %s = %g\n") + call pargstr (KY_APODIZE) + call pargr (rg_pstatr (pm, APODIZE)) + + call printf ("Filtering:\n") + call rg_pstats (pm, FSTRING, Memc[str], SZ_LINE) + call printf (" %s: %s\n") + call pargstr (KY_FILTER) + call pargstr (Memc[str]) + if (rg_pstati(pm,FILTER) == PM_FCOSBELL) { + call printf (" %s: %g %s: %g\n") + call pargstr (KY_SXINNER) + call pargr (rg_pstatr (pm, SXINNER)) + call pargstr (KY_SXOUTER) + call pargr (rg_pstatr (pm, SXOUTER)) + call printf (" %s: %g %s: %g\n") + call pargstr (KY_SYINNER) + call pargr (rg_pstatr (pm, SYINNER)) + call pargstr (KY_SYOUTER) + call pargr (rg_pstatr (pm, SYOUTER)) + call printf (" %s: %b\n") + call pargstr (KY_RADSYM) + call pargb (itob(rg_pstati(pm,RADSYM))) + } else { + call printf (" %s: %g\n") + call pargstr (KY_UFLUXRATIO) + call pargr (rg_pstatr (pm, UFLUXRATIO)) + call printf (" %s: %g\n") + call pargstr (KY_THRESHOLD) + call pargr (rg_pstatr(pm,THRESHOLD)) + } + + call printf ("Normalization\n") + call printf (" %s: %g\n") + call pargstr (KY_NORMFACTOR) + call pargr (rg_pstatr (pm, NORMFACTOR)) + + call printf ("\n") + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/psfmatch/rgptools.x b/pkg/images/immatch/src/psfmatch/rgptools.x new file mode 100644 index 00000000..df36c166 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgptools.x @@ -0,0 +1,641 @@ +include "psfmatch.h" + +# RG_PINIT -- Initialize the main psfmatch data structure. + +procedure rg_pinit (pm, cfunc) + +pointer pm #O pointer to psfmatch structure +int cfunc #I mode of computing the convolution function + +begin + call malloc (pm, LEN_PSFSTRUCT, TY_STRUCT) + + # Initialize the pointers. + PM_RC1(pm) = NULL + PM_RC2(pm) = NULL + PM_RL1(pm) = NULL + PM_RL2(pm) = NULL + PM_RZERO(pm) = NULL + PM_RXSLOPE(pm) = NULL + PM_RYSLOPE(pm) = NULL + PM_NREGIONS(pm) = 0 + PM_CNREGION(pm) = 1 + + # Define the background fitting parameters. + PM_CENTER(pm) = DEF_CENTER + PM_BACKGRD(pm) = DEF_BACKGRD + PM_BVALUER(pm) = 0.0 + PM_BVALUE(pm) = 0.0 + call strcpy ("median", PM_BSTRING(pm), SZ_FNAME) + PM_LOREJECT(pm) = DEF_LOREJECT + PM_HIREJECT(pm) = DEF_HIREJECT + PM_APODIZE(pm) = 0.0 + + PM_UFLUXRATIO(pm) = DEF_UFLUXRATIO + PM_FILTER(pm) = DEF_FILTER + call strcpy ("replace", PM_FSTRING(pm), SZ_FNAME) + PM_SXINNER(pm) = DEF_SXINNER + PM_SXOUTER(pm) = DEF_SXOUTER + PM_SYINNER(pm) = DEF_SYINNER + PM_SYOUTER(pm) = DEF_SYOUTER + PM_RADSYM(pm) = DEF_RADSYM + PM_THRESHOLD(pm) = DEF_THRESHOLD + + PM_NORMFACTOR(pm) = DEF_NORMFACTOR + + PM_CONVOLUTION(pm) = cfunc + switch (cfunc) { + case PM_CONIMAGE: + PM_CONVOLUTION(pm) = PM_CONIMAGE + call strcpy ("image", PM_CSTRING(pm), SZ_FNAME) + case PM_CONPSF: + PM_CONVOLUTION(pm) = PM_CONPSF + call strcpy ("psf", PM_CSTRING(pm), SZ_FNAME) + case PM_CONKERNEL: + PM_CONVOLUTION(pm) = PM_CONKERNEL + call strcpy ("kernel", PM_CSTRING(pm), SZ_FNAME) + default: + PM_CONVOLUTION(pm) = PM_CONIMAGE + call strcpy ("image", PM_CSTRING(pm), SZ_FNAME) + } + PM_DNX(pm) = DEF_DNX + PM_DNY(pm) = DEF_DNY + PM_PNX(pm) = DEF_PNX + PM_PNY(pm) = DEF_PNY + PM_KNX(pm) = 0 + PM_KNY(pm) = 0 + PM_POWER(pm) = DEF_POWER + + PM_REFFFT(pm) = NULL + PM_IMFFT(pm) = NULL + PM_FFT(pm) = NULL + PM_CONV(pm) = NULL + PM_ASFFT(pm) = NULL + PM_NXFFT(pm) = 0 + PM_NYFFT(pm) = 0 + + # Initialize the strings. + PM_IMAGE(pm) = EOS + PM_REFIMAGE(pm) = EOS + PM_PSFDATA(pm) = EOS + PM_PSFIMAGE(pm) = EOS + PM_OBJLIST(pm) = EOS + PM_KERNEL(pm) = EOS + PM_OUTIMAGE(pm) = EOS + + # Initialize the buffers. + call rg_prinit (pm) +end + + +# RG_PRINIT -- Initialize the regions definition portion of the psf matching +# code fitting structure. + +procedure rg_prinit (pm) + +pointer pm #I pointer to psfmatch structure + +begin + call rg_prfree (pm) + + PM_NREGIONS(pm) = 0 + PM_CNREGION(pm) = 1 + + call malloc (PM_RC1(pm), MAX_NREGIONS, TY_INT) + call malloc (PM_RC2(pm), MAX_NREGIONS, TY_INT) + call malloc (PM_RL1(pm), MAX_NREGIONS, TY_INT) + call malloc (PM_RL2(pm), MAX_NREGIONS, TY_INT) + call malloc (PM_RZERO(pm), MAX_NREGIONS, TY_REAL) + call malloc (PM_RXSLOPE(pm), MAX_NREGIONS, TY_REAL) + call malloc (PM_RYSLOPE(pm), MAX_NREGIONS, TY_REAL) + + call amovki (INDEFI, Memi[PM_RC1(pm)], MAX_NREGIONS) + call amovki (INDEFI, Memi[PM_RC2(pm)], MAX_NREGIONS) + call amovki (INDEFI, Memi[PM_RL1(pm)], MAX_NREGIONS) + call amovki (INDEFI, Memi[PM_RL2(pm)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[PM_RZERO(pm)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[PM_RXSLOPE(pm)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[PM_RYSLOPE(pm)], MAX_NREGIONS) +end + + +# RG_PINDEFR -- Re-initialize the background and answers regions portion of +# the psf-matching structure. + +procedure rg_pindefr (pm) + +pointer pm #I pointer to the psfmatch structure + +int nregions +int rg_pstati () + +begin + nregions = rg_pstati (pm, NREGIONS) + + if (nregions > 0) { + call amovkr (INDEFR, Memr[PM_RZERO(pm)], nregions) + call amovkr (INDEFR, Memr[PM_RXSLOPE(pm)], nregions) + call amovkr (INDEFR, Memr[PM_RYSLOPE(pm)], nregions) + } +end + + +# RG_PREALLOC -- Reallocate the regions buffers and initialize if necessary. + +procedure rg_prealloc (pm, nregions) + +pointer pm #I pointer to psfmatch structure +int nregions #I number of regions + +int nr +int rg_pstati() + +begin + nr = rg_pstati (pm, NREGIONS) + + call realloc (PM_RC1(pm), nregions, TY_INT) + call realloc (PM_RC2(pm), nregions, TY_INT) + call realloc (PM_RL1(pm), nregions, TY_INT) + call realloc (PM_RL2(pm), nregions, TY_INT) + call realloc (PM_RZERO(pm), nregions, TY_REAL) + call realloc (PM_RXSLOPE(pm), nregions, TY_REAL) + call realloc (PM_RYSLOPE(pm), nregions, TY_REAL) + + call amovki (INDEFI, Memi[PM_RC1(pm)+nr], nregions - nr) + call amovki (INDEFI, Memi[PM_RC2(pm)+nr], nregions - nr) + call amovki (INDEFI, Memi[PM_RL1(pm)+nr], nregions - nr) + call amovki (INDEFI, Memi[PM_RL2(pm)+nr], nregions - nr) + call amovkr (INDEFR, Memr[PM_RZERO(pm)+nr], nregions - nr) + call amovkr (INDEFR, Memr[PM_RXSLOPE(pm)+nr], nregions - nr) + call amovkr (INDEFR, Memr[PM_RYSLOPE(pm)+nr], nregions - nr) + #call amovkr (INDEFR, Memr[PM_XSHIFTS(pm)+nr], nregions - nr) + #call amovkr (INDEFR, Memr[PM_YSHIFTS(pm)+nr], nregions - nr) +end + + +# RG_PRFREE -- Free the regions portion of the psfmatch structure. + +procedure rg_prfree (pm) + +pointer pm #I/O pointer to psfmatch structure + +begin + call rg_pseti (pm, NREGIONS, 0) + if (PM_RC1(pm) != NULL) + call mfree (PM_RC1(pm), TY_INT) + PM_RC1(pm) = NULL + if (PM_RC2(pm) != NULL) + call mfree (PM_RC2(pm), TY_INT) + PM_RC2(pm) = NULL + if (PM_RL1(pm) != NULL) + call mfree (PM_RL1(pm), TY_INT) + PM_RL1(pm) = NULL + if (PM_RL2(pm) != NULL) + call mfree (PM_RL2(pm), TY_INT) + PM_RL2(pm) = NULL + if (PM_RZERO(pm) != NULL) + call mfree (PM_RZERO(pm), TY_REAL) + PM_RZERO(pm) = NULL + if (PM_RXSLOPE(pm) != NULL) + call mfree (PM_RXSLOPE(pm), TY_REAL) + PM_RXSLOPE(pm) = NULL + if (PM_RYSLOPE(pm) != NULL) + call mfree (PM_RYSLOPE(pm), TY_REAL) + PM_RYSLOPE(pm) = NULL +end + + +# RG_PFREE -- Free the psfmatch structure. + +procedure rg_pfree (pm) + +pointer pm #I pointer to psfmatch structure + +begin + # Free the region descriptors + call rg_prfree (pm) + + if (PM_REFFFT(pm) != NULL) + call mfree (PM_REFFFT(pm), TY_REAL) + if (PM_IMFFT(pm) != NULL) + call mfree (PM_IMFFT(pm), TY_REAL) + if (PM_FFT(pm) != NULL) + call mfree (PM_FFT(pm), TY_REAL) + if (PM_CONV(pm) != NULL) + call mfree (PM_CONV(pm), TY_REAL) + if (PM_ASFFT(pm) != NULL) + call mfree (PM_ASFFT(pm), TY_REAL) + + call mfree (pm, TY_STRUCT) +end + + +# RG_PSTATI -- Fetch the value of a psfmatch task integer parameter. + +int procedure rg_pstati (pm, param) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched + +begin + switch (param) { + case NREGIONS: + return (PM_NREGIONS(pm)) + case CNREGION: + return (PM_CNREGION(pm)) + case CENTER: + return (PM_CENTER(pm)) + case BACKGRD: + return (PM_BACKGRD(pm)) + case CONVOLUTION: + return (PM_CONVOLUTION(pm)) + case DNX: + return (PM_DNX(pm)) + case DNY: + return (PM_DNY(pm)) + case PNX: + return (PM_PNX(pm)) + case PNY: + return (PM_PNY(pm)) + case KNX: + return (PM_KNX(pm)) + case KNY: + return (PM_KNY(pm)) + case POWER: + return (PM_POWER(pm)) + + case FILTER: + return (PM_FILTER(pm)) + case RADSYM: + return (PM_RADSYM(pm)) + + case NXFFT: + return (PM_NXFFT(pm)) + case NYFFT: + return (PM_NYFFT(pm)) + + default: + call error (0, "RG_PSTATI: Unknown integer parameter.") + } +end + + +# RG_PSTATP -- Fetch the value of a psfmatch task pointer parameter. + +pointer procedure rg_pstatp (pm, param) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched + +begin + switch (param) { + case RC1: + return (PM_RC1(pm)) + case RC2: + return (PM_RC2(pm)) + case RL1: + return (PM_RL1(pm)) + case RL2: + return (PM_RL2(pm)) + case RZERO: + return (PM_RZERO(pm)) + case RXSLOPE: + return (PM_RXSLOPE(pm)) + case RYSLOPE: + return (PM_RYSLOPE(pm)) + case REFFFT: + return (PM_REFFFT(pm)) + case IMFFT: + return (PM_IMFFT(pm)) + case FFT: + return (PM_FFT(pm)) + case CONV: + return (PM_CONV(pm)) + case ASFFT: + return (PM_ASFFT(pm)) + default: + call error (0, "RG_PSTATP: Unknown pointer parameter.") + } +end + + +# RG_PSTATR -- Fetch the value of a psfmath task real parameter. + +real procedure rg_pstatr (pm, param) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched + +begin + switch (param) { + case BVALUER: + return (PM_BVALUER(pm)) + case BVALUE: + return (PM_BVALUE(pm)) + case APODIZE: + return (PM_APODIZE(pm)) + case LOREJECT: + return (PM_LOREJECT(pm)) + case HIREJECT: + return (PM_HIREJECT(pm)) + case UFLUXRATIO: + return (PM_UFLUXRATIO(pm)) + case FLUXRATIO: + return (PM_FLUXRATIO(pm)) + case SXINNER: + return (PM_SXINNER(pm)) + case SXOUTER: + return (PM_SXOUTER(pm)) + case SYINNER: + return (PM_SYINNER(pm)) + case SYOUTER: + return (PM_SYOUTER(pm)) + case THRESHOLD: + return (PM_THRESHOLD(pm)) + case NORMFACTOR: + return (PM_NORMFACTOR(pm)) + default: + call error (0, "RG_PSTATR: Unknown real parameter.") + } +end + + +# RG_PSTATS -- Fetch the value of a psfmatch string string parameter. + +procedure rg_pstats (pm, param, str, maxch) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched +char str[ARB] # output string +int maxch # maximum number of characters + +begin + switch (param) { + case BSTRING: + call strcpy (PM_BSTRING(pm), str, maxch) + case CSTRING: + call strcpy (PM_CSTRING(pm), str, maxch) + case FSTRING: + call strcpy (PM_FSTRING(pm), str, maxch) + case IMAGE: + call strcpy (PM_IMAGE(pm), str, maxch) + case REFIMAGE: + call strcpy (PM_REFIMAGE(pm), str, maxch) + case PSFDATA: + call strcpy (PM_PSFDATA(pm), str, maxch) + case PSFIMAGE: + call strcpy (PM_PSFIMAGE(pm), str, maxch) + case OBJLIST: + call strcpy (PM_OBJLIST(pm), str, maxch) + case KERNEL: + call strcpy (PM_KERNEL(pm), str, maxch) + case OUTIMAGE: + call strcpy (PM_OUTIMAGE(pm), str, maxch) + default: + call error (0, "RG_PSTATS: Unknown string parameter.") + } +end + + +# RG_PSETI -- Set the value of a psfmatch task integer parameter. + +procedure rg_pseti (pm, param, value) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched +int value # value of the integer parameter + +begin + switch (param) { + case NREGIONS: + PM_NREGIONS(pm) = value + case CNREGION: + PM_CNREGION(pm) = value + case CENTER: + PM_CENTER(pm) = value + case BACKGRD: + PM_BACKGRD(pm) = value + switch (value) { + case PM_BNONE: + call strcpy ("none", PM_BSTRING(pm), SZ_FNAME) + case PM_BMEAN: + call strcpy ("mean", PM_BSTRING(pm), SZ_FNAME) + case PM_BMEDIAN: + call strcpy ("median", PM_BSTRING(pm), SZ_FNAME) + case PM_BSLOPE: + call strcpy ("plane", PM_BSTRING(pm), SZ_FNAME) + case PM_BNUMBER: + ; + default: + call strcpy ("none", PM_BSTRING(pm), SZ_FNAME) + } + case CONVOLUTION: + PM_CONVOLUTION(pm) = value + switch (value) { + case PM_CONIMAGE: + call strcpy ("image", PM_CSTRING(pm), SZ_FNAME) + case PM_CONPSF: + call strcpy ("psf", PM_CSTRING(pm), SZ_FNAME) + case PM_CONKERNEL: + call strcpy ("kernel", PM_CSTRING(pm), SZ_FNAME) + default: + call strcpy ("image", PM_CSTRING(pm), SZ_FNAME) + } + case DNX: + PM_DNX(pm) = value + case DNY: + PM_DNY(pm) = value + case PNX: + PM_PNX(pm) = value + case PNY: + PM_PNY(pm) = value + case KNX: + PM_KNX(pm) = value + case KNY: + PM_KNY(pm) = value + case POWER: + PM_POWER(pm) = value + case RADSYM: + PM_RADSYM(pm) = value + case NXFFT: + PM_NXFFT(pm) = value + case NYFFT: + PM_NYFFT(pm) = value + case FILTER: + PM_FILTER(pm) = value + switch (value) { + case PM_FNONE: + call strcpy ("none", PM_FSTRING(pm), SZ_FNAME) + case PM_FCOSBELL: + call strcpy ("cosbell", PM_FSTRING(pm), SZ_FNAME) + case PM_FREPLACE: + call strcpy ("replace", PM_FSTRING(pm), SZ_FNAME) + case PM_FMODEL: + call strcpy ("model", PM_FSTRING(pm), SZ_FNAME) + default: + call strcpy ("none", PM_FSTRING(pm), SZ_FNAME) + } + default: + call error (0, "RG_PSETI: Unknown integer parameter.") + } +end + + +# RG_PSETP -- Set the value of a psfmatch task pointer parameter. + +procedure rg_psetp (pm, param, value) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched +pointer value # value of the pointer parameter + +begin + switch (param) { + case RC1: + PM_RC1(pm) = value + case RC2: + PM_RC2(pm) = value + case RL1: + PM_RL1(pm) = value + case RL2: + PM_RL2(pm) = value + case RZERO: + PM_RZERO(pm) = value + case RXSLOPE: + PM_RXSLOPE(pm) = value + case RYSLOPE: + PM_RYSLOPE(pm) = value + case REFFFT: + PM_REFFFT(pm) = value + case IMFFT: + PM_IMFFT(pm) = value + case FFT: + PM_FFT(pm) = value + case CONV: + PM_CONV(pm) = value + case ASFFT: + PM_ASFFT(pm) = value + + default: + call error (0, "RG_PSETP: Unknown pointer parameter.") + } +end + + +# RG_PSETR -- Set the value of a psfmatch task real parameter. + +procedure rg_psetr (pm, param, value) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched +real value # real parameter + +begin + switch (param) { + case BVALUER: + PM_BVALUER(pm) = value + case BVALUE: + PM_BVALUE(pm) = value + case LOREJECT: + PM_LOREJECT(pm) = value + case HIREJECT: + PM_HIREJECT(pm) = value + case APODIZE: + PM_APODIZE(pm) = value + case UFLUXRATIO: + PM_UFLUXRATIO(pm) = value + case FLUXRATIO: + PM_FLUXRATIO(pm) = value + case SXINNER: + PM_SXINNER(pm) = value + case SXOUTER: + PM_SXOUTER(pm) = value + case SYINNER: + PM_SYINNER(pm) = value + case SYOUTER: + PM_SYOUTER(pm) = value + case THRESHOLD: + PM_THRESHOLD(pm) = value + case NORMFACTOR: + PM_NORMFACTOR(pm) = value + default: + call error (0, "RG_PSETR: Unknown real parameter.") + } +end + + +# RG_PSETS -- Procedure to set the value of a string parameter. + +procedure rg_psets (pm, param, str) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched +char str[ARB] # output string + +int index, ip +pointer sp, temp +real rval +int strdic(), fnldir(), ctor() + +begin + call smark (sp) + call salloc (temp, SZ_LINE, TY_CHAR) + + switch (param) { + case BSTRING: + ip = 1 + index = strdic (str, str, SZ_LINE, PM_BTYPES) + if (index > 0) { + call strcpy (str, PM_BSTRING(pm), SZ_FNAME) + call rg_pseti (pm, BACKGRD, index) + } else if (ctor (str, ip, rval) > 0) { + call rg_psetr (pm, BVALUE, rval) + if (ctor (str, ip, rval) > 0) { + call rg_psetr (pm, BVALUER, rval) + call strcpy (str, PM_BSTRING(pm), SZ_FNAME) + call rg_pseti (pm, BACKGRD, PM_NUMBER) + } else { + call rg_psetr (pm, BVALUE, 0.0) + call rg_psetr (pm, BVALUER, 0.0) + } + } + case CSTRING: + index = strdic (str, str, SZ_LINE, PM_CTYPES) + if (index > 0) { + call strcpy (str, PM_CSTRING(pm), SZ_FNAME) + call rg_pseti (pm, CONVOLUTION, index) + } + case FSTRING: + index = strdic (str, str, SZ_LINE, PM_FTYPES) + if (index > 0) { + call strcpy (str, PM_FSTRING(pm), SZ_FNAME) + call rg_pseti (pm, FILTER, index) + } + case IMAGE: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], PM_IMAGE(pm), SZ_FNAME) + call strcpy (Memc[temp+index], PM_IMAGE(pm), SZ_FNAME) + case REFIMAGE: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], PM_REFIMAGE(pm), SZ_FNAME) + call strcpy (Memc[temp+index], PM_REFIMAGE(pm), SZ_FNAME) + case PSFDATA: + call strcpy (str, PM_PSFDATA(pm), SZ_FNAME) + case PSFIMAGE: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], PM_PSFIMAGE(pm), SZ_FNAME) + call strcpy (Memc[temp+index], PM_PSFIMAGE(pm), SZ_FNAME) + case OBJLIST: + call strcpy (str, PM_OBJLIST(pm), SZ_FNAME) + case KERNEL: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], PM_KERNEL(pm), SZ_FNAME) + call strcpy (Memc[temp+index], PM_KERNEL(pm), SZ_FNAME) + case OUTIMAGE: + call strcpy (str, PM_OUTIMAGE(pm), SZ_FNAME) + default: + call error (0, "RG_PSETS: Unknown string parameter.") + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/psfmatch/t_psfmatch.x b/pkg/images/immatch/src/psfmatch/t_psfmatch.x new file mode 100644 index 00000000..182ac286 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/t_psfmatch.x @@ -0,0 +1,365 @@ +include <fset.h> +include <imhdr.h> +include "psfmatch.h" + +# T_PSFMATCH -- Match the resolution of an image to that of a reference +# image. + +procedure t_psfmatch () + +pointer image1 # pointer to the input image name +pointer imager # pointer to the reference image name +pointer fpsflist # pointer to the regions list +pointer image2 # pointer to the output image name +pointer kernel # pointer to the kernel image name +pointer pspectra # pointer to the fourier spectra image name +int interactive # interactive mode ? +int verbose # verbose mode ? +int boundary # boundary extension type +real constant # constant for boundary extension + +int list1, listr, psflist, listk, list2 +int nregions, newref, stat +pointer sp, imtemp, str, pm, gd, id, imr, im1, impsf, imk, im2 +bool clgetb() +int imtopen(), imtlen(), imtgetim(), fntopnb(), fntlenb(), clgwrd(), btoi() +int rg_pstati(), rg_ptmpimage(), rg_pregions(), rg_psfm(), rg_pisfm() +pointer gopen(), immap(), rg_pstatp() +real clgetr() +errchk fntopnb(), fntclsb() + +begin + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate temporary space. + call smark (sp) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (fpsflist, SZ_LINE, TY_CHAR) + call salloc (kernel, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (pspectra, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get task parameters. + call clgstr ("input", Memc[str], SZ_LINE) + list1 = imtopen (Memc[str]) + call clgstr ("reference", Memc[str], SZ_LINE) + listr = imtopen (Memc[str]) + call clgstr ("psfdata", Memc[fpsflist], SZ_LINE) + call clgstr ("kernel", Memc[str], SZ_LINE) + listk = imtopen (Memc[str]) + call clgstr ("output", Memc[str], SZ_LINE) + list2 = imtopen (Memc[str]) + + # Open the psf matching fitting structure. + call rg_pgpars (pm) + + # Will the task run in interactive mode? + if (rg_pstati (pm, CONVOLUTION) == PM_CONKERNEL) + interactive = NO + else + interactive = btoi (clgetb ("interactive")) + + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL) { + if (imtlen (listr) <= 0) + call error (0, "The reference image list is empty.") + if (imtlen (listr) > 1 && imtlen (listr) != imtlen (list1)) + call error (0, + "The number of reference and input images is not the same.") + if (interactive == NO && Memc[fpsflist] == EOS) { + call error (0, "The objects list is empty.") + } else if (rg_pstati (pm, CONVOLUTION) == PM_CONIMAGE) { + psflist = fntopnb (Memc[fpsflist], NO) + if (fntlenb(psflist) > 0 && imtlen (listr) != fntlenb (psflist)) + call error (0, + "The number of reference images and objects lists is not the same") + } else { + psflist = imtopen (Memc[fpsflist]) + if (imtlen (list1) != imtlen (psflist)) + call error (0, + "The number of input and psf images is not the same") + } + call rg_psets (pm, PSFDATA, Memc[fpsflist]) + } else { + call imtclose (listr) + listr = NULL + psflist = NULL + call rg_psets (pm, PSFDATA, "") + } + + # Compare the lengths of the input and output lists. + if (imtlen(listk) <= 0) { + call imtclose (listk) + listk = NULL + } else if (imtlen (list1) != imtlen (listk)) + call error (0, + "The number of input and kernel images is not the same.") + + if (imtlen (list2) <= 0) { + call imtclose (list2) + list2 = NULL + } else if (imtlen (list1) != imtlen (list2)) + call error (0, + "The number of input and output images are not the same.") + + # Get the boundary extension parameters for the image convolution. + boundary = clgwrd ("boundary", Memc[str], SZ_LINE, + "|constant|nearest|reflect|wrap|") + constant = clgetr ("constant") + + if (interactive == YES) { + call clgstr ("graphics", Memc[str], SZ_FNAME) + iferr (gd = gopen (Memc[str], NEW_FILE, STDGRAPH)) + gd = NULL + call clgstr ("display", Memc[str], SZ_FNAME) + iferr (id = gopen (Memc[str], APPEND, STDIMAGE)) + id = NULL + verbose = YES + } else { + gd = NULL + id = NULL + verbose = btoi (clgetb ("verbose")) + } + + imr = NULL + impsf = NULL + + # Do each set of input and output images. + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF)) { + + # Open reference image and the associated objects file + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL) { + if (imtgetim (listr, Memc[imager], SZ_FNAME) != EOF) { + if (imr != NULL) + call imunmap (imr) + imr = immap (Memc[imager], READ_ONLY, 0) + if (IM_NDIM(imr) > 2) + call error (0, "Reference psf/image must be 1D or 2D") + call rg_psets (pm, REFIMAGE, Memc[imager]) + if (rg_pstati (pm, CONVOLUTION) == PM_CONIMAGE) { + nregions = rg_pregions (psflist, imr, pm, 1, NO) + if (nregions <= 0 && interactive == NO) + call error (0, "The objects list is empty.") + call rg_psets (pm, PSFIMAGE, "") + } + newref = YES + } + if (rg_pstati (pm, CONVOLUTION) == PM_CONPSF) { + if (imtgetim (psflist, Memc[str], SZ_FNAME) != EOF) { + impsf = immap (Memc[str], READ_ONLY, 0) + if (IM_NDIM(impsf) != IM_NDIM(imr)) + call error (0, + "Image and reference psf must have same dimensionality") + if (IM_LEN(impsf,1) != IM_LEN(imr,1)) + call error (0, + "Image and reference psf are not the same size") + if (IM_NDIM(impsf) == 2 && (IM_LEN(impsf,2) != + IM_LEN(imr,2))) + call error (0, + "Image and reference psf are not the same size") + call rg_psets (pm, PSFIMAGE, Memc[str]) + newref = YES + } + } + } else { + imr = NULL + impsf = NULL + call rg_psets (pm, REFIMAGE, "") + call rg_psets (pm, PSFIMAGE, "") + call rg_psets (pm, OBJLIST, "") + newref = NO + } + + # Open the input image. + im1 = immap (Memc[image1], READ_ONLY, 0) + if (IM_NDIM(im1) > 2) { + call error (0, "Input image must be 1D or 2D") + } else if (imr != NULL) { + if (IM_NDIM(im1) != IM_NDIM(imr)) + call error (0, + "Input and reference images must have same dimensionality") + } + call rg_psets (pm, IMAGE, Memc[image1]) + + # Open the kernel image name. + if (listk != NULL) { + if (imtgetim (listk, Memc[kernel], SZ_FNAME) != EOF) + ; + } else { + if (rg_ptmpimage (Memc[image1], "ker", "ker", Memc[kernel], + SZ_FNAME) == NO) + ; + } + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL) + imk = immap (Memc[kernel], NEW_IMAGE, 0) + else + imk = immap (Memc[kernel], READ_ONLY, 0) + call rg_psets (pm, KERNEL, Memc[kernel]) + + + # Construct the output image name. + if (list2 == NULL) { + im2 = NULL + Memc[image2] = NULL + } else if (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF) { + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + im2 = immap (Memc[image2], NEW_COPY, im1) + } else { + im2 = NULL + Memc[image2] = NULL + } + call rg_psets (pm, OUTIMAGE, Memc[image2]) + + # Compute the the psf matching kernel. + if (interactive == YES) { + stat = rg_pisfm (pm, imr, psflist, impsf, im1, imk, NULL, im2, + gd, id) + } else { + if (rg_psfm (pm, imr, im1, impsf, imk, newref) == OK) { + if (verbose == YES) { + call printf ( + "Completed computing/reading kernel %s for image %s\n") + call pargstr (Memc[kernel]) + call pargstr (Memc[image1]) + if (rg_pstati(pm, CONVOLUTION) != PM_CONKERNEL) + call rg_pwrite (pm, imk, NULL) + } + } else { + if (verbose == YES) { + call printf ( + "Error computing/reading kernel %s for image %s\n") + call pargstr (Memc[kernel]) + call pargstr (Memc[image1]) + } + } + stat = NO + } + + # Convolve the image. + if (im2 != NULL && stat == NO) { + if (verbose == YES) { + if (rg_pstatp(pm, CONV) != NULL) + call printf ( + "\tComputing matched image %s ...\n") + else + call printf ( + "\tComputing matched image %s ...\n") + call pargstr (Memc[imtemp]) + call pargstr (Memc[kernel]) + } + if (rg_pstatp(pm, CONV) != NULL) + call rg_pconvolve (im1, im2, Memr[rg_pstatp(pm,CONV)], + rg_pstati(pm,KNX), rg_pstati(pm,KNY), boundary, + constant) + } + + # Close up the images. + if (im2 != NULL) { + call imunmap (im2) + if (rg_pstatp(pm, CONV) == NULL) + call imdelete (Memc[image2]) + else + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + if (impsf != NULL) + call imunmap (impsf) + if (imk != NULL) { + call imunmap (imk) + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL && + rg_pstatp(pm, CONV) == NULL) + call imdelete (Memc[kernel]) + } + call imunmap (im1) + + if (stat == YES) + break + newref = NO + } + + # Close up the lists. + if (imr != NULL) + call imunmap (imr) + + if (list2 != NULL) + call imtclose (list2) + if (listk != NULL) + call imtclose (listk) + if (psflist != NULL) { + if (rg_pstati (pm, CONVOLUTION) == PM_CONIMAGE) + call fntclsb (psflist) + else + call imtclose (psflist) + } + if (listr != NULL) + call imtclose (listr) + call imtclose (list1) + + call rg_pfree (pm) + + # Close up te graphics and the display. + if (gd != NULL) + call gclose (gd) + if (id != NULL) + call gclose (id) + + call sfree (sp) +end + + +# RG_PTMPIMAGE -- Generate either a permanent image name using a user specified +# prefix or temporary image name using a default prefix. Return NO if the +# image is temporary or YES if it is permanent. + +int procedure rg_ptmpimage (image, prefix, tmp, name, maxch) + +char image[ARB] #I image name +char prefix[ARB] #I user supplied prefix +char tmp[ARB] #I user supplied temporary root +char name[ARB] #O output name +int maxch #I max number of chars + +int npref, ndir +int fnldir(), rg_pimroot(), strlen() + +begin + npref = strlen (prefix) + ndir = fnldir (prefix, name, maxch) + if (npref == ndir) { + call mktemp (tmp, name[ndir+1], maxch) + return (NO) + } else { + call strcpy (prefix, name, npref) + if (rg_pimroot (image, name[npref+1], maxch) <= 0) + ; + return (YES) + } +end + + +# RG_PIMROOT -- Fetch the root image name minus the directory specification +# and the section notation. The length of the root name is returned. + +int procedure rg_pimroot (image, root, maxch) + +char image[ARB] #I image specification +char root[ARB] #O rootname +int maxch #I maximum number of characters + +int nchars +pointer sp, str +int fnldir(), strlen() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + call imgimage (image, root, maxch) + nchars = fnldir (root, Memc[str], maxch) + call strcpy (root[nchars+1], root, maxch) + + call sfree (sp) + return (strlen (root)) +end diff --git a/pkg/images/immatch/src/wcsmatch/mkpkg b/pkg/images/immatch/src/wcsmatch/mkpkg new file mode 100644 index 00000000..638ee1e8 --- /dev/null +++ b/pkg/images/immatch/src/wcsmatch/mkpkg @@ -0,0 +1,14 @@ +# Make the SKYXYMATCH / WCSXYMATCH / WCSCOPY tasks + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + +libpkg.a: + rgmatchio.x wcsxymatch.h + t_skyxymatch.x <fset.h> <imhdr.h> <mwset.h> <math.h> \ + <pkg/skywcs.h> wcsxymatch.h + t_wcscopy.x <imhdr.h> <mwset.h> + t_wcsxymatch.x <fset.h> <imhdr.h> <mwset.h> wcsxymatch.h + ; diff --git a/pkg/images/immatch/src/wcsmatch/rgmatchio.x b/pkg/images/immatch/src/wcsmatch/rgmatchio.x new file mode 100644 index 00000000..1a0de167 --- /dev/null +++ b/pkg/images/immatch/src/wcsmatch/rgmatchio.x @@ -0,0 +1,77 @@ +include "wcsxymatch.h" + +define DEF_BUFSIZE 200 + +# RG_RDXY -- Read in the x and y coordinates from a file. + +int procedure rg_rdxy (fd, x, y, wcs, xcolumn, ycolumn, xunits, yunits) + +int fd #I the input file descriptor +pointer x #U pointer to the x coordinates +pointer y #U pointer to the y coordinates +int wcs #I the world coordinate system +int xcolumn #I column containing the x coordinate +int ycolumn #I column containing the y coordinate +int xunits #I the x coordinate units +int yunits #I the y coordinate units + +double xval, yval +int i, ip, bufsize, maxcols, npts +pointer sp, str +int fscan(), nscan(), ctod() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + bufsize = DEF_BUFSIZE + call malloc (x, bufsize, TY_DOUBLE) + call malloc (y, bufsize, TY_DOUBLE) + maxcols = max (xcolumn, ycolumn) + + npts = 0 + while (fscan(fd) != EOF) { + + xval = INDEFD + yval = INDEFD + do i = 1, maxcols { + call gargwrd (Memc[str], SZ_FNAME) + if (i != nscan()) + break + ip = 1 + if (i == xcolumn) { + if (ctod (Memc[str], ip, xval) <= 0) + xval = INDEFD + } else if (i == ycolumn) { + if (ctod (Memc[str], ip, yval) <= 0) + yval = INDEFD + } + } + if (IS_INDEFD(xval) || IS_INDEFD(yval)) + next + + Memd[x+npts] = xval + Memd[y+npts] = yval + npts = npts + 1 + if (npts >= bufsize) { + bufsize = bufsize + DEF_BUFSIZE + call realloc (x, bufsize, TY_DOUBLE) + call realloc (y, bufsize, TY_DOUBLE) + } + } + + # Convert the coordinates if necessary. + switch (wcs) { + case RG_WORLD: + if (xunits == RG_UHOURS) + call amulkd (Memd[x], 15.0d0, Memd[x], npts) + if (yunits == RG_UHOURS) + call amulkd (Memd[y], 15.0d0, Memd[y], npts) + default: + ; + } + + call sfree (sp) + + return (npts) +end diff --git a/pkg/images/immatch/src/wcsmatch/t_skyxymatch.x b/pkg/images/immatch/src/wcsmatch/t_skyxymatch.x new file mode 100644 index 00000000..533d36a8 --- /dev/null +++ b/pkg/images/immatch/src/wcsmatch/t_skyxymatch.x @@ -0,0 +1,690 @@ +include <fset.h> +include <imhdr.h> +include <mwset.h> +include <math.h> +include <pkg/skywcs.h> +include "wcsxymatch.h" + +# T_SKYXYMATCH -- Compute a list of the tie points required to register an +# image to a reference image using WCS information in the image headers and +# the celestial coordinate transformation routines. + +procedure t_skyxymatch() + +bool verbose +double xmin, xmax, ymin, ymax, x1, x2, y1, y2 +int ilist, rlist, olist, clist, cfd, ofd +int nx, ny, wcs, min_sigdigits, xcolumn, ycolumn, xunits, yunits +int rstat, stat, npts +pointer sp, refimage, image, xformat, yformat, rxformat, ryformat +pointer rwxformat, rwyformat, txformat, tyformat, twxformat, twyformat, str +pointer imr, im, mwr, mw, coor, coo, ctr, ct +pointer rxl, ryl, rxw, ryw, trxw, tryw, ixl, iyl + +bool clgetb(), streq() +double clgetd() +int imtopen(), fntopnb(), clgeti(), clgwrd(), strdic(), imtlen() +int fntlenb(), imtgetim(), fntgfnb(), open(), mw_stati(), sk_decim() +int rg_rdxy(), rg_xytoxy(), sk_stati() +pointer immap() +errchk mw_gwattrs() + +begin + # Get some temporary working space. + call smark (sp) + call salloc (refimage, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (xformat, SZ_FNAME, TY_CHAR) + call salloc (yformat, SZ_FNAME, TY_CHAR) + call salloc (rwxformat, SZ_FNAME, TY_CHAR) + call salloc (rwyformat, SZ_FNAME, TY_CHAR) + call salloc (rxformat, SZ_FNAME, TY_CHAR) + call salloc (ryformat, SZ_FNAME, TY_CHAR) + call salloc (twxformat, SZ_FNAME, TY_CHAR) + call salloc (twyformat, SZ_FNAME, TY_CHAR) + call salloc (txformat, SZ_FNAME, TY_CHAR) + call salloc (tyformat, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the input image and output file lists. + call clgstr ("input", Memc[str], SZ_FNAME) + ilist = imtopen (Memc[str]) + call clgstr ("reference", Memc[str], SZ_FNAME) + rlist = imtopen (Memc[str]) + call clgstr ("output", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) + call strcpy ("STDOUT", Memc[str], SZ_FNAME) + olist = fntopnb (Memc[str], NO) + + # Determine the source of the input coordinates. + call clgstr ("coords", Memc[str], SZ_FNAME) + if (streq (Memc[str], "grid")) { + clist = NULL + xmin = clgetd ("xmin") + xmax = clgetd ("xmax") + ymin = clgetd ("ymin") + ymax = clgetd ("ymax") + nx = clgeti ("nx") + ny = clgeti ("ny") + wcs = clgwrd ("wcs", Memc[str], SZ_FNAME, RG_WCSLIST) + } else { + clist = fntopnb (Memc[str], NO) + xmin = INDEFD + xmax = INDEFD + ymin = INDEFD + ymax = INDEFD + nx = clgeti ("nx") + ny = clgeti ("ny") + wcs = clgwrd ("wcs", Memc[str], SZ_FNAME, RG_WCSLIST) + xcolumn = clgeti ("xcolumn") + ycolumn = clgeti ("ycolumn") + call clgstr ("xunits", Memc[str], SZ_FNAME) + xunits = strdic (Memc[str], Memc[str], SZ_FNAME, RG_UNITLIST) + if (xunits <= 0) + xunits = RG_UNATIVE + call clgstr ("yunits", Memc[str], SZ_FNAME) + yunits = strdic (Memc[str], Memc[str], SZ_FNAME, RG_UNITLIST) + if (yunits <= 0) + yunits = RG_UNATIVE + } + + # Get the output coordinate formatting information. + call clgstr ("xformat", Memc[xformat], SZ_FNAME) + call clgstr ("yformat", Memc[yformat], SZ_FNAME) + call clgstr ("rwxformat", Memc[rxformat], SZ_FNAME) + call clgstr ("rwyformat", Memc[ryformat], SZ_FNAME) + call clgstr ("wxformat", Memc[txformat], SZ_FNAME) + call clgstr ("wyformat", Memc[tyformat], SZ_FNAME) + min_sigdigits = clgeti ("min_sigdigits") + + # Get remaining parameters. + verbose = clgetb ("verbose") + + # Check the formatting of the reference and input logical coordinates. + if (Memc[xformat] == EOS) { + call sprintf (Memc[xformat], SZ_FNAME, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } + if (Memc[yformat] == EOS) { + call sprintf (Memc[yformat], SZ_FNAME, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } + + # Check the reference image list length. + if (imtlen (rlist) <= 0) + call error (0, "The reference image list is empty.") + if (imtlen(rlist) > 1 && imtlen(rlist) != imtlen(ilist)) + call error (0, + "The number of reference and input images is not the same.") + + # Check the output coordinate file length. + if (fntlenb(olist) > 1 && fntlenb(olist) != imtlen(ilist)) + call error (0, + "The number of output coords files and input images is not the same.") + + # Check the reference coordinate list length. + if (clist != NULL) { + if (fntlenb (clist) != imtlen (rlist)) + call error (0, + "The number of reference coords files and images are not the same") + } + + # Initialize the reference image and coordinate list pointers. + imr = NULL + cfd = NULL + + # Loop over the input images. + while (imtgetim (ilist, Memc[image], SZ_FNAME) != EOF) { + + # Open the reference image and reference coordinate file and + # compute the logical and world reference coordinates. + if (imtgetim (rlist, Memc[refimage], SZ_FNAME) != EOF) { + + # Open the reference image. + if (imr != NULL) { + call mfree (rxl, TY_DOUBLE) + call mfree (ryl, TY_DOUBLE) + call mfree (rxw, TY_DOUBLE) + call mfree (ryw, TY_DOUBLE) + call mfree (trxw, TY_DOUBLE) + call mfree (tryw, TY_DOUBLE) + call mfree (ixl, TY_DOUBLE) + call mfree (iyl, TY_DOUBLE) + if (mwr != NULL) + call mw_close (mwr) + if (coor != NULL) + #call mfree (coor, TY_STRUCT) + call sk_close (coor) + call imunmap (imr) + } + imr = immap (Memc[refimage], READ_ONLY, 0) + if (IM_NDIM(imr) > 2) + call error (0, "The reference image must be 1D or 2D") + + # Open the reference image wcs. + rstat = sk_decim (imr, "logical", mwr, coor) + + # Check that the wcs dimensions are rational. + if (mwr != NULL) { + if (mw_stati(mwr, MW_NPHYSDIM) < IM_NDIM(imr) || + mw_stati (mwr, MW_NDIM) != IM_NDIM(imr)) { + call mw_close (mwr) + mwr = NULL + } + } + + # Compute the x limits of the logical reference coordinates. + if (IS_INDEFD(xmin)) + x1 = 1.0d0 + else + x1 = max (1.0d0, min (xmin, double(IM_LEN(imr,1)))) + if (IS_INDEFD(xmax)) + x2 = double(IM_LEN(imr,1)) + else + x2 = max (1.0d0, min (xmax, double(IM_LEN(imr,1)))) + + # Compute the y limits of the logical reference coordinates. + if (IM_NDIM(imr) == 1) + y1 = 1.0d0 + else if (IS_INDEFD(ymin)) + y1 = 1.0d0 + else + y1 = max (1.0d0, min (ymin, double(IM_LEN(imr,2)))) + if (IM_NDIM(imr) == 1) + y2 = 1.0d0 + else if (IS_INDEFD(ymax)) + y2 = double(IM_LEN(imr,2)) + else + y2 = max (1.0d0, min (ymax, double(IM_LEN(imr,2)))) + + # Compute the reference logical and world coordinates. + if (clist != NULL) { + + if (cfd != NULL) + call close (cfd) + + if (fntgfnb (clist, Memc[str], SZ_FNAME) != EOF) { + cfd = open (Memc[str], READ_ONLY, TEXT_FILE) + npts = rg_rdxy (cfd, rxw, ryw, wcs, xcolumn, ycolumn, + xunits, yunits) + call malloc (trxw, npts, TY_DOUBLE) + call malloc (tryw, npts, TY_DOUBLE) + call malloc (rxl, npts, TY_DOUBLE) + call malloc (ryl, npts, TY_DOUBLE) + call malloc (ixl, npts, TY_DOUBLE) + call malloc (iyl, npts, TY_DOUBLE) + if (wcs == RG_WORLD) + ctr = rg_xytoxy (mwr, Memd[rxw], Memd[ryw], + Memd[rxl], Memd[ryl], npts, "world", "logical", + 1, 2) + else + ctr = rg_xytoxy (mwr, Memd[rxw], Memd[ryw], + Memd[rxl], Memd[ryl], npts, "physical", + "logical", 1, 2) + } + + } else { + + if (IM_NDIM(imr) == 1) + npts = nx + else + npts = nx * ny + call malloc (rxl, npts, TY_DOUBLE) + call malloc (ryl, npts, TY_DOUBLE) + call malloc (rxw, npts, TY_DOUBLE) + call malloc (ryw, npts, TY_DOUBLE) + call malloc (trxw, npts, TY_DOUBLE) + call malloc (tryw, npts, TY_DOUBLE) + call malloc (ixl, npts, TY_DOUBLE) + call malloc (iyl, npts, TY_DOUBLE) + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, x1, x2, + y1, y2) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, x1, x2, + y1, y2) + if (wcs == RG_WORLD) + ctr = rg_xytoxy (mwr, Memd[rxl], Memd[ryl], Memd[rxw], + Memd[ryw], npts, "logical", "world", 1, 2) + else + ctr = rg_xytoxy (mwr, Memd[rxl], Memd[ryl], Memd[rxw], + Memd[ryw], npts, "logical", "physical", 1, 2) + + } + } + + # Open the input image. + im = immap (Memc[image], READ_ONLY, 0) + if (IM_NDIM(im) > 2) + call error (0, "The input image must be 1D or 2D") + if (IM_NDIM(im) != IM_NDIM(imr)) + call error (0, + "The input image must have same dimensionality as reference image") + + # Open the input wcs. + stat = sk_decim (im, "logical", mw, coo) + if (mw != NULL) { + if (mw_stati(mw, MW_NPHYSDIM) < IM_NDIM(im) || + mw_stati (mw, MW_NDIM) != IM_NDIM(im)) { + call mw_close (mw) + mw = NULL + } + } + + # Open the output file. + if (fntgfnb (olist, Memc[str], SZ_FNAME) != EOF) + ofd = open (Memc[str], NEW_FILE, TEXT_FILE) + + # Print information about the reference and input coordinate + # systems and the reference and input files to the output + # file + if (ofd == STDOUT) + call fseti (ofd, F_FLUSHNL, YES) + if (streq (Memc[str], "STDOUT") || ofd == STDOUT) + call fseti (ofd, F_FLUSHNL, YES) + call fprintf (ofd, "\n") + call fprintf (ofd, + "# Reference image: %s Input image: %s\n# Coords: %s") + call pargstr (Memc[refimage]) + call pargstr (Memc[image]) + if (clist == NULL) { + call pargstr ("grid") + call fprintf (ofd, " Wcs: logical\n") + } else { + call fstats (cfd, F_FILENAME, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call fprintf (ofd, " Wcs: %s\n") + switch (wcs) { + case RG_PHYSICAL: + call pargstr ("physical") + case RG_WORLD: + call pargstr ("world") + default: + call pargstr ("world") + } + } + if (rstat == ERR) + call fprintf (ofd, + "# Error decoding the reference coordinate system\n") + call sk_iiwrite (ofd, "Refsystem", Memc[refimage], mwr, coor) + if (stat == ERR) + call fprintf (ofd, + "# Error decoding the input coordinate system\n") + call sk_iiwrite (ofd, "Insystem", Memc[image], mw, coo) + + # Print information about the reference and input coordinate + # systems and the reference and input files to the standard + # output. + if (verbose && ofd != STDOUT) { + call printf ("\n") + call printf ( + "Reference image: %s Input image: %s\n Coords: %s") + call pargstr (Memc[refimage]) + call pargstr (Memc[image]) + if (clist == NULL) { + call pargstr ("grid") + call printf (" Wcs: logical\n") + } else { + call fstats (cfd, F_FILENAME, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call printf (" Wcs: %s\n") + switch (wcs) { + case RG_PHYSICAL: + call pargstr ("physical") + case RG_WORLD: + call pargstr ("world") + default: + call pargstr ("world") + } + } + if (rstat == ERR) + call printf ( + "Error decoding the rference coordinate system\n") + call sk_iiprint ("Refsystem", Memc[refimage], mwr, coor) + if (stat == ERR) + call printf ( + "Error decoding the input coordinate system\n") + call sk_iiprint ("Insystem", Memc[image], mw, coo) + call printf ("\n") + } + + # Set the reference and input coordinate formats. + if (Memc[rxformat] == EOS) + call rg_ssetfmt (mwr, wcs, sk_stati(coor, S_XLAX), + min_sigdigits, Memc[rwxformat], SZ_FNAME) + else + call strcpy (Memc[rxformat], Memc[rwxformat], SZ_FNAME) + + if (Memc[txformat] == EOS) + call rg_ssetfmt (mw, wcs, sk_stati(coo, S_XLAX), + min_sigdigits, Memc[twxformat], SZ_FNAME) + else + call strcpy (Memc[txformat], Memc[twxformat], SZ_FNAME) + if (Memc[ryformat] == EOS) + call rg_ssetfmt (mwr, wcs, sk_stati(coor, S_YLAX), + min_sigdigits, Memc[rwyformat], SZ_FNAME) + else + call strcpy (Memc[ryformat], Memc[rwyformat], SZ_FNAME) + if (Memc[tyformat] == EOS) + call rg_ssetfmt (mw, wcs, sk_stati(coo, S_YLAX), + min_sigdigits, Memc[twyformat], SZ_FNAME) + else + call strcpy (Memc[tyformat], Memc[twyformat], SZ_FNAME) + + + # Compute the output coordinates issuing a warning if the + # axes types are not compatable. + if (mwr == NULL || rstat == ERR) { + call fprintf (ofd, + "# \tWarning: error decoding reference image wcs\n") + if (verbose && ofd != STDOUT) + call printf ( + "\tWarning: error decoding reference image wcs\n") + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + if (clist == NULL) { + call amovd (Memd[rxl], Memd[rxw], npts) + call amovd (Memd[ryl], Memd[ryw], npts) + call amovd (Memd[rxl], Memd[trxw], npts) + call amovd (Memd[ryl], Memd[tryw], npts) + } + ct = NULL + } else if (ctr == NULL) { + call fprintf (ofd, "# \tWarning: Unable to compute reference \ +logical <-> world transform\n") + if (verbose && ofd != STDOUT) + call printf ("\tWarning: Unable to compute reference \ +logical <-> world transform\n") + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + if (clist == NULL) { + call amovd (Memd[rxl], Memd[rxw], npts) + call amovd (Memd[ryl], Memd[ryw], npts) + call amovd (Memd[rxl], Memd[trxw], npts) + call amovd (Memd[ryl], Memd[tryw], npts) + } + ct = NULL + } else if (mw == NULL || stat == ERR) { + call fprintf (ofd, + "# \tWarning: error decoding input image wcs\n") + if (verbose && ofd != STDOUT) + call printf ("\tWarning: error decoding input image wcs\n") + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + call amovd (Memd[rxw], Memd[trxw], npts) + call amovd (Memd[ryw], Memd[tryw], npts) + ct = NULL + } else { + # Check axis status. + if (wcs == RG_PHYSICAL) { + ct = rg_xytoxy (mw, Memd[rxw], Memd[ryw], Memd[ixl], + Memd[iyl], npts, "physical", "logical", 1, 2) + call amovd (Memd[rxw], Memd[trxw], npts) + call amovd (Memd[ryw], Memd[tryw], npts) + if (ct == NULL) { + call fprintf (ofd, + "# \tWarning: Unable to compute image physical -> \ +logical transform\n") + if (verbose && ofd != STDOUT) + call printf ( + "\tWarning: Unable to compute image physical \ +-> logical transform\n") + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, + double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + } + } else { + call rg_lltransform (coor, coo, Memd[rxw], Memd[ryw], + Memd[trxw], Memd[tryw], npts) + if ((sk_stati (coor, S_PLNGAX) < sk_stati(coor, + S_PLATAX)) && (sk_stati (coo,S_PLNGAX) < + sk_stati(coo, S_PLATAX))) + ct = rg_xytoxy (mw, Memd[trxw], Memd[tryw], Memd[ixl], + Memd[iyl], npts, "world", "logical", 1, 2) + else if ((sk_stati (coor, S_PLNGAX) > sk_stati(coor, + S_PLATAX)) && (sk_stati (coo,S_PLNGAX) > + sk_stati(coo, S_PLATAX))) + ct = rg_xytoxy (mw, Memd[trxw], Memd[tryw], Memd[ixl], + Memd[iyl], npts, "world", "logical", 1, 2) + else + ct = rg_xytoxy (mw, Memd[tryw], Memd[trxw], Memd[ixl], + Memd[iyl], npts, "world", "logical", 1, 2) + if (ct == NULL) { + call fprintf (ofd, + "# \tWarning: Unable to compute image world -> \ +logical transform\n") + if (verbose && ofd != STDOUT) + call printf ( + "\tWarning: Unable to compute image world -> \ +logical transform\n") + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, + double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + } + } + } + + # Write out the results. + if ((sk_stati (coor, S_PLNGAX) < sk_stati(coor, S_PLATAX)) && + (sk_stati (coo,S_PLNGAX) < sk_stati(coo, S_PLATAX))) + call rg_swcoords (ofd, Memd[rxl], Memd[ryl], Memd[ixl], + Memd[iyl], Memd[rxw], Memd[ryw], Memd[trxw], Memd[tryw], + npts, Memc[xformat], Memc[yformat], Memc[rwxformat], + Memc[rwyformat], Memc[twxformat], Memc[twyformat]) + else if ((sk_stati (coor, S_PLNGAX) > sk_stati(coor, + S_PLATAX)) && (sk_stati (coo,S_PLNGAX) > sk_stati(coo, + S_PLATAX))) + call rg_swcoords (ofd, Memd[rxl], Memd[ryl], Memd[ixl], + Memd[iyl], Memd[rxw], Memd[ryw], Memd[trxw], Memd[tryw], + npts, Memc[xformat], Memc[yformat], Memc[rwxformat], + Memc[rwyformat], Memc[twxformat], Memc[twyformat]) + else + call rg_swcoords (ofd, Memd[rxl], Memd[ryl], Memd[ixl], + Memd[iyl], Memd[rxw], Memd[ryw], Memd[tryw], Memd[trxw], + npts, Memc[xformat], Memc[yformat], Memc[rwxformat], + Memc[rwyformat], Memc[twxformat], Memc[twyformat]) + + # Close the input image and its wcs. + if (mw != NULL) + call mw_close (mw) + if (coo != NULL) + #call mfree (coo, TY_STRUCT) + call sk_close (coo) + call imunmap (im) + + # Close the output coordinate file if it is not going to + # be appended to. + if (fntlenb(olist) == imtlen(ilist)) + call close (ofd) + } + + if (imr != NULL) { + call mfree (rxl, TY_DOUBLE) + call mfree (ryl, TY_DOUBLE) + call mfree (rxw, TY_DOUBLE) + call mfree (ryw, TY_DOUBLE) + call mfree (trxw, TY_DOUBLE) + call mfree (tryw, TY_DOUBLE) + call mfree (ixl, TY_DOUBLE) + call mfree (iyl, TY_DOUBLE) + if (mwr != NULL) + call mw_close (mwr) + if (coor != NULL) + #call mfree (coor, TY_STRUCT) + call sk_close (coor) + call imunmap (imr) + } + if (cfd != NULL) + call close (cfd) + if (fntlenb(olist) < imtlen(ilist)) + call close (ofd) + if (ilist != NULL) + call imtclose (ilist) + if (rlist != NULL) + call imtclose (rlist) + if (olist != NULL) + call fntclsb (olist) + if (clist != NULL) + call fntclsb (clist) + + call sfree (sp) +end + + +# RG_SSETFMT -- Procedure to set the appropriate default format. + +procedure rg_ssetfmt (mw, wcs, laxno, min_sigdigits, wformat, maxch) + +pointer mw #I pointer to the image wcs +int wcs #I the input wcs type +int laxno #I the physical axis number +int min_sigdigits #I the minmum number of significant digits +char wformat[ARB] #O the output format string +int maxch #I the maximum size of the output format string + +pointer sp, str +bool streq() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + if (mw == NULL) { + call sprintf (wformat, maxch, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } else if (wcs == RG_PHYSICAL) { + call strcpy ("%10.3f", wformat, maxch) + } else { + iferr { + call mw_gwattrs (mw, laxno, "format", wformat, maxch) + } then { + iferr { + call mw_gwattrs (mw, laxno, "axtype", Memc[str], SZ_FNAME) + } then { + call sprintf (wformat, maxch, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } else { + if (streq (Memc[str], "ra")) + call strcpy ("%12.2H", wformat, maxch) + else if (streq (Memc[str], "dec")) + call strcpy ("%11.1h", wformat, maxch) + else if (streq (Memc[str+1], "lon")) + call strcpy ("%11.1h", wformat, maxch) + else if (streq (Memc[str+1], "lat")) + call strcpy ("%11.1h", wformat, maxch) + else { + call sprintf (wformat, maxch, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } + } + } + } + + call sfree (sp) +end + + +# RG_SWCOORDS -- Write out the reference and input logical coordinates of the +# tie points and the reference world coordinates. + +procedure rg_swcoords (ofd, xref, yref, xin, yin, wxref, wyref, twxref, twyref, + npts, xformat, yformat, wxformat, wyformat, twxformat, twyformat) + +int ofd #I the output file descriptor +double xref[ARB] #I the reference logical x coordinates +double yref[ARB] #I the reference logical y coordinates +double xin[ARB] #I the input logical x coordinates +double yin[ARB] #I the input logical y coordinates +double wxref[ARB] #I the reference world x coordinates +double wyref[ARB] #I the reference world y coordinates +double twxref[ARB] #I the input world x coordinates +double twyref[ARB] #I the input world y coordinates +int npts #I the number of input points +char xformat[ARB] #I the logical x coordinates format +char yformat[ARB] #I the logical y coordinates format +char wxformat[ARB] #I the reference world x coordinates format +char wyformat[ARB] #I the reference world y coordinates format +char twxformat[ARB] #I the input world x coordinates format +char twyformat[ARB] #I the input world y coordinates format + +int i +pointer sp, fmtstr + +begin + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + + # Write the column descriptions. + call fprintf (ofd, + "# \tColumn 1: reference logical x coordinate\n") + call fprintf (ofd, + "# \tColumn 2: reference logical y coordinate\n") + call fprintf (ofd, + "# \tColumn 3: input logical x coordinate\n") + call fprintf (ofd, + "# \tColumn 4: input logical y coordinate\n") + call fprintf (ofd, + "# \tColumn 5: reference world x coordinate\n") + call fprintf (ofd, + "# \tColumn 6: reference world y coordinate\n") + call fprintf (ofd, + "# \tColumn 7: input world x coordinate\n") + call fprintf (ofd, + "# \tColumn 8: input world y coordinate\n") + call fprintf (ofd, "\n") + + call sprintf (Memc[fmtstr], SZ_LINE, + "%s %s %s %s %s %s %s %s\n") + call pargstr (xformat) + call pargstr (yformat) + call pargstr (xformat) + call pargstr (yformat) + call pargstr (wxformat) + call pargstr (wyformat) + call pargstr (twxformat) + call pargstr (twyformat) + + do i = 1, npts { + call fprintf (ofd, Memc[fmtstr]) + call pargd (xref[i]) + call pargd (yref[i]) + call pargd (xin[i]) + call pargd (yin[i]) + call pargd (wxref[i]) + call pargd (wyref[i]) + call pargd (twxref[i]) + call pargd (twyref[i]) + } + + call sfree (sp) +end + diff --git a/pkg/images/immatch/src/wcsmatch/t_wcscopy.x b/pkg/images/immatch/src/wcsmatch/t_wcscopy.x new file mode 100644 index 00000000..6d15e5c8 --- /dev/null +++ b/pkg/images/immatch/src/wcsmatch/t_wcscopy.x @@ -0,0 +1,199 @@ +include <imhdr.h> +include <mwset.h> + +# T_WCSCOPY -- Copy the world coordinate system of a reference image to +# the world coordinate system of an input image. + +procedure t_wcscopy() + +bool verbose +int ilist, rlist +pointer sp, image, refimage, value, str, imr, mwr, im +real rval +double dval +bool clgetb() +int imtopen(), imtlen(), imtgetim() +#int mw_stati(), rg_samesize() +pointer immap(), mw_openim() +real imgetr() +double imgetd() +errchk mw_openim(), imgstr(), imgetr(), imgetd(), imdelf() + +begin + # Get some temporary working space. + call smark (sp) + call salloc (refimage, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the input image and reference image lists. + call clgstr ("images", Memc[str], SZ_FNAME) + ilist = imtopen (Memc[str]) + call clgstr ("refimages", Memc[str], SZ_FNAME) + rlist = imtopen (Memc[str]) + verbose = clgetb ("verbose") + + # Check the reference image list length. + if (imtlen (rlist) <= 0) + call error (0, "The reference image list is empty.") + if (imtlen(rlist) > 1 && imtlen(rlist) != imtlen(ilist)) + call error (0, + "The number of reference and input images is not the same.") + + # Initialize the reference image and coordinate list pointers. + imr = NULL + + # Loop over the input images. + while (imtgetim (ilist, Memc[image], SZ_FNAME) != EOF) { + + # Open the reference image and reference coordinate file and + # compute the logical and world reference coordinates. + if (imtgetim (rlist, Memc[refimage], SZ_FNAME) != EOF) { + + # Open the reference image. + if (imr != NULL) { + if (mwr != NULL) + call mw_close (mwr) + call imunmap (imr) + } + imr = immap (Memc[refimage], READ_ONLY, 0) + + # Open the reference image wcs. + iferr (mwr = mw_openim (imr)) + mwr = NULL + + # Check that the wcs dimensions are rational. +# if (mwr != NULL) { +# if (mw_stati(mwr, MW_NPHYSDIM) < IM_NDIM(imr)) { +# call mw_close (mwr) +# mwr = NULL +# } +# } + } + + # Print message about progress of task + if (verbose) { + call printf ("Copying wcs from image %s to image %s\n") + call pargstr (Memc[refimage]) + call pargstr (Memc[image]) + } + + # Remove any image section and open the input image. + call imgimage (Memc[image], Memc[image], SZ_FNAME) + iferr (im = immap (Memc[image], READ_WRITE, 0)) { + im = immap (Memc[image], NEW_IMAGE, 0) + IM_NDIM(im) = 0 + } + + # Test for valid wcs. + if (mwr == NULL) { + if (verbose) { + call printf ( + "\tError: cannot read wcs for reference image %s\n") + call pargstr (Memc[refimage]) + } +# } else if (IM_NDIM(im) != IM_NDIM(imr)) { +# if (verbose) { +# call printf ( +# "\tError: %s and %s have different number of dimensions\n") +# call pargstr (Memc[image]) +# call pargstr (Memc[refimage]) +# } + } else { +# if (rg_samesize (imr, im) == NO) { +# if (verbose) { +# call printf ( +# "\tWarning: images %s and %s have different sizes\n") +# call pargstr (Memc[image]) +# call pargstr (Memc[refimage]) +# } +# } + #mw = mw_open (NULL, mw_stati (mwr,MW_NPHYSDIM)) + #call mw_loadim (mw, imr) + #call mw_saveim (mw, im) + #call mw_close (mw) + call mw_saveim (mwr, im) + + # Copy the RADECSYS keyword to the input image header. + ifnoerr { + call imgstr (imr, "RADECSYS", Memc[value], SZ_FNAME) + } then { + call imastr (im, "RADECSYS", Memc[value]) + } else { + iferr (call imdelf (im, "RADECSYS")) + ; + } + + # Copy the EQUINOX or EPOCH keyword to the input image header + # EQUINOX keyword. + ifnoerr { + rval = imgetr (imr, "EQUINOX") + } then { + call imaddr (im, "EQUINOX", rval) + iferr (call imdelf (im, "EPOCH")) + ; + } else { + ifnoerr { + rval = imgetr (imr, "EPOCH") + } then { + call imaddr (im, "EQUINOX", rval) + iferr (call imdelf (im, "EPOCH")) + ; + } else { + iferr (call imdelf (im, "EQUINOX")) + ; + iferr (call imdelf (im, "EPOCH")) + ; + } + } + + # Copy the MJD-WCSkeyword to the input image header. + ifnoerr { + dval = imgetd (imr, "MJD-WCS") + } then { + call imaddd (im, "MJD-WCS", dval) + } else { + iferr (call imdelf (im, "MJD-WCS")) + ; + } + } + + # Close the input image. + call imunmap (im) + + } + + if (imr != NULL) { + if (mwr != NULL) + call mw_close (mwr) + call imunmap (imr) + } + + if (ilist != NULL) + call imtclose (ilist) + if (rlist != NULL) + call imtclose (rlist) + + call sfree (sp) +end + + +# RG_SAMESIZE -- Determine whether two images of the same dimension are +# the same size. + +int procedure rg_samesize (im1, im2) + +pointer im1 #I the first image descriptor +pointer im2 #I the second image descriptor + +int i, stat + +begin + stat = YES + do i = 1, IM_NDIM(im1) { + if (IM_LEN(im1,i) != IM_LEN(im2,i)) + return (NO) + } + return (stat) +end diff --git a/pkg/images/immatch/src/wcsmatch/t_wcsxymatch.x b/pkg/images/immatch/src/wcsmatch/t_wcsxymatch.x new file mode 100644 index 00000000..503bc7f3 --- /dev/null +++ b/pkg/images/immatch/src/wcsmatch/t_wcsxymatch.x @@ -0,0 +1,787 @@ +include <fset.h> +include <imhdr.h> +include <mwset.h> +include "wcsxymatch.h" + +# T_WCSXYMATCH -- Compute a list of the tie points required to register an +# image to a reference image using WCS information in the image headers. + +procedure t_wcsxymatch() + +bool verbose, transpose +double xmin, xmax, ymin, ymax, x1, x2, y1, y2 +int ilist, rlist, olist, clist, cfd, ofd +int nx, ny, npts, wcs, xcolumn, ycolumn +int xunits, yunits, min_sigdigits, axstat, projstat +pointer sp, refimage, image, xformat, yformat, rxformat, ryformat +pointer wxformat, wyformat, str, paxno, rlaxno, laxno +pointer im, imr, mw, mwr, rxl, ryl, rxw, ryw, ixl, iyl, ctr, ct + +bool clgetb(), streq() +double clgetd() +int imtopen(), fntopnb(), imtlen(), fntlenb(), imtgetim(), open(), clgeti() +int clgwrd(), rg_rdxy(), fntgfnb(), rg_axstat(), rg_projstat(), mw_stati() +int strdic() +pointer immap(), mw_openim(), rg_xytoxy() +errchk mw_openim(), mw_gwattrs() + +begin + # Get some temporary working space. + call smark (sp) + call salloc (refimage, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (xformat, SZ_FNAME, TY_CHAR) + call salloc (yformat, SZ_FNAME, TY_CHAR) + call salloc (wxformat, SZ_FNAME, TY_CHAR) + call salloc (wyformat, SZ_FNAME, TY_CHAR) + call salloc (rxformat, SZ_FNAME, TY_CHAR) + call salloc (ryformat, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + call salloc (paxno, IM_MAXDIM, TY_INT) + call salloc (rlaxno, IM_MAXDIM, TY_INT) + call salloc (laxno, IM_MAXDIM, TY_INT) + + # Get the input image and output file lists. + call clgstr ("input", Memc[str], SZ_FNAME) + ilist = imtopen (Memc[str]) + call clgstr ("reference", Memc[str], SZ_FNAME) + rlist = imtopen (Memc[str]) + call clgstr ("output", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) + call strcpy ("STDOUT", Memc[str], SZ_FNAME) + olist = fntopnb (Memc[str], NO) + + # Determine the source of the input coordinates. + call clgstr ("coords", Memc[str], SZ_FNAME) + if (streq (Memc[str], "grid")) { + clist = NULL + xmin = clgetd ("xmin") + xmax = clgetd ("xmax") + ymin = clgetd ("ymin") + ymax = clgetd ("ymax") + nx = clgeti ("nx") + ny = clgeti ("ny") + wcs = clgwrd ("wcs", Memc[str], SZ_FNAME, RG_WCSLIST) + } else { + clist = fntopnb (Memc[str], NO) + xmin = INDEFD + xmax = INDEFD + ymin = INDEFD + ymax = INDEFD + nx = clgeti ("nx") + ny = clgeti ("ny") + wcs = clgwrd ("wcs", Memc[str], SZ_FNAME, RG_WCSLIST) + xcolumn = clgeti ("xcolumn") + ycolumn = clgeti ("ycolumn") + call clgstr ("xunits", Memc[str], SZ_FNAME) + xunits = strdic (Memc[str], Memc[str], SZ_FNAME, RG_UNITLIST) + if (xunits <= 0) + xunits = RG_UNATIVE + call clgstr ("yunits", Memc[str], SZ_FNAME) + yunits = strdic (Memc[str], Memc[str], SZ_FNAME, RG_UNITLIST) + if (yunits <= 0) + yunits = RG_UNATIVE + } + transpose = clgetb ("transpose") + + # Get the output coordinate formatting information. + call clgstr ("xformat", Memc[xformat], SZ_FNAME) + call clgstr ("yformat", Memc[yformat], SZ_FNAME) + call clgstr ("wxformat", Memc[rxformat], SZ_FNAME) + call clgstr ("wyformat", Memc[ryformat], SZ_FNAME) + min_sigdigits = clgeti ("min_sigdigits") + + # Get remaining parameters. + verbose = clgetb ("verbose") + + # Check the formatting of the reference and input logical coordinates. + if (Memc[xformat] == EOS) { + call sprintf (Memc[xformat], SZ_FNAME, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } + if (Memc[yformat] == EOS) { + call sprintf (Memc[yformat], SZ_FNAME, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } + + # Check the reference image list length. + if (imtlen (rlist) <= 0) + call error (0, "The reference image list is empty.") + if (imtlen(rlist) > 1 && imtlen(rlist) != imtlen(ilist)) + call error (0, + "The number of reference and input images is not the same.") + + # Check the output coordinate file length. + if (fntlenb(olist) > 1 && fntlenb(olist) != imtlen(ilist)) + call error (0, + "The number of output coords files and input images is not the same.") + + # Check the reference coordinate list length. + if (clist != NULL) { + if (fntlenb (clist) != imtlen (rlist)) + call error (0, + "The number of reference coords files and images are not the same") + } + + # Initialize the reference image and coordinate list pointers. + imr = NULL + cfd = NULL + + # Loop over the input images. + while (imtgetim (ilist, Memc[image], SZ_FNAME) != EOF) { + + # Open the output file. + if (fntgfnb (olist, Memc[str], SZ_FNAME) != EOF) { + ofd = open (Memc[str], NEW_FILE, TEXT_FILE) + if (ofd == STDOUT) + call fseti (ofd, F_FLUSHNL, YES) + else if (fntlenb (olist) != imtlen (ilist)) + call error (0, + "The number of output coords files and input images is not the same.") + } + + # Open the reference image and reference coordinate file and + # compute the logical and world reference coordinates. + if (imtgetim (rlist, Memc[refimage], SZ_FNAME) != EOF) { + + # Open the reference image. + if (imr != NULL) { + call mfree (rxl, TY_DOUBLE) + call mfree (ryl, TY_DOUBLE) + call mfree (rxw, TY_DOUBLE) + call mfree (ryw, TY_DOUBLE) + call mfree (ixl, TY_DOUBLE) + call mfree (iyl, TY_DOUBLE) + if (mwr != NULL) + call mw_close (mwr) + call imunmap (imr) + } + imr = immap (Memc[refimage], READ_ONLY, 0) + if (IM_NDIM(imr) > 2) + call error (0, "The reference image must be 1D or 2D") + + # Open the reference image wcs. + iferr (mwr = mw_openim (imr)) + mwr = NULL + + # Check that the wcs dimensions are rational. + if (mwr != NULL) { + if (mw_stati(mwr, MW_NPHYSDIM) < IM_NDIM(imr) || + mw_stati (mwr, MW_NDIM) != IM_NDIM(imr)) { + call mw_close (mwr) + mwr = NULL + } + } + + # Get the reference image physical and logical axis maps. + if (mwr != NULL) { + call mw_gaxmap (mwr, Memi[paxno], Memi[rlaxno], + mw_stati(mwr, MW_NPHYSDIM)) + call rg_laxmap (Memi[paxno], mw_stati(mwr, MW_NPHYSDIM), + Memi[rlaxno], mw_stati(mwr, MW_NDIM)) + } else { + Memi[rlaxno] = 1 + Memi[rlaxno+1] = 2 + } + + # Compute the x limits of the logical reference coordinates. + if (IS_INDEFD(xmin)) + x1 = 1.0d0 + else + x1 = max (1.0d0, min (xmin, double(IM_LEN(imr,1)))) + if (IS_INDEFD(xmax)) + x2 = double(IM_LEN(imr,1)) + else + x2 = max (1.0d0, min (xmax, double(IM_LEN(imr,1)))) + + # Compute the y limits of the logical reference coordinates. + if (IM_NDIM(imr) == 1) + y1 = 1.0d0 + else if (IS_INDEFD(ymin)) + y1 = 1.0d0 + else + y1 = max (1.0d0, min (ymin, double(IM_LEN(imr,2)))) + if (IM_NDIM(imr) == 1) + y2 = 1.0d0 + else if (IS_INDEFD(ymax)) + y2 = double(IM_LEN(imr,2)) + else + y2 = max (1.0d0, min (ymax, double(IM_LEN(imr,2)))) + + # Compute the reference logical and world coordinates. + if (clist != NULL) { + + if (cfd != NULL) + call close (cfd) + + if (fntgfnb (clist, Memc[str], SZ_FNAME) != EOF) { + cfd = open (Memc[str], READ_ONLY, TEXT_FILE) + npts = rg_rdxy (cfd, rxw, ryw, wcs, xcolumn, ycolumn, + xunits, yunits) + call malloc (rxl, npts, TY_DOUBLE) + call malloc (ryl, npts, TY_DOUBLE) + call malloc (ixl, npts, TY_DOUBLE) + call malloc (iyl, npts, TY_DOUBLE) + if (wcs == RG_WORLD) + ctr = rg_xytoxy (mwr, Memd[rxw], Memd[ryw], + Memd[rxl], Memd[ryl], npts, "world", + "logical", 1, 2) + else + ctr = rg_xytoxy (mwr, Memd[rxw], Memd[ryw], + Memd[rxl], Memd[ryl], npts, "physical", + "logical", 1, 2) + } + + } else { + + if (IM_NDIM(imr) == 1) + npts = nx + else + npts = nx * ny + call malloc (rxl, npts, TY_DOUBLE) + call malloc (ryl, npts, TY_DOUBLE) + call malloc (rxw, npts, TY_DOUBLE) + call malloc (ryw, npts, TY_DOUBLE) + call malloc (ixl, npts, TY_DOUBLE) + call malloc (iyl, npts, TY_DOUBLE) + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, x1, x2, + y1, y2) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, x1, x2, + y1, y2) + if (wcs == RG_WORLD) + ctr = rg_xytoxy (mwr, Memd[rxl], Memd[ryl], Memd[rxw], + Memd[ryw], npts, "logical", "world", 1, 2) + else + ctr = rg_xytoxy (mwr, Memd[rxl], Memd[ryl], Memd[rxw], + Memd[ryw], npts, "logical", "physical", 1, 2) + + } + } + + # Open the input image. + im = immap (Memc[image], READ_ONLY, 0) + if (IM_NDIM(im) > 2) + call error (0, "The input image must be 1D or 2D") + if (IM_NDIM(im) != IM_NDIM(imr)) + call error (0, + "The input image must have same dimensionality as reference image") + + # Open the input wcs. + iferr (mw = mw_openim (im)) + mw = NULL + if (mw != NULL) { + if (mw_stati(mw, MW_NPHYSDIM) < IM_NDIM(im) || + mw_stati (mw, MW_NDIM) != IM_NDIM(im)) { + call mw_close (mw) + mw = NULL + } + } + + # Get the input image wcs physical and logical axis maps. + if (mw != NULL) { + call mw_gaxmap (mw, Memi[paxno], Memi[laxno], mw_stati(mw, + MW_NPHYSDIM)) + call rg_laxmap (Memi[paxno], mw_stati(mw, MW_NPHYSDIM), + Memi[laxno], mw_stati(mw, MW_NDIM)) + } else { + Memi[laxno] = 1 + Memi[laxno+1] = 2 + } + + # Write the banner string. + call fprintf (ofd, + "\n# Reference image: %s Input image: %s\n# \tCoords: %s") + call pargstr (Memc[refimage]) + call pargstr (Memc[image]) + if (clist == NULL) { + call pargstr ("grid") + call fprintf (ofd, "\n") + } else { + call fstats (cfd, F_FILENAME, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call fprintf (ofd, " Wcs: %s\n") + switch (wcs) { + case RG_PHYSICAL: + call pargstr ("physical") + case RG_WORLD: + call pargstr ("world") + default: + call pargstr ("world") + } + } + + # Printe message on the terminal. + if (verbose && ofd != STDOUT) { + call printf ( + "\nReference image: %s Input image: %s\n\tCoords: %s") + call pargstr (Memc[refimage]) + call pargstr (Memc[image]) + if (clist == NULL) { + call pargstr ("grid") + call printf ("\n") + } else { + call fstats (cfd, F_FILENAME, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call printf (" Wcs: %s\n") + switch (wcs) { + case RG_PHYSICAL: + call pargstr ("physical") + case RG_WORLD: + call pargstr ("world") + default: + call pargstr ("world") + } + } + } + + # Set the reference coordinate formats. + if (Memc[rxformat] == EOS) + call rg_wsetfmt (mwr, mw, wcs, Memi[rlaxno], Memi[laxno], + min_sigdigits, Memc[wxformat], SZ_FNAME) + else + call strcpy (Memc[rxformat], Memc[wxformat], SZ_FNAME) + + if (Memc[ryformat] == EOS) + call rg_wsetfmt (mwr, mw, wcs, Memi[rlaxno+1], Memi[laxno+1], + min_sigdigits, Memc[wyformat], SZ_FNAME) + else + call strcpy (Memc[ryformat], Memc[wyformat], SZ_FNAME) + + # Compute the output coordinates issuing a warning if the + # axes types are not compatable. + if (mwr == NULL) { + call fprintf (ofd, + "# \tWarning: reference image wcs is undefined\n") + if (verbose && ofd != STDOUT) + call printf ( + "\tWarning: reference image wcs is undefined\n") + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + if (clist == NULL) { + call amovd (Memd[rxl], Memd[rxw], npts) + call amovd (Memd[ryl], Memd[ryw], npts) + } + ct = NULL + } else if (ctr == NULL) { + call fprintf (ofd, "# \tWarning: Unable to compute reference \ +logical <-> world transform\n") + if (verbose && ofd != STDOUT) { + call printf ("\tWarning: Unable to compute reference \ +logical <-> world transform\n") + } + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + if (clist == NULL) { + call amovd (Memd[rxl], Memd[rxw], npts) + call amovd (Memd[ryl], Memd[ryw], npts) + } + ct = NULL + } else if (mw == NULL) { + call fprintf (ofd, + "# \tWarning: input image wcs is undefined\n") + if (verbose && ofd != STDOUT) + call printf ("\tWarning: input image wcs is undefined\n") + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + ct = NULL + } else { + # Check axis status. + if (wcs == RG_PHYSICAL) { + axstat = RG_AXEQUAL + projstat = RG_AXEQUAL + ct = rg_xytoxy (mw, Memd[rxw], Memd[ryw], Memd[ixl], + Memd[iyl], npts, "physical", "logical", 1, 2) + if (ct == NULL) { + call fprintf (ofd, + "# \tWarning: Unable to compute image physical -> \ +logical transform\n") + if (verbose && ofd != STDOUT) { + call printf ( + "\tWarning: Unable to compute image physical \ +-> logical transform\n") + } + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, + double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + } + } else { + axstat = rg_axstat (mwr, Memi[rlaxno], Memi[rlaxno+1], + mw, Memi[laxno], Memi[laxno+1], transpose) + projstat = rg_projstat (mwr, Memi[rlaxno], Memi[rlaxno+1], + mw, Memi[laxno], Memi[laxno+1]) + switch (axstat) { + case RG_AXEQUAL, RG_AXNOTEQUAL: + ct = rg_xytoxy (mw, Memd[rxw], Memd[ryw], Memd[ixl], + Memd[iyl], npts, "world", "logical", 1, 2) + case RG_AXSWITCHED: + ct = rg_xytoxy (mw, Memd[ryw], Memd[rxw], Memd[ixl], + Memd[iyl], npts, "world", "logical", 1, 2) + } + if (ct == NULL) { + call fprintf (ofd, + "# \tWarning: Unable to compute image \ + world -> logical transform\n") + if (verbose && ofd != STDOUT) { + call printf ( + "\tWarning: Unable to compute image world -> \ +logical transform\n") + } + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, + double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + } else if (axstat == RG_AXNOTEQUAL) { + call fprintf (ofd, + "# \tWarning: Reference and image axtype \ +attributes are different\n") + if (verbose && ofd != STDOUT) { + call printf ( + "\tWarning: Reference and image axtype \ +attributes are different\n") + } + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, + double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + } else if (projstat == RG_AXNOTEQUAL) { + call fprintf (ofd, + "# \tWarning: Reference and image wtype \ +attributes are different\n") + if (verbose && ofd != STDOUT) { + call printf ( + "\tWarning: Reference and image wtype \ +attributes are different\n") + } + } + } + } + + # Write out the results. + call rg_wcoords (ofd, Memd[rxl], Memd[ryl], Memd[ixl], + Memd[iyl], Memd[rxw], Memd[ryw], npts, Memc[xformat], + Memc[yformat], Memc[wxformat], Memc[wyformat]) + + # Close the input image and its wcs. + if (mw != NULL) + call mw_close (mw) + call imunmap (im) + + # Close the output coordinate file if it is not going to + # be appended to. + if (fntlenb(olist) == imtlen(ilist)) + call close (ofd) + } + + if (imr != NULL) { + call mfree (rxl, TY_DOUBLE) + call mfree (ryl, TY_DOUBLE) + call mfree (rxw, TY_DOUBLE) + call mfree (ryw, TY_DOUBLE) + call mfree (ixl, TY_DOUBLE) + call mfree (iyl, TY_DOUBLE) + if (mwr != NULL) + call mw_close (mwr) + call imunmap (imr) + } + if (cfd != NULL) + call close (cfd) + if (fntlenb(olist) < imtlen(ilist)) + call close (ofd) + if (ilist != NULL) + call imtclose (ilist) + if (rlist != NULL) + call imtclose (rlist) + if (olist != NULL) + call fntclsb (olist) + if (clist != NULL) + call fntclsb (clist) + + call sfree (sp) +end + + +# RG_WSETFMT -- Set the world coordinate format. + +procedure rg_wsetfmt (mwr, mw, wcs, rlaxno, laxno, min_sigdigits, + wformat, maxch) + +pointer mwr #I pointer to the reference image wcs +pointer mw #I pointer to the input image wcs +int wcs #I the input wcs type +int rlaxno #I the reference physical axis number +int laxno #I the input physical axis number +int min_sigdigits #I the minimum number of significant digits +char wformat[ARB] #O the output world coordinate format +int maxch #I the maximum size of the format string + +pointer sp, str +bool streq() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + if (mwr == NULL || mw == NULL) { + call sprintf (wformat, maxch, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + + } else if (wcs == RG_PHYSICAL) { + call strcpy ("%10.3f", wformat, maxch) + + } else { + iferr { + call mw_gwattrs (mwr, rlaxno, "format", wformat, maxch) + } then { + iferr { + call mw_gwattrs (mw, laxno, "format", wformat, maxch) + } then { + iferr { + call mw_gwattrs (mwr, rlaxno, "axtype", Memc[str], + SZ_FNAME) + } then { + call sprintf (wformat, maxch, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } else { + if (streq (Memc[str], "ra")) + call strcpy ("%11.1H", wformat, maxch) + else if (streq (Memc[str], "dec")) + call strcpy ("%11.1h", wformat, maxch) + else if (streq (Memc[str+1], "lon")) + call strcpy ("%11.1h", wformat, maxch) + else if (streq (Memc[str+1], "lat")) + call strcpy ("%11.1h", wformat, maxch) + else { + call sprintf (wformat, maxch, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } + } + } + } + } + + call sfree (sp) +end + + +# RG_AXSTAT -- Determine whether or not the two axes are equal. + +int procedure rg_axstat (mw1, ax11, ax12, mw2, ax21, ax22, transpose) + +pointer mw1 #I pointer to the first wcs +int ax11, ax12 #I the logical reference axes +pointer mw2 #I pointer to the second wcs +int ax21, ax22 #I the logical input axes +bool transpose #I transpose the world coordinates + +int stat +pointer sp, xax1, yax1, xax2, yax2 +bool streq() +errchk mw_gwattrs() + +begin + call smark (sp) + call salloc (xax1, SZ_FNAME, TY_CHAR) + call salloc (yax1, SZ_FNAME, TY_CHAR) + call salloc (xax2, SZ_FNAME, TY_CHAR) + call salloc (yax2, SZ_FNAME, TY_CHAR) + + iferr (call mw_gwattrs (mw1, ax11, "axtype", Memc[xax1], SZ_FNAME)) + Memc[xax1] = EOS + iferr (call mw_gwattrs (mw1, ax12, "axtype", Memc[yax1], SZ_FNAME)) + Memc[yax1] = EOS + iferr (call mw_gwattrs (mw2, ax21, "axtype", Memc[xax2], SZ_FNAME)) + Memc[xax2] = EOS + iferr (call mw_gwattrs (mw2, ax22, "axtype", Memc[yax2], SZ_FNAME)) + Memc[yax2] = EOS + + if (transpose) + stat = RG_AXSWITCHED + else if (streq (Memc[xax1], Memc[xax2]) && streq(Memc[yax1], + Memc[yax2])) + stat = RG_AXEQUAL + else if (streq (Memc[xax1], Memc[yax2]) && streq(Memc[yax1], + Memc[xax2])) + stat = RG_AXSWITCHED + else + stat = RG_AXNOTEQUAL + + call sfree (sp) + + return (stat) +end + + +# RG_PROJSTAT -- Determine whether or not the projections of two axes are equal. + +int procedure rg_projstat (mw1, ax11, ax12, mw2, ax21, ax22) + +pointer mw1 #I pointer to the first wcs +int ax11, ax12 #I the logical reference axes +pointer mw2 #I pointer to the second wcs +int ax21, ax22 #I the logical reference axes + +int stat +pointer sp, xproj1, yproj1, xproj2, yproj2 +bool streq() +errchk mw_gwattrs() + +begin + call smark (sp) + call salloc (xproj1, SZ_FNAME, TY_CHAR) + call salloc (yproj1, SZ_FNAME, TY_CHAR) + call salloc (xproj2, SZ_FNAME, TY_CHAR) + call salloc (yproj2, SZ_FNAME, TY_CHAR) + + iferr (call mw_gwattrs (mw1, ax11, "wtype", Memc[xproj1], SZ_FNAME)) + Memc[xproj1] = EOS + iferr (call mw_gwattrs (mw1, ax12, "wtype", Memc[yproj1], SZ_FNAME)) + Memc[yproj1] = EOS + iferr (call mw_gwattrs (mw2, ax21, "wtype", Memc[xproj2], SZ_FNAME)) + Memc[xproj2] = EOS + iferr (call mw_gwattrs (mw2, ax22, "wtype", Memc[yproj2], SZ_FNAME)) + Memc[yproj2] = EOS + + if (streq (Memc[xproj1], Memc[xproj2]) && streq(Memc[yproj1], + Memc[yproj2])) + stat = RG_AXEQUAL + else if (streq (Memc[xproj1], Memc[yproj2]) && streq(Memc[yproj1], + Memc[xproj2])) + stat = RG_AXSWITCHED + else + stat = RG_AXNOTEQUAL + + call sfree (sp) + + return (stat) +end + + +# RG_WCOORDS -- Write out the reference and input logical coordinates of the +# tie points and the reference world coordinates. + +procedure rg_wcoords (ofd, xref, yref, xin, yin, wxref, wyref, npts, + xformat, yformat, wxformat, wyformat) + +int ofd #I the output file descriptor +double xref[ARB] #I the reference logical x coordinates +double yref[ARB] #I the reference logical y coordinates +double xin[ARB] #I the input logical x coordinates +double yin[ARB] #I the input logical y coordinates +double wxref[ARB] #I the input reference world x coordinates +double wyref[ARB] #I the input reference world y coordinates +int npts #I the number of input points +char xformat[ARB] #I the logical x coordinates format +char yformat[ARB] #I the logical y coordinates format +char wxformat[ARB] #I the world x coordinates format +char wyformat[ARB] #I the world y coordinates format + +int i +pointer sp, fmtstr + +begin + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + + # Write the column descriptions. + call fprintf (ofd, + "# \tColumn 1: reference logical x coordinate\n") + call fprintf (ofd, + "# \tColumn 2: reference logical y coordinate\n") + call fprintf (ofd, + "# \tColumn 3: input logical x coordinate\n") + call fprintf (ofd, + "# \tColumn 4: input logical y coordinate\n") + call fprintf (ofd, + "# \tColumn 5: reference world x coordinate\n") + call fprintf (ofd, + "# \tColumn 6: reference world y coordinate\n") + call fprintf (ofd, "\n") + + # Create the format string. + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s %s %s\n") + call pargstr (xformat) + call pargstr (yformat) + call pargstr (xformat) + call pargstr (yformat) + call pargstr (wxformat) + call pargstr (wyformat) + + do i = 1, npts { + call fprintf (ofd, Memc[fmtstr]) + call pargd (xref[i]) + call pargd (yref[i]) + call pargd (xin[i]) + call pargd (yin[i]) + call pargd (wxref[i]) + call pargd (wyref[i]) + } + + call sfree (sp) +end + + +# RG_LAXMAP (paxno, wcsndim, laxno, ndim) + +procedure rg_laxmap (paxno, wcsndim, laxno, ndim) + +int paxno[ARB] #I the physical axis map +int wcsndim #I the number of physical axis dimensions +int laxno[ARB] #O the physical axis map +int ndim #I the number of logical axis dimensions + +int i, j + +begin + if (ndim < wcsndim) { + do i = 1, ndim { + laxno[i] = 0 + do j = 1, wcsndim { + if (paxno[j] != i) + next + laxno[i] = j + break + } + } + do i = ndim + 1, wcsndim + laxno[i] = 0 + } else { + do i = 1, wcsndim + laxno[i] = i + } +end diff --git a/pkg/images/immatch/src/wcsmatch/wcsxymatch.h b/pkg/images/immatch/src/wcsmatch/wcsxymatch.h new file mode 100644 index 00000000..b92673a6 --- /dev/null +++ b/pkg/images/immatch/src/wcsmatch/wcsxymatch.h @@ -0,0 +1,15 @@ +# Define the permitted input wcs types +define RG_WCSLIST "|physical|world|" + +define RG_PHYSICAL 1 +define RG_WORLD 2 + +# Define the permitted units +define RG_UNITLIST "|hours|native|" +define RG_UHOURS 1 +define RG_UNATIVE 2 + +# Define the relationship between the two axes +define RG_AXEQUAL 1 +define RG_AXSWITCHED 2 +define RG_AXNOTEQUAL 3 diff --git a/pkg/images/immatch/src/xregister/mkpkg b/pkg/images/immatch/src/xregister/mkpkg new file mode 100644 index 00000000..262b721d --- /dev/null +++ b/pkg/images/immatch/src/xregister/mkpkg @@ -0,0 +1,25 @@ +# Make the XREGISTER task + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + +libpkg.a: + rgxbckgrd.x "xregister.h" <math/gsurfit.h> + rgxcolon.x "xregister.h" <imhdr.h> <imset.h> <error.h> + rgxcorr.x "xregister.h" <imhdr.h> <math/gsurfit.h> <math.h> + rgxdbio.x "xregister.h" + rgxfft.x + rgxfit.x "xregister.h" <math/iminterp.h> <mach.h> <math/nlfit.h> + rgxgpars.x "xregister.h" + rgxicorr.x "xregister.h" <ctype.h> <imhdr.h> <fset.h> + rgximshift.x <imhdr.h> <imset.h> <math/iminterp.h> + rgxplot.x <imhdr.h> <gset.h> + rgxppars.x "xregister.h" + rgxregions.x "xregister.h" <fset.h> <imhdr.h> <ctype.h> + rgxshow.x "xregister.h" + rgxtools.x "xregister.h" + rgxtransform.x "xregister.h" <imhdr.h> <math.h> + t_xregister.x "xregister.h" <fset.h> <gset.h> <imhdr.h> <imset.h> + ; diff --git a/pkg/images/immatch/src/xregister/oxregister.key b/pkg/images/immatch/src/xregister/oxregister.key new file mode 100644 index 00000000..91064ff8 --- /dev/null +++ b/pkg/images/immatch/src/xregister/oxregister.key @@ -0,0 +1,33 @@ + Xregister Image Overlay Sub-menu + + +? Print help +c Overlay the marked column of the reference image + with the same column of the input image +l Overlay the marked line of the reference image + with the sname line of the input image +x Overlay the marked column of the reference image + with the x and y lagged column of the input image +y Overlay the marked line of the reference image + with the x and y lagged line of the input image +v Overlay the marked column of the reference image + with the x and y shifted column of the input image +h Overlay the marked line of the reference image + with the x and y shifted line of the input image +q Quit + + + Image Overlay Sub-menu Colon Commands + +:c [m] [n] Overlay the middle [mth] column of the reference image + with the mth [nth] column of the input image +:l [m] [n] Overlay the middle [mth] line of the reference image + with the mth [nth] line of the input image +:x [m] Overlay the middle [mth] column of the reference image + with the x and y lagged column of the input image +:y [m] Overlay the middle [mth] line of the reference image + with the x and y lagged line of the input image +:v [m] Overlay the middle [mth] column of the reference image + with the x and y shifted column of the input image +:h [m] Overlay the middle [mth] line of the reference image + with the x and y shifted line of the input image diff --git a/pkg/images/immatch/src/xregister/rgxbckgrd.x b/pkg/images/immatch/src/xregister/rgxbckgrd.x new file mode 100644 index 00000000..c9747ee6 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxbckgrd.x @@ -0,0 +1,63 @@ +include <math/gsurfit.h> +include "xregister.h" + +# RG_XSCALE -- Compute the background offset and x and y slope. + +procedure rg_xscale (xc, data, npts, nx, ny, offset, coeff) + +pointer xc #I pointer to the cross-correlation function +real data[ARB] #I the input data +int npts #I the number of points +int nx, ny #I the dimensions of the original subraster +real offset #I the input offset +real coeff[ARB] #O the output coefficients + +int wborder +pointer gs +real loreject, hireject, zero +int rg_xstati(), rg_znsum(), rg_znmedian(), rg_slope() +real rg_xstatr() + +begin + loreject = rg_xstatr (xc, LOREJECT) + hireject = rg_xstatr (xc, HIREJECT) + wborder = rg_xstati (xc, BORDER) + + switch (rg_xstati (xc, BACKGRD)) { + case XC_BNONE: + coeff[1] = offset + coeff[2] = 0.0 + coeff[3] = 0.0 + case XC_MEAN: + if (rg_znsum (data, npts, zero, loreject, hireject) <= 0) + zero = 0.0 + coeff[1] = zero + coeff[2] = 0.0 + coeff[3] = 0.0 + case XC_MEDIAN: + if (rg_znmedian (data, npts, zero, loreject, hireject) <= 0) + zero = 0.0 + coeff[1] = zero + coeff[2] = 0.0 + coeff[3] = 0.0 + case XC_SLOPE: + call gsinit (gs, GS_POLYNOMIAL, 2, 2, GS_XNONE, 1.0, real (nx), 1.0, + real (ny)) + if (rg_slope (gs, data, npts, nx, ny, wborder, wborder, loreject, + hireject) == ERR) { + coeff[1] = 0.0 + coeff[2] = 0.0 + coeff[3] = 0.0 + } else { + call gssave (gs, coeff) + coeff[1] = coeff[GS_SAVECOEFF+1] + coeff[2] = coeff[GS_SAVECOEFF+2] + coeff[3] = coeff[GS_SAVECOEFF+3] + } + call gsfree (gs) + default: + coeff[1] = offset + coeff[2] = 0.0 + coeff[3] = 0.0 + } +end diff --git a/pkg/images/immatch/src/xregister/rgxcolon.x b/pkg/images/immatch/src/xregister/rgxcolon.x new file mode 100644 index 00000000..cb007473 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxcolon.x @@ -0,0 +1,508 @@ +include <error.h> +include <imhdr.h> +include <imset.h> +include "xregister.h" + +# RG_XCOLON-- Procedure to process colon commands for setting the cross- +# correlation parameters. + +procedure rg_xcolon (gd, xc, imr, im1, im2, db, dformat, tfd, reglist, cmdstr, + newdata, newcross, newcenter) + +pointer gd #I pointer to the graphics stream +pointer xc #I pointer to cross-correlation structure +pointer imr #I/O pointer to the reference image +pointer im1 #I/O pointer to the input image +pointer im2 #I/O pointer to the output image +pointer db #I/O pointer to the shifts database file +int dformat #I is the shifts file in database format +int tfd #I/O the transformations file descriptor +pointer reglist #I/O pointer to the regions list +char cmdstr[ARB] #I input command string +int newdata #I/O new input data +int newcross #I/O new cross-correlation function flag +int newcenter #I/O new cross-correlation peak flag + +bool streq() +int ncmd, creg, nreg, ival, stat +pointer sp, cmd, str +real rval +int strdic(), open(), nscan(), rg_xstati(), fntopnb() +int rg_xregions(), rg_xmkregions(), strlen() +pointer immap(), dtmap(), rg_xstatp() +real rg_xstatr() +errchk immap(), dtmap(), open(), fntopnb() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the command. + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call sfree (sp) + return + } + + # Process the command. + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, XCMDS) + switch (ncmd) { + case XCMD_REFIMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str]) + } else { + if (imr != NULL) { + call imunmap (imr) + imr = NULL + } + iferr { + imr = immap (Memc[cmd], READ_ONLY, 0) + } then { + call erract (EA_WARN) + imr = immap (Memc[str], READ_ONLY, 0) + } else if (IM_NDIM(imr) > 2 || IM_NDIM(imr) != IM_NDIM(im1)) { + call printf ( + "Image has the wrong number of dimensions\n") + call imunmap (imr) + imr = immap (Memc[str], READ_ONLY, 0) + } else { + call rg_xsets (xc, REFIMAGE, Memc[cmd]) + newdata = YES; newcross = YES; newcenter = YES + } + } + + case XCMD_IMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_xstats (xc, IMAGE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + } else { + if (im1 != NULL) { + call imunmap (im1) + im1 = NULL + } + iferr { + im1 = immap (Memc[cmd], READ_ONLY, 0) + call imseti (im1, IM_TYBNDRY, BT_NEAREST) + if (IM_NDIM(im1) == 1) + call imseti (im1, IM_NBNDRYPIX, IM_LEN(im1,1)) + else + call imseti (im1, IM_NBNDRYPIX, + max (IM_LEN(im1,1), IM_LEN(im1,2))) + } then { + call erract (EA_WARN) + im1 = immap (Memc[str], READ_ONLY, 0) + call imseti (im1, IM_TYBNDRY, BT_NEAREST) + if (IM_NDIM(im1) == 1) + call imseti (im1, IM_NBNDRYPIX, IM_LEN(im1,1)) + else + call imseti (im1, IM_NBNDRYPIX, + max (IM_LEN(im1,1), IM_LEN(im1,2))) + } else if (IM_NDIM(im1) > 2 || IM_NDIM(im1) != IM_NDIM(imr)) { + call printf ( + "Image has the wrong number of dimensions\n") + call imunmap (im1) + im1 = immap (Memc[str], READ_ONLY, 0) + call imseti (im1, IM_TYBNDRY, BT_NEAREST) + if (IM_NDIM(im1) == 1) + call imseti (im1, IM_NBNDRYPIX, IM_LEN(im1,1)) + else + call imseti (im1, IM_NBNDRYPIX, + max (IM_LEN(im1,1), IM_LEN(im1,2))) + } else { + call rg_xsets (xc, IMAGE, Memc[cmd]) + newdata = YES; newcross = YES; newcenter = YES + } + } + + case XCMD_OUTIMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_xstats (xc, OUTIMAGE, Memc[str], SZ_FNAME) + if (im2 == NULL || Memc[cmd] == EOS || streq (Memc[cmd], + Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_OUTIMAGE) + call pargstr (Memc[str]) + } else { + if (im2 != NULL) { + call imunmap (im2) + im2 = NULL + } + iferr { + im2 = immap (Memc[cmd], NEW_COPY, im1) + } then { + call erract (EA_WARN) + im2 = immap (Memc[str], NEW_COPY, im1) + } else { + call rg_xsets (xc, OUTIMAGE, Memc[cmd]) + } + } + + case XCMD_DATABASE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_xstats (xc, DATABASE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_DATABASE) + call pargstr (Memc[str]) + } else { + if (db != NULL) { + if (dformat == YES) + call dtunmap (db) + else + call close (db) + db = NULL + } + iferr { + if (dformat == YES) + db = dtmap (Memc[cmd], APPEND) + else + db = open (Memc[cmd], NEW_FILE, TEXT_FILE) + } then { + call erract (EA_WARN) + if (dformat == YES) + db = dtmap (Memc[str], APPEND) + else + db = open (Memc[str], APPEND, TEXT_FILE) + } else { + call rg_xsets (xc, DATABASE, Memc[cmd]) + } + } + + CASE XCMD_RECORD: + call gargstr (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_xstats (xc, RECORD, Memc[str], SZ_FNAME) + call printf ("%s: %s\n") + call pargstr (KY_RECORD) + call pargstr (Memc[str]) + } else + call rg_xsets (xc, RECORD, Memc[cmd]) + + case XCMD_CREGION: + + call gargi (nreg) + creg = rg_xstati (xc, CREGION) + + if (nscan() == 1 || (nreg == creg)) { + call printf ("%s: %d/%d") + call pargstr (KY_CREGION) + call pargi (creg) + call pargi (rg_xstati (xc, NREGIONS)) + call printf (" [%d:%d,%d:%d]\n") + call pargi (Memi[rg_xstatp (xc,RC1)+creg-1]) + call pargi (Memi[rg_xstatp (xc,RC2)+creg-1]) + call pargi (Memi[rg_xstatp (xc,RL1)+creg-1]) + call pargi (Memi[rg_xstatp (xc,RL2)+creg-1]) + + } else { + if (nreg < 1 || nreg > rg_xstati (xc,NREGIONS)) { + call printf ("Region %d is out of range\n") + call pargi (nreg) + } else { + call printf ( + "Setting current region to %d: [%d:%d,%d:%d]\n") + call pargi (nreg) + call pargi (Memi[rg_xstatp (xc,RC1)+nreg-1]) + call pargi (Memi[rg_xstatp (xc,RC2)+nreg-1]) + call pargi (Memi[rg_xstatp (xc,RL1)+nreg-1]) + call pargi (Memi[rg_xstatp (xc,RL2)+nreg-1]) + call rg_xseti (xc, CREGION, nreg) + newdata = YES; newcross = YES; newcenter = YES + } + + } + + case XCMD_REGIONS: + + call gargwrd (Memc[cmd], SZ_LINE) + call rg_xstats (xc, REGIONS, Memc[str], SZ_FNAME) + if (nscan() == 1 || streq (Memc[cmd], Memc[str]) || Memc[cmd] == + EOS) { + call printf ("%s [string/file]: %s\n") + call pargstr (KY_REGIONS) + call pargstr (Memc[str]) + } else { + if (reglist != NULL) { + call fntclsb (reglist) + reglist = NULL + } + iferr (reglist = fntopnb (Memc[cmd], NO)) + reglist = NULL + if (rg_xregions (reglist, imr, xc, 1) > 0) { + call rg_xseti (xc, CREGION, 1) + call rg_xsets (xc, REGIONS, Memc[cmd]) + newdata = YES; newcross = YES; newcenter = YES + } else { + if (reglist != NULL) { + call fntclsb (reglist) + reglist = NULL + } + iferr (reglist = fntopnb (Memc[str], NO)) + reglist = NULL + if (rg_xregions (reglist, imr, xc, 1) > 0) + ; + call rg_xsets (xc, REGIONS, Memc[str]) + call rg_xseti (xc, CREGION, 1) + } + } + + case XCMD_REFFILE: + + call gargwrd (Memc[cmd], SZ_LINE) + call rg_xstats (xc, REFFILE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_REFFILE) + call pargstr (Memc[str]) + } else { + if (tfd != NULL) { + call close (tfd) + tfd = NULL + } + iferr { + tfd = open (Memc[cmd], READ_ONLY, TEXT_FILE) + } then { + tfd = NULL + call erract (EA_WARN) + call rg_xsets (xc, REFFILE, "") + call printf ("Coords file is undefined.\n") + } else + call rg_xsets (xc, REFFILE, Memc[cmd]) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_XLAG: + call gargi (ival) + if (nscan () == 1) { + call printf ("%s = %d\n") + call pargstr (KY_XLAG) + call pargi (rg_xstati (xc, XLAG)) + } else { + call rg_xseti (xc, XLAG, ival) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_YLAG: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_YLAG) + call pargi (rg_xstati (xc, YLAG)) + } else { + call rg_xseti (xc, YLAG, ival) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_DXLAG: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_DXLAG) + call pargi (rg_xstati (xc, DXLAG)) + } else { + call rg_xseti (xc, DXLAG, ival) + } + + case XCMD_DYLAG: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_DYLAG) + call pargi (rg_xstati (xc, DYLAG)) + } else { + call rg_xseti (xc, DYLAG, ival) + } + + case XCMD_BACKGROUND: + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] != EOS) + call strcat (" ", Memc[cmd], SZ_LINE) + call gargwrd (Memc[cmd+strlen(Memc[cmd])], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_xstats (xc, BSTRING, Memc[str], SZ_FNAME) + call printf ("%s: %s\n") + call pargstr (KY_BACKGROUND) + call pargstr (Memc[str]) + } else { + call rg_xsets (xc, BSTRING, Memc[cmd]) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_BORDER: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_BORDER) + call pargi (rg_xstati (xc, BORDER)) + } else { + call rg_xseti (xc, BORDER, ival) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_LOREJECT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_LOREJECT) + call pargr (rg_xstatr (xc, LOREJECT)) + } else { + call rg_xsetr (xc, LOREJECT, rval) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_HIREJECT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_HIREJECT) + call pargr (rg_xstatr (xc, HIREJECT)) + } else { + call rg_xsetr (xc, HIREJECT, rval) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_APODIZE: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_APODIZE) + call pargr (rg_xstatr (xc, APODIZE)) + } else { + call rg_xsetr (xc, APODIZE, max (0.0, min (rval, 0.50))) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_CORRELATION: + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_xstats (xc, CSTRING, Memc[str], SZ_FNAME) + call printf ("%s = %s\n") + call pargstr (KY_CORRELATION) + call pargstr (Memc[str]) + } else { + stat = strdic (Memc[cmd], Memc[cmd], SZ_LINE, XC_CTYPES) + if (stat > 0) { + call rg_xseti (xc, CFUNC, stat) + call rg_xsets (xc, CSTRING, Memc[cmd]) + newcross = YES; newcenter = YES + } + } + + case XCMD_XWINDOW: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_XWINDOW) + call pargi (rg_xstati (xc, XWINDOW)) + } else { + call rg_xseti (xc, XWINDOW, ival) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_YWINDOW: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_YWINDOW) + call pargi (rg_xstati (xc, YWINDOW)) + } else { + call rg_xseti (xc, YWINDOW, ival) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_PEAKCENTER: + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_xstats (xc, PSTRING, Memc[str], SZ_FNAME) + call printf ("%s: %s\n") + call pargstr (KY_PEAKCENTER) + call pargstr (Memc[str]) + } else { + stat = strdic (Memc[cmd], Memc[cmd], SZ_LINE, XC_PTYPES) + if (stat > 0) { + call rg_xseti (xc, PFUNC, stat) + call rg_xsets (xc, PSTRING, Memc[cmd]) + newcenter = YES + } + } + + case XCMD_XCBOX: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_XCBOX) + call pargi (rg_xstati (xc, XCBOX)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_xseti (xc, XCBOX, ival) + newcenter = YES + } + + case XCMD_YCBOX: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_YCBOX) + call pargi (rg_xstati (xc, YCBOX)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_xseti (xc, YCBOX, ival) + newcenter = YES + } + + case XCMD_SHOW: + call gdeactivate (gd, 0) + call gargwrd (Memc[cmd], SZ_LINE) + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, XSHOW) + switch (ncmd) { + case XSHOW_DATA: + call rg_xnshow (xc) + case XSHOW_BACKGROUND: + call rg_xbshow (xc) + case XSHOW_CORRELATION: + call rg_xxshow (xc) + case XSHOW_PEAKCENTER: + call rg_xpshow (xc) + default: + call rg_xshow (xc) + } + call greactivate (gd, 0) + + case XCMD_MARK: + call gdeactivate (gd, 0) + if (reglist != NULL) { + call fntclsb (reglist) + reglist = NULL + } + if (rg_xmkregions (imr, xc, 1, MAX_NREGIONS, Memc[str], + SZ_LINE) <= 0) { + call rg_xstats (xc, REGIONS, Memc[str], SZ_LINE) + iferr (reglist = fntopnb (Memc[str], NO)) + reglist = NULL + if (rg_xregions (reglist, imr, xc, 1) > 0) + ; + call rg_xsets (xc, REGIONS, Memc[str]) + call rg_xseti (xc, CREGION, 1) + } else { + call rg_xseti (xc, CREGION, 1) + call rg_xsets (xc, REGIONS, Memc[str]) + newdata = YES; newcross = YES; newcenter = YES + } + call greactivate (gd, 0) + default: + call printf ("Unknown or ambiguous colon command\7\n") + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/xregister/rgxcorr.x b/pkg/images/immatch/src/xregister/rgxcorr.x new file mode 100644 index 00000000..a708bf7a --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxcorr.x @@ -0,0 +1,1034 @@ +include <imhdr.h> +include <math.h> +include <math/gsurfit.h> +include "xregister.h" + +# RG_XCORR -- Compute the shift shift for an image relative to a reference +# image using cross-correlation techniques. + +int procedure rg_xcorr (imr, im1, db, dformat, xc) + +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer db #I pointer to the shifts database +int dformat #I write shifts file in database format ? +pointer xc #I pointer to the cross-correlation structure + +pointer sp, image, imname +real xshift, yshift +bool streq() +int rg_xstati(), fscan(), nscan() +errchk rg_cross(), rg_xfile() + +begin + # Allocate working space. + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call rg_xstats (xc, IMAGE, Memc[image], SZ_FNAME) + + # Initialize. + xshift = 0.0 + yshift = 0.0 + + # Compute the average shift for the image. + switch (rg_xstati (xc, CFUNC)) { + case XC_DISCRETE, XC_DIFFERENCE, XC_FOURIER: + + # Write out the parameters. + if (dformat == YES) + call rg_xdbparams (db, xc) + + # Compute the cross-correlation function. + call rg_cross (imr, im1, xc, NULL, xshift, yshift) + call rg_xsetr (xc, TXSHIFT, xshift) + call rg_xsetr (xc, TYSHIFT, yshift) + + # Write out the results for the individual regions. + if (dformat == YES) + call rg_xwreg (db, xc) + + # Write out the total shifts. + if (dformat == YES) + call rg_xdbshift (db, xc) + else { + call fprintf (db, "%s %g %g\n") + call pargstr (Memc[image]) + call pargr (xshift) + call pargr (yshift) + } + + # Set the x and y lags for the next picture. + if (rg_xstati (xc, NREFPTS) > 0) { + call rg_xseti (xc, XLAG, 0) + call rg_xseti (xc, YLAG, 0) + } else if (IS_INDEFI (rg_xstati (xc, DXLAG)) || + IS_INDEFI (rg_xstati (xc, DYLAG))) { + call rg_xseti (xc, XLAG, nint (-xshift)) + call rg_xseti (xc, YLAG, nint (-yshift)) + } else { + call rg_xseti (xc, XLAG, rg_xstati (xc, XLAG) + rg_xstati (xc, + DXLAG)) + call rg_xseti (xc, YLAG, rg_xstati (xc, YLAG) + rg_xstati (xc, + DYLAG)) + } + + case XC_FILE: + if (dformat == YES) + call rg_xfile (db, xc, xshift, yshift) + else { + if (fscan (db) != EOF) { + call gargwrd (Memc[imname], SZ_FNAME) + call gargr (xshift) + call gargr (yshift) + if (! streq (Memc[imname], Memc[image]) || nscan() != 3) { + xshift = 0.0 + yshift = 0.0 + } + } else { + xshift = 0.0 + yshift = 0.0 + } + } + call rg_xsetr (xc, TXSHIFT, xshift) + call rg_xsetr (xc, TYSHIFT, yshift) + + default: + call error (0, "The correlation function is undefined.") + } + + call sfree (sp) + + return (NO) +end + + +# RG_CROSS -- Compute the cross-correlation function for all the regions +# using discrete, fourier, or difference techniques and compute the position +# of its peak using one of several centering algorithms. + +procedure rg_cross (imr, im1, xc, gd, xavshift, yavshift) + +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer xc #I pointer to the cross correlation structure +pointer gd #I pointer to graphics stream +real xavshift #O x coord shift +real yavshift #O y coord shift + +int i, nregions, ngood +pointer pxshift, pyshift +real xshift, yshift +int rg_xstati(), rg_xcget(), rg_xfget() +pointer rg_xstatp() + +begin + # Get the pointers. + pxshift = rg_xstatp (xc, XSHIFTS) + pyshift = rg_xstatp (xc, YSHIFTS) + nregions = rg_xstati (xc, NREGIONS) + + # Loop over the regions. + xavshift = 0.0 + yavshift = 0.0 + ngood = 0 + do i = 1, nregions { + + # Compute the cross_correlation function. + switch (rg_xstati (xc, CFUNC)) { + case XC_DISCRETE, XC_DIFFERENCE: + if (rg_xcget (xc, imr, im1, i) == ERR) { + Memr[pxshift+i-1] = INDEFR + Memr[pyshift+i-1] = INDEFR + if (rg_xstatp (xc, XCOR) != NULL) + call mfree (rg_xstatp (xc, XCOR), TY_REAL) + call rg_xsetp (xc, XCOR, NULL) + next + } + case XC_FOURIER: + if (rg_xfget (xc, imr, im1, i) == ERR) { + Memr[pxshift+i-1] = INDEFR + Memr[pyshift+i-1] = INDEFR + if (rg_xstatp (xc, XCOR) != NULL) + call mfree (rg_xstatp (xc, XCOR), TY_REAL) + call rg_xsetp (xc, XCOR, NULL) + next + } + default: + call error (0, "The correlation function is undefined") + } + + # Find the peak of the cross-correlation function. + call rg_fit (xc, i, gd, xshift, yshift) + + # Accumulate the shifts. + xavshift = xavshift + xshift + yavshift = yavshift + yshift + ngood = ngood + 1 + } + + # Compute the average shift. + if (ngood > 0) { + xavshift = xavshift / ngood + yavshift = yavshift / ngood + } +end + + +# RG_XFILE -- Read the average x and y shifts from the shifts database. + +procedure rg_xfile (db, xc, xshift, yshift) + +pointer db #I pointer to the database +pointer xc #I pointer to the cross correlation structure +real xshift #O shift in x +real yshift #O shift in y + +int rec +pointer sp, str +int dtlocate() +real dtgetr() +errchk dtlocate(), dtgetr() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + call rg_xstats (xc, RECORD, Memc[str], SZ_LINE) + iferr { + rec = dtlocate (db, Memc[str]) + xshift = dtgetr (db, rec, "xshift") + yshift = dtgetr (db, rec, "yshift") + } then { + xshift = 0.0 + yshift = 0.0 + } + + call sfree (sp) +end + + +# RG_ICROSS -- Compute the cross-correlation function for a given region. + +int procedure rg_icross (xc, imr, im1, nreg) + +pointer xc #I pointer to the cross-correlation structure +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +int nreg #I the index of the current region + +int stat +pointer pxshift, pyshift +int rg_xstati(), rg_xcget(), rg_xfget() +pointer rg_xstatp() + +begin + pxshift = rg_xstatp (xc, XSHIFTS) + pyshift = rg_xstatp (xc, YSHIFTS) + + switch (rg_xstati (xc, CFUNC)) { + case XC_DISCRETE, XC_DIFFERENCE: + stat = rg_xcget (xc, imr, im1, nreg) + if (stat == ERR) { + Memr[pxshift+nreg-1] = INDEFR + Memr[pyshift+nreg-1] = INDEFR + if (rg_xstatp (xc, XCOR) != NULL) + call mfree (rg_xstatp (xc, XCOR), TY_REAL) + call rg_xsetp (xc, XCOR, NULL) + } + case XC_FOURIER: + stat = rg_xfget (xc, imr, im1, nreg) + if (stat == ERR) { + Memr[pxshift+nreg-1] = INDEFR + Memr[pyshift+nreg-1] = INDEFR + if (rg_xstatp (xc, XCOR) != NULL) + call mfree (rg_xstatp (xc, XCOR), TY_REAL) + call rg_xsetp (xc, XCOR, NULL) + } + case XC_FILE: + stat = OK + } + + return (stat) +end + + +# RG_XCGET -- Compute the convolution using the discrete or difference +# correlation functions. + +int procedure rg_xcget (xc, imr, im1, i) + +pointer xc #I pointer to the cross-correlation structure +pointer imr #I pointer to the reference image +pointer im1 #I pointer to input image image +int i #I index of region + +int stat, xwindow, ywindow, nrimcols, nrimlines, nimcols, nimlines +int nrcols, nrlines, ncols, nlines +int xlag, ylag, nborder, rc1, rc2, rl1, rl2, c1, c2, l1, l2 +pointer sp, str, coeff, rbuf, ibuf, xcor +pointer prc1, prc2, prl1, prl2, przero, prxslope, pryslope, border +real rxlag, rylag +int rg_xstati(), rg_border() +pointer rg_xstatp(), rg_ximget() +real rg_xstatr() + +define nextregion_ 10 + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (coeff, max (GS_SAVECOEFF + 6, 9), TY_REAL) + rbuf = NULL + ibuf = NULL + + # Check for regions. + if (i > rg_xstati (xc, NREGIONS)) { + stat = ERR + goto nextregion_ + } + + # Get the image sizes. + nrimcols = IM_LEN(imr,1) + if (IM_NDIM(imr) == 1) + nrimlines = 1 + else + nrimlines = IM_LEN(imr,2) + nimcols = IM_LEN(im1,1) + if (IM_NDIM(im1) == 1) + nimlines = 1 + else + nimlines = IM_LEN(im1,2) + + # Get the reference region pointers. + prc1 = rg_xstatp (xc, RC1) + prc2 = rg_xstatp (xc, RC2) + prl1 = rg_xstatp (xc, RL1) + prl2 = rg_xstatp (xc, RL2) + przero = rg_xstatp (xc, RZERO) + prxslope = rg_xstatp (xc, RXSLOPE) + pryslope = rg_xstatp (xc, RYSLOPE) + + # Compute the reference region limits. + rc1 = max (1, min (int (nrimcols), Memi[prc1+i-1])) + rc2 = min (int (nrimcols), max (1, Memi[prc2+i-1])) + rl1 = max (1, min (int (nrimlines), Memi[prl1+i-1])) + rl2 = min (int (nrimlines), max (1, Memi[prl2+i-1])) + nrcols = rc2 - rc1 + 1 + nrlines = rl2 - rl1 + 1 + + # Move to the next reference region if current region is off the image. + if (rc1 > nrimcols || rc2 < 1 || rl1 > nrimlines || rl2 < 1) { + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Reference section: %s[%d:%d,%d:%d] is off image.\n") + call pargstr (Memc[str]) + call pargi (rc1) + call pargi (rc2) + call pargi (rl1) + call pargi (rl2) + stat = ERR + goto nextregion_ + } + + # Check the window sizes. + xwindow = rg_xstati (xc, XWINDOW) + if (nrlines == 1) + ywindow = 1 + else + ywindow = rg_xstati (xc, YWINDOW) + + # Move to next ref regions if current region is too small. + if (nrcols < xwindow || (IM_NDIM(imr) == 2 && nrlines < ywindow)) { + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Reference section: %s[%d:%d,%d:%d] has too few points.\n") + call pargstr (Memc[str]) + call pargi (rc1) + call pargi (rc2) + call pargi (rl1) + call pargi (rl2) + stat = ERR + goto nextregion_ + } + + # Apply the transformation if defined or lag to the ref regions. + if (rg_xstati (xc, NREFPTS) > 0) { + call rg_etransform (xc, (rc1 + rc2) / 2.0, (rl1 + rl2) / 2.0, + rxlag, rylag) + xlag = rxlag - (rc1 + rc2) / 2.0 + if (ywindow == 1) + ylag = 0 + else + ylag = rylag - (rl1 + rl2) / 2.0 + } else { + xlag = rg_xstati (xc, XLAG) + if (ywindow == 1) + ylag = 0 + else + ylag = rg_xstati (xc, YLAG) + } + + # Get the input image limits. + c1 = rc1 + xlag - xwindow / 2 + c2 = rc2 + xlag + xwindow / 2 + l1 = rl1 + ylag - ywindow / 2 + l2 = rl2 + ylag + ywindow / 2 + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + + # Move to the next ref region if input region is off image. + if (c1 > nimcols || c2 < 1 || l1 > nimlines || l2 < 1) { + call rg_xstats (xc, IMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Image section: %s[%d:%d,%d:%d] is off image.\n") + call pargstr (Memc[str]) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + stat = ERR + goto nextregion_ + } + + # Move to the next ref region if input region is less than 3 by 3. + if ((ncols < xwindow) || (IM_NDIM(im1) == 2 && nlines < ywindow)) { + call rg_xstats (xc, IMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Image section: %s[%d:%d,%d:%d] has too few points.\n") + call pargstr (Memc[str]) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + stat = ERR + goto nextregion_ + } + + # Get the input reference and input image data. + rbuf = rg_ximget (imr, rc1, rc2, rl1, rl2) + if (rbuf == NULL) { + stat = ERR + goto nextregion_ + } + ibuf = rg_ximget (im1, c1, c2, l1, l2) + if (ibuf == NULL) { + stat = ERR + goto nextregion_ + } + + # Do the background subtraction. + + # Compute the zero point, x slope and y slope of ref image. + if (IS_INDEFR(Memr[przero+i-1]) || IS_INDEFR(Memr[prxslope+i- 1]) || + IS_INDEFR(Memr[pryslope+i-1])) { + if (IS_INDEFI(rg_xstati (xc, BORDER))) { + call rg_xscale (xc, Memr[rbuf], nrcols * nrlines, nrcols, + nrlines, rg_xstatr (xc, BVALUER), Memr[coeff]) + } else { + border = NULL + nborder = rg_border (Memr[rbuf], nrcols, nrlines, + max (0, nrcols - 2 * rg_xstati (xc, BORDER)), + max (0, nrlines - 2 * rg_xstati (xc, BORDER)), + border) + call rg_xscale (xc, Memr[border], nborder, nrcols, + nrlines, rg_xstatr (xc, BVALUER), Memr[coeff]) + if (border != NULL) + call mfree (border, TY_REAL) + } + + # Save the coefficients. + Memr[przero+i-1] = Memr[coeff] + Memr[prxslope+i-1] = Memr[coeff+1] + Memr[pryslope+i-1] = Memr[coeff+2] + } + + call rg_subtract (Memr[rbuf], nrcols, nrlines, Memr[przero+i-1], + Memr[prxslope+i-1], Memr[pryslope+i-1]) + + # Compute the zero point, and the x and y slopes of input image. + if (IS_INDEFI(rg_xstati (xc, BORDER))) { + call rg_xscale (xc, Memr[ibuf], ncols * nlines, ncols, + nlines, rg_xstatr (xc, BVALUE), Memr[coeff]) + } else { + border = NULL + nborder = rg_border (Memr[ibuf], ncols, nlines, + max (0, ncols - 2 * rg_xstati (xc, BORDER)), + max (0, nlines - 2 * rg_xstati (xc, BORDER)), + border) + call rg_xscale (xc, Memr[border], nborder, ncols, nlines, + rg_xstatr (xc, BVALUE), Memr[coeff]) + if (border != NULL) + call mfree (border, TY_REAL) + } + + # Subtract the baseline. + call rg_subtract (Memr[ibuf], ncols, nlines, Memr[coeff], + Memr[coeff+1], Memr[coeff+2]) + + # Apodize the data. + if (rg_xstatr (xc, APODIZE) > 0.0) { + call rg_apodize (Memr[rbuf], nrcols, nrlines, rg_xstatr (xc, + APODIZE), YES) + call rg_apodize (Memr[ibuf], ncols, nlines, rg_xstatr (xc, + APODIZE), YES) + } + + # Spatially filter the data with a Laplacian. + switch (rg_xstati (xc, FILTER)) { + case XC_LAPLACE: + call rg_xlaplace (Memr[rbuf], nrcols, nrlines, 1.0) + call rg_xlaplace (Memr[ibuf], ncols, nlines, 1.0) + default: + ; + } + + # Allocate space for the cross-correlation function. + if (rg_xstatp (xc, XCOR) == NULL) { + call malloc (xcor, xwindow * ywindow, TY_REAL) + call rg_xsetp (xc, XCOR, xcor) + } else { + xcor = rg_xstatp (xc, XCOR) + call realloc (xcor, xwindow * ywindow, TY_REAL) + call rg_xsetp (xc, XCOR, xcor) + } + + # Clear the correlation function. + call aclrr (Memr[xcor], xwindow * ywindow) + + # Compute the cross-correlation function. + if (rg_xstati (xc, CFUNC) == XC_DISCRETE) { + call rg_xconv (Memr[rbuf], nrcols, nrlines, Memr[ibuf], ncols, + nlines, Memr[xcor], xwindow, ywindow) + } else { + call rg_xdiff (Memr[rbuf], nrcols, nrlines, Memr[ibuf], ncols, + nlines, Memr[xcor], xwindow, ywindow) + } + + stat = OK + +nextregion_ + + # Free memory. + call sfree (sp) + if (rbuf != NULL) + call mfree (rbuf, TY_REAL) + if (ibuf != NULL) + call mfree (ibuf, TY_REAL) + if (stat == ERR) + return (ERR) + else + return (OK) +end + + +# RG_XFGET -- Compute the cross-correlation function using Fourier techniques. + +int procedure rg_xfget (xc, imr, im1, i) + +pointer xc #I pointer to the cross-correlation structure +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +int i #I index of the current region + +int rc1, rc2, rl1, rl2, nrcols, nrlines, c1, c2, l1, l2, ncols, nlines +int nrimcols, nrimlines, nimcols, nimlines +int xwindow, ywindow, xlag, nxfft, nyfft, ylag, stat, nborder +pointer sp, str, coeff, xcor, rbuf, ibuf, fft, border +pointer prc1, prc2, prl1, prl2, przero, prxslope, pryslope +real rxlag, rylag +int rg_xstati(), rg_border(), rg_szfft() +pointer rg_xstatp(), rg_ximget() +real rg_xstatr() + +define nextregion_ 11 + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (coeff, max (GS_SAVECOEFF+6, 9), TY_REAL) + + # Check for number of regions. + if (i > rg_xstati (xc, NREGIONS)) { + stat = ERR + goto nextregion_ + } + + # Allocate space for the cross-correlation function. + nrimcols = IM_LEN(imr,1) + if (IM_NDIM(imr) == 1) + nrimlines = 1 + else + nrimlines = IM_LEN(imr,2) + nimcols = IM_LEN(im1,1) + if (IM_NDIM(im1) == 1) + nimlines = 1 + else + nimlines = IM_LEN(im1,2) + + # Get the regions pointers. + prc1 = rg_xstatp (xc, RC1) + prc2 = rg_xstatp (xc, RC2) + prl1 = rg_xstatp (xc, RL1) + prl2 = rg_xstatp (xc, RL2) + przero = rg_xstatp (xc, RZERO) + prxslope = rg_xstatp (xc, RXSLOPE) + pryslope = rg_xstatp (xc, RYSLOPE) + + # Get the reference subraster region. + rc1 = max (1, min (int (nrimcols), Memi[prc1+i-1])) + rc2 = min (int (nrimcols), max (1, Memi[prc2+i-1])) + rl1 = max (1, min (int (nrimlines), Memi[prl1+i-1])) + rl2 = min (int (nrimlines), max (1, Memi[prl2+i-1])) + nrcols = rc2 - rc1 + 1 + nrlines = rl2 - rl1 + 1 + + # Go to next region if the reference region is off the image. + if (rc1 > nrimcols || rc2 < 1 || rl1 > nrimlines || rl2 < 1) { + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Reference section: %s[%d:%d,%d:%d] is off image.\n") + call pargstr (Memc[str]) + call pargi (rc1) + call pargi (rc2) + call pargi (rl1) + call pargi (rl2) + stat = ERR + goto nextregion_ + } + + # Check the window sizes. + xwindow = rg_xstati (xc, XWINDOW) + if (nrlines == 1) + ywindow = 1 + else + ywindow = rg_xstati (xc, YWINDOW) + + # Go to the next region if the reference region has too few points. + if ((nrcols < xwindow) || (IM_NDIM(im1) == 2 && nrlines < ywindow)) { + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Reference section: %s[%d:%d,%d:%d] has too few points.\n") + call pargstr (Memc[str]) + call pargi (rc1) + call pargi (rc2) + call pargi (rl1) + call pargi (rl2) + stat = ERR + goto nextregion_ + } + + # Apply the transformation if defined or the lag. + if (rg_xstati (xc, NREFPTS) > 0) { + call rg_etransform (xc, (rc1 + rc2) / 2.0, (rl1 + rl2) / 2.0, + rxlag, rylag) + xlag = rxlag - (rc1 + rc2) / 2.0 + if (ywindow == 1) + ylag = 0 + else + ylag = rylag - (rl1 + rl2) / 2.0 + } else { + xlag = rg_xstati (xc, XLAG) + if (ywindow == 1) + ylag = 0 + else + ylag = rg_xstati (xc, YLAG) + } + + # Get the input image subraster regions. + c1 = rc1 + xlag + c2 = rc2 + xlag + l1 = rl1 + ylag + l2 = rl2 + ylag + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + + # Go to next region if region is off the image. + if (c1 > nimcols || c2 < 1 || l1 > nimlines || l2 < 1) { + call rg_xstats (xc, IMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Image section: %s[%d:%d,%d:%d] is off image.\n") + call pargstr (Memc[str]) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + stat = ERR + goto nextregion_ + } + + # Go to next region if region has too few points. + if ((ncols < xwindow) || (IM_NDIM(im1) == 2 && nlines < ywindow)) { + call rg_xstats (xc, IMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Image section: %s[%d:%d,%d:%d] has too few points.\n") + call pargstr (Memc[str]) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + stat = ERR + goto nextregion_ + } + + # Figure out how big the Fourier transform has to be, given + # the size of the reference subraster, the window size and + # the fact that the FFT must be a power of 2. + + nxfft = rg_szfft (nrcols, xwindow) + if (ywindow == 1) + nyfft = 1 + else + nyfft = rg_szfft (nrlines, ywindow) + call calloc (fft, 2 * nxfft * nyfft, TY_REAL) + + # Get the input reference and input image data. + rbuf = NULL + rbuf = rg_ximget (imr, rc1, rc2, rl1, rl2) + if (rbuf == NULL) { + stat = ERR + goto nextregion_ + } + + # Do the background subtraction. + + # Compute the zero point, x slope and y slope of ref image. + if (IS_INDEFR(Memr[przero+i-1]) || IS_INDEFR(Memr[prxslope+i- 1]) || + IS_INDEFR(Memr[pryslope+i-1])) { + if (IS_INDEFI(rg_xstati (xc, BORDER))) { + call rg_xscale (xc, Memr[rbuf], nrcols * nrlines, nrcols, + nrlines, rg_xstatr (xc, BVALUER), Memr[coeff]) + } else { + border = NULL + nborder = rg_border (Memr[rbuf], nrcols, nrlines, + max (0, nrcols - 2 * rg_xstati (xc, BORDER)), + max (0, nrlines - 2 * rg_xstati (xc, BORDER)), + border) + call rg_xscale (xc, Memr[border], nborder, nrcols, + nrlines, rg_xstatr (xc, BVALUER), Memr[coeff]) + if (border != NULL) + call mfree (border, TY_REAL) + } + + # Save the coefficients. + Memr[przero+i-1] = Memr[coeff] + Memr[prxslope+i-1] = Memr[coeff+1] + Memr[pryslope+i-1] = Memr[coeff+2] + } + + call rg_subtract (Memr[rbuf], nrcols, nrlines, Memr[przero+i-1], + Memr[prxslope+i-1], Memr[pryslope+i-1]) + + # Apodize the data. + if (rg_xstatr (xc, APODIZE) > 0.0) + call rg_apodize (Memr[rbuf], nrcols, nrlines, rg_xstatr (xc, + APODIZE), YES) + + # Spatially filter the data with a Laplacian. + switch (rg_xstati (xc, FILTER)) { + case XC_LAPLACE: + call rg_xlaplace (Memr[rbuf], nrcols, nrlines, 1.0) + default: + ; + } + + # Load the reference data into the FFT. + call rg_rload (Memr[rbuf], nrcols, nrlines, Memr[fft], nxfft, nyfft) + call mfree (rbuf, TY_REAL) + + ibuf = NULL + ibuf = rg_ximget (im1, c1, c2, l1, l2) + if (ibuf == NULL) { + stat = ERR + goto nextregion_ + } + + # Compute the zero point, and the x and y slopes of input image. + if (IS_INDEFI(rg_xstati (xc, BORDER))) { + call rg_xscale (xc, Memr[ibuf], ncols * nlines, ncols, + nlines, rg_xstatr (xc, BVALUE), Memr[coeff]) + } else { + border = NULL + nborder = rg_border (Memr[ibuf], ncols, nlines, + max (0, ncols - 2 * rg_xstati (xc, BORDER)), + max (0, nlines - 2 * rg_xstati (xc, BORDER)), + border) + call rg_xscale (xc, Memr[border], nborder, ncols, nlines, + rg_xstatr (xc, BVALUE), Memr[coeff]) + if (border != NULL) + call mfree (border, TY_REAL) + } + + # Subtract the baseline. + call rg_subtract (Memr[ibuf], ncols, nlines, Memr[coeff], + Memr[coeff+1], Memr[coeff+2]) + + # Apodize the data. + if (rg_xstatr (xc, APODIZE) > 0.0) + call rg_apodize (Memr[ibuf], ncols, nlines, rg_xstatr (xc, + APODIZE), YES) + + # Spatially filter the data with a Laplacian. + switch (rg_xstati (xc, FILTER)) { + case XC_LAPLACE: + call rg_xlaplace (Memr[ibuf], ncols, nlines, 1.0) + default: + ; + } + + # Load the image data into the FFT. + call rg_iload (Memr[ibuf], ncols, nlines, Memr[fft], nxfft, nyfft) + call mfree (ibuf, TY_REAL) + + # Normalize the data. + call rg_fnorm (Memr[fft], nrcols, nrlines, nxfft, nyfft) + + # Compute the cross-correlation function. + call rg_fftcor (Memr[fft], nxfft, nyfft) + + # Allocate space for the correlation function. + if (rg_xstatp (xc, XCOR) == NULL) { + call malloc (xcor, xwindow * ywindow, TY_REAL) + call rg_xsetp (xc, XCOR, xcor) + } else { + xcor = rg_xstatp (xc, XCOR) + call realloc (xcor, xwindow * ywindow, TY_REAL) + call rg_xsetp (xc, XCOR, xcor) + } + + # Move the valid lags into the crosscorrelation array + call rg_movexr (Memr[fft], nxfft, nyfft, Memr[xcor], xwindow, ywindow) + + # Free space. + call mfree (fft, TY_REAL) + + stat = OK + +nextregion_ + + call sfree (sp) + if (stat == ERR) + return (ERR) + else + return (OK) +end + + +# RG_XIMGET -- Fill a buffer from a specified region of the image. + +pointer procedure rg_ximget (im, c1, c2, l1, l2) + +pointer im #I pointer to the iraf image +int c1, c2 #I column limits in the input image +int l1, l2 #I line limits in the input image + +int i, ncols, nlines, npts +pointer ptr, index, buf +pointer imgs1r(), imgs2r() + +begin + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + npts = ncols * nlines + call malloc (ptr, npts, TY_REAL) + + index = ptr + do i = l1, l2 { + if (IM_NDIM(im) == 1) + buf = imgs1r (im, c1, c2) + else + buf = imgs2r (im, c1, c2, i, i) + call amovr (Memr[buf], Memr[index], ncols) + index = index + ncols + } + + return (ptr) +end + + +# RG_XLAPLACE -- Compute the Laplacian of an image subraster in place. + +procedure rg_xlaplace (data, nx, ny, rho) + +real data[nx,ARB] #I the input array +int nx, ny #I the size of the input/output data array +real rho #I the pixel to pixel correlation factor + +int i, inline, outline, nxk, nyk, nxc +pointer sp, lineptrs, ptr +real rhosq, kernel[3,3] +data nxk /3/, nyk /3/ + +begin + # Define the kernel. + rhosq = rho * rho + kernel[1,1] = rhosq + kernel[2,1] = -rho * (1.0 + rhosq) + kernel[3,1] = rhosq + kernel[1,2] = -rho * (1.0 + rhosq) + kernel[2,2] = (1.0 + rhosq) * (1 + rhosq) + kernel[3,2] = -rho * (1.0 + rhosq) + kernel[1,3] = rhosq + kernel[2,3] = -rho * (1.0 + rhosq) + kernel[3,3] = rhosq + + # Set up an array of line pointers. + call smark (sp) + call salloc (lineptrs, nyk, TY_POINTER) + + # Allocate working space. + nxc = nx + 2 * (nxk / 2) + do i = 1, nyk + call salloc (Memi[lineptrs+i-1], nxc, TY_REAL) + + inline = 1 - nyk / 2 + do i = 1, nyk - 1 { + if (inline < 1) { + call amovr (data[1,1], Memr[Memi[lineptrs+i]+nxk/2], nx) + Memr[Memi[lineptrs+i]] = data[1,1] + Memr[Memi[lineptrs+i]+nxc-1] = data[nx,1] + } else { + call amovr (data[1,i-1], Memr[Memi[lineptrs+i]+nxk/2], nx) + Memr[Memi[lineptrs+i]] = data[1,i-1] + Memr[Memi[lineptrs+i]+nxc-1] = data[nx,i-1] + } + inline = inline + 1 + } + + # Generate the output image line by line + do outline = 1, ny { + + # Scroll the input buffers + ptr = Memi[lineptrs] + do i = 1, nyk - 1 + Memi[lineptrs+i-1] = Memi[lineptrs+i] + Memi[lineptrs+nyk-1] = ptr + + # Read in new image line + if (inline > ny) { + call amovr (data[1,ny], Memr[Memi[lineptrs+nyk-1]+nxk/2], + nx) + Memr[Memi[lineptrs+nyk-1]] = data[1,ny] + Memr[Memi[lineptrs+nyk-1]+nxc-1] = data[nx,ny] + } else { + call amovr (data[1,inline], Memr[Memi[lineptrs+nyk-1]+nxk/2], + nx) + Memr[Memi[lineptrs+nyk-1]] = data[1,inline] + Memr[Memi[lineptrs+nyk-1]+nxc-1] = data[nx,inline] + } + + # Generate output image line + call aclrr (data[1,outline], nx) + do i = 1, nyk + call acnvr (Memr[Memi[lineptrs+i-1]], data[1,outline], nx, + kernel[1,i], nxk) + + inline = inline + 1 + } + + # Free the image buffer pointers + call sfree (sp) +end + + +# RG_XCONV -- Compute the cross-correlation function directly in the spatial +# domain. + +procedure rg_xconv (ref, nrcols, nrlines, image, ncols, nlines, xcor, xwindow, + ywindow) + +real ref[nrcols,nrlines] #I the input reference subraster +int nrcols, nrlines #I size of the reference subraster +real image[ncols,nlines] #I the input image subraster +int ncols, nlines #I size of the image subraster +real xcor[xwindow,ywindow] #O the output cross-correlation function +int xwindow, ywindow #I size of the cross-correlation function + +int lagx, lagy, i, j +real meanr, facr, meani, faci, sum +real asumr() +#real cxmin, cxmax + +begin + meanr = asumr (ref, nrcols * nrlines) / (nrcols * nrlines) + facr = 0.0 + do j = 1, nrlines { + do i = 1, nrcols + facr = facr + (ref[i,j] - meanr) ** 2 + } + if (facr <= 0.0) + facr = 1.0 + else + facr = sqrt (facr) + + do lagy = 1, ywindow { + do lagx = 1, xwindow { + meani = 0.0 + do j = 1, nrlines { + do i = 1, nrcols + meani = meani + image[i+lagx-1,j+lagy-1] + } + meani = meani / (nrcols * nrlines) + faci = 0.0 + sum = 0.0 + do j = 1, nrlines { + do i = 1, nrcols { + faci = faci + (image[i+lagx-1,j+lagy-1] - meani) ** 2 + sum = sum + (ref[i,j] - meanr) * + (image[i+lagx-1,j+lagy-1] - meani) + } + } + if (faci <= 0.0) + faci = 1.0 + else + faci = sqrt (faci) + xcor[lagx,lagy] = sum / facr / faci + } + } +end + + +# RG_XDIFF -- Compute the error function at each of several templates. + +procedure rg_xdiff (ref, nrcols, nrlines, image, ncols, nlines, xcor, xwindow, + ywindow) + +real ref[nrcols,nrlines] #I reference subraste +int nrcols, nrlines #I size of the reference subraster +real image[ncols,nlines] #I image subraster +int ncols, nlines #I size of image subraster +real xcor[xwindow,ywindow] #O crosscorrelation function +int xwindow, ywindow #I size of correlation function + +int lagx, lagy, i, j +real meanr, meani, sum, cormin, cormax +real asumr() + + +begin + meanr = asumr (ref, nrcols * nrlines) / (nrcols * nrlines) + do lagy = 1, ywindow { + do lagx = 1, xwindow { + meani = 0.0 + do j = 1, nrlines { + do i = 1, nrcols + meani = meani + image[i+lagx-1,j+lagy-1] + } + meani = meani / (nrcols * nrlines) + sum = 0.0 + do j = 1, nrlines { + do i = 1, nrcols { + sum = sum + abs ((ref[i,j] - meanr) - + (image[i+lagx-1,j+lagy-1] - meani)) + } + } + xcor[lagx,lagy] = sum + } + } + + call alimr (xcor, xwindow * ywindow, cormin, cormax) + call adivkr (xcor, cormax, xcor, xwindow * ywindow) + call asubkr (xcor, 1.0, xcor, xwindow * ywindow) + call anegr (xcor, xcor, xwindow * ywindow) +end + diff --git a/pkg/images/immatch/src/xregister/rgxdbio.x b/pkg/images/immatch/src/xregister/rgxdbio.x new file mode 100644 index 00000000..3e197636 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxdbio.x @@ -0,0 +1,290 @@ +include "xregister.h" + +# RG_XWREC -- Procedure to write out the whole record. + +procedure rg_xwrec (db, dformat, xc) + +pointer db #I pointer to the database file +int dformat #I is the shifts file in database format +pointer xc #I pointer to the cross correlation structure + +int i, nregions, ngood, c1, c2, l1, l2, xlag, ylag +pointer sp, image, prc1, prc2, prl1, prl2, pxshift, pyshift +real xin, yin, xout, yout, xavshift, yavshift +int rg_xstati() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + + # Write the header record. + if (dformat == YES) + call rg_xdbparams (db, xc) + + # Fetch the pointers to the columns. + prc1 = rg_xstatp (xc, RC1) + prc2 = rg_xstatp (xc, RC2) + prl1 = rg_xstatp (xc, RL1) + prl2 = rg_xstatp (xc, RL2) + pxshift = rg_xstatp (xc, XSHIFTS) + pyshift = rg_xstatp (xc, YSHIFTS) + nregions = rg_xstati (xc, NREGIONS) + + xavshift = 0.0 + yavshift = 0.0 + ngood = 0 + do i = 1, nregions { + + xin = (Memi[prc1+i-1] + Memi[prc2+i-1]) / 2.0 + yin = (Memi[prl1+i-1] + Memi[prl2+i-1]) / 2.0 + if (rg_xstati (xc, NREFPTS) > 0) { + call rg_etransform (xc, xin, yin, xout, yout) + xlag = xout - xin + ylag = yout - yin + } else { + xlag = rg_xstati (xc, XLAG) + ylag = rg_xstati (xc, YLAG) + } + c1 = Memi[prc1+i-1] + xlag + c2 = Memi[prc2+i-1] + xlag + l1 = Memi[prl1+i-1] + ylag + l2 = Memi[prl2+i-1] + ylag + + if (IS_INDEFR(Memr[pxshift+i-1]) || IS_INDEFR(Memr[pyshift+i-1])) { + if (dformat == YES) + call rg_xdbshiftr (db, Memi[prc1+i-1], Memi[prc2+i-1], + Memi[prl1+i-1], Memi[prl2+i-1], c1, c2, l1, l2, + INDEFR, INDEFR) + } else { + if (dformat == YES) + call rg_xdbshiftr (db, Memi[prc1+i-1], Memi[prc2+i-1], + Memi[prl1+i-1], Memi[prl2+i-1], c1, c2, l1, l2, + Memr[pxshift+i-1], Memr[pyshift+i-1]) + ngood = ngood + 1 + xavshift = xavshift + Memr[pxshift+i-1] + yavshift = yavshift + Memr[pyshift+i-1] + } + } + + # Compute the average shift. + if (ngood <= 0) { + xavshift = 0.0 + yavshift = 0.0 + } else { + xavshift = xavshift / ngood + yavshift = yavshift / ngood + } + call rg_xsetr (xc, TXSHIFT, xavshift) + call rg_xsetr (xc, TYSHIFT, yavshift) + + if (dformat == YES) + call rg_xdbshift (db, xc) + else { + call rg_xstats (xc, IMAGE, Memc[image], SZ_FNAME) + call fprintf (db, "%s %g %g\n") + call pargstr (Memc[image]) + call pargr (xavshift) + call pargr (yavshift) + } + + call sfree (sp) +end + + +# RG_XDBPARAMS -- Write the cross-correlation parameters to the database file. + +procedure rg_xdbparams (db, xc) + +pointer db #I pointer to the database file +pointer xc #I pointer to the cross-correlation structure + +pointer sp, str +int rg_xstati() +#real rg_xstatr() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Write out the time record was written. + call dtput (db, "\n") + call dtptime (db) + + # Write out the record name. + call rg_xstats (xc, RECORD, Memc[str], SZ_FNAME) + call dtput (db, "begin\t%s\n") + call pargstr (Memc[str]) + + # Write the image names. + call rg_xstats (xc, IMAGE, Memc[str], SZ_FNAME) + call dtput (db, "\t%s\t\t%s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_FNAME) + call dtput (db, "\t%s\t%s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str]) + + call dtput (db, "\t%s\t%d\n") + call pargstr (KY_NREGIONS) + call pargi (rg_xstati (xc, NREGIONS)) + + call sfree (sp) +end + + +# RG_XWREG -- Write out the results for each region individually into +# the shifts file. + +procedure rg_xwreg (db, xc) + +pointer db #I pointer to the database file +pointer xc #I pointer to the cross-correlation structure + +int i, nregions, c1, c2, l1, l2, xlag, ylag +pointer prc1, prc2, prl1, prl2, pxshift, pyshift +real xin, yin, xout, yout +int rg_xstati() +pointer rg_xstatp() + +begin + # Fetch the regions pointers. + prc1 = rg_xstatp (xc, RC1) + prc2 = rg_xstatp (xc, RC2) + prl1 = rg_xstatp (xc, RL1) + prl2 = rg_xstatp (xc, RL2) + pxshift = rg_xstatp (xc, XSHIFTS) + pyshift = rg_xstatp (xc, YSHIFTS) + nregions = rg_xstati (xc, NREGIONS) + + # Write out the reference image region(s) and the equivalent + # input image regions. + do i = 1, nregions { + + xin = (Memi[prc1+i-1] + Memi[prc2+i-1]) / 2.0 + yin = (Memi[prl1+i-1] + Memi[prl2+i-1]) / 2.0 + if (rg_xstati (xc, NREFPTS) > 0) { + call rg_etransform (xc, xin, yin, xout, yout) + xlag = xout - xin + ylag = yout - yin + } else { + xlag = rg_xstati (xc, XLAG) + ylag = rg_xstati (xc, YLAG) + } + c1 = Memi[prc1+i-1] + xlag + c2 = Memi[prc2+i-1] + xlag + l1 = Memi[prl1+i-1] + ylag + l2 = Memi[prl2+i-1] + ylag + + if (IS_INDEFR(Memr[pxshift+i-1]) || IS_INDEFR(Memr[pyshift+i-1])) + call rg_xdbshiftr (db, Memi[prc1+i-1], Memi[prc2+i-1], + Memi[prl1+i-1], Memi[prl2+i-1], c1, c2, l1, l2, + INDEFR, INDEFR) + else + call rg_xdbshiftr (db, Memi[prc1+i-1], Memi[prc2+i-1], + Memi[prl1+i-1], Memi[prl2+i-1], c1, c2, l1, l2, + Memr[pxshift+i-1], Memr[pyshift+i-1]) + } +end + + +# RG_XDBSHIFTR -- Write out the reference image section, input image +# section and x and y shifts for each region. + +procedure rg_xdbshiftr (db, rc1, rc2, rl1, rl2, c1, c2, l1, l2, xshift, yshift) + +pointer db #I pointer to the database file +int rc1, rc2 #I reference region column limits +int rl1, rl2 #I reference region line limits +int c1, c2 #I image region column limits +int l1, l2 #I image region line limits +real xshift #I x shift +real yshift #I y shift + +begin + call dtput (db,"\t[%d:%d,%d:%d]\t[%d:%d,%d:%d]\t%g\t%g\n") + call pargi (rc1) + call pargi (rc2) + call pargi (rl1) + call pargi (rl2) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call pargr (xshift) + call pargr (yshift) +end + + +# RG_XDBSHIFT -- Write the average shifts to the shifts database. + +procedure rg_xdbshift (db, xc) + +pointer db #I pointer to text database file +pointer xc #I pointer to the cross-correlation structure + +real rg_xstatr() + +begin + call dtput (db, "\t%s\t\t%g\n") + call pargstr (KY_TXSHIFT) + call pargr (rg_xstatr (xc, TXSHIFT)) + call dtput (db, "\t%s\t\t%g\n") + call pargstr (KY_TYSHIFT) + call pargr (rg_xstatr (xc, TYSHIFT)) +end + + +# RG_XPWREC -- Print the computed shift for a region. + +procedure rg_xpwrec (xc, i) + +pointer xc #I pointer to the cross-correlation structure +int i #I the current region + +int xlag, ylag, c1, c2, l1, l2 +pointer prc1, prc2, prl1, prl2 +real xin, yin, rxlag, rylag +int rg_xstati() +pointer rg_xstatp() + +begin + # Fetch the pointers to the reference regions. + prc1 = rg_xstatp (xc, RC1) + prc2 = rg_xstatp (xc, RC2) + prl1 = rg_xstatp (xc, RL1) + prl2 = rg_xstatp (xc, RL2) + + # Transform the reference region to the input region. + xin = (Memi[prc1+i-1] + Memi[prc2+i-1]) / 2.0 + yin = (Memi[prl1+i-1] + Memi[prl2+i-1]) / 2.0 + if (rg_xstati (xc, NREFPTS) > 0) { + call rg_etransform (xc, xin, yin, rxlag, rylag) + xlag = rxlag - xin + ylag = rylag - yin + } else { + xlag = rg_xstati (xc, XLAG) + ylag = rg_xstati (xc, YLAG) + } + + c1 = Memi[prc1+i-1] + xlag + c2 = Memi[prc2+i-1] + xlag + l1 = Memi[prl1+i-1] + ylag + l2 = Memi[prl2+i-1] + ylag + + # Print the results. + call printf ("Region %d: [%d:%d,%d:%d] [%d:%d,%d:%d] %g %g\n") + call pargi (i) + call pargi (Memi[prc1+i-1]) + call pargi (Memi[prc2+i-1]) + call pargi (Memi[prl1+i-1]) + call pargi (Memi[prl2+i-1]) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call pargr (Memr[rg_xstatp(xc,XSHIFTS)+i-1]) + call pargr (Memr[rg_xstatp(xc,YSHIFTS)+i-1]) +end diff --git a/pkg/images/immatch/src/xregister/rgxfft.x b/pkg/images/immatch/src/xregister/rgxfft.x new file mode 100644 index 00000000..8847cf56 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxfft.x @@ -0,0 +1,179 @@ +# RG_FFTCOR -- Compute the FFT of the reference and image data, take their +# product, and compute the inverse transform to get the cross-correlation +# function. The reference and input image are loaded into alternate memory +# locations. + +procedure rg_fftcor (fft, nxfft nyfft) + +real fft[ARB] #I/O array to be fft'd +int nxfft, nyfft #I dimensions of the fft + +pointer sp, dim + +begin + call smark (sp) + call salloc (dim, 2, TY_INT) + + # Fourier transform the two arrays. + Memi[dim] = nxfft + Memi[dim+1] = nyfft + if (Memi[dim+1] == 1) + call rg_fourn (fft, Memi[dim], 1, 1) + else + call rg_fourn (fft, Memi[dim], 2, 1) + + # Compute the product of the two transforms. + call rg_mulfft (fft, fft, 2 * nxfft, nyfft) + + # Shift the array to center the transform. + call rg_fshift (fft, fft, 2 * nxfft, nyfft) + + # Normalize the transform. + call adivkr (fft, real (nxfft * nyfft), fft, 2 * nxfft * nyfft) + + # Compute the inverse transform. + if (Memi[dim+1] == 1) + call rg_fourn (fft, Memi[dim], 1, -1) + else + call rg_fourn (fft, Memi[dim], 2, -1) + + call sfree (sp) +end + + +# RG_MULFFT -- Unpack the two individual ffts and compute their product. + +procedure rg_mulfft (fft1, fft2, nxfft, nyfft) + +real fft1[nxfft,nyfft] #I array containing 2 ffts of 2 real functions +real fft2[nxfft,nyfft] #O fft of correlation function +int nxfft, nyfft #I dimensions of fft + +int i,j, nxd2p2, nxp2, nxp3, nyd2p1, nyp2 +real c1, c2, h1r, h1i, h2r, h2i + +begin + c1 = 0.5 + c2 = -0.5 + + nxd2p2 = nxfft / 2 + 2 + nxp2 = nxfft + 2 + nxp3 = nxfft + 3 + nyd2p1 = nyfft / 2 + 1 + nyp2 = nyfft + 2 + + # Compute the 0 frequency point. + h1r = fft1[1,1] + h1i = 0.0 + h2r = fft1[2,1] + h2i = 0.0 + fft2[1,1] = h1r * h2r + fft2[2,1] = 0.0 + + # Compute the x axis points. + do i = 3, nxd2p2, 2 { + h2r = c1 * (fft1[i,1] + fft1[nxp2-i,1]) + h2i = c1 * (fft1[i+1,1] - fft1[nxp3-i,1]) + h1r = -c2 * (fft1[i+1,1] + fft1[nxp3-i,1]) + h1i = c2 * (fft1[i,1] - fft1[nxp2-i,1]) + fft2[i,1] = (h1r * h2r + h1i * h2i) + fft2[i+1,1] = (h1i * h2r - h2i * h1r) + fft2[nxp2-i,1] = fft2[i,1] + fft2[nxp3-i,1] = - fft2[i+1,1] + } + + # Quit if the transform is 1D. + if (nyfft < 2) + return + + # Compute the y axis points. + do i = 2, nyd2p1 { + h2r = c1 * (fft1[1,i] + fft1[1, nyp2-i]) + h2i = c1 * (fft1[2,i] - fft1[2,nyp2-i]) + h1r = -c2 * (fft1[2,i] + fft1[2,nyp2-i]) + h1i = c2 * (fft1[1,i] - fft1[1,nyp2-i]) + fft2[1,i] = (h1r * h2r + h1i * h2i) + fft2[2,i] = (h1i * h2r - h2i * h1r) + fft2[1,nyp2-i] = fft2[1,i] + fft2[2,nyp2-i] = - fft2[2,i] + } + + # Compute along the axis of symmetry. + do i = 3, nxd2p2, 2 { + h2r = c1 * (fft1[i,nyd2p1] + fft1[nxp2-i, nyd2p1]) + h2i = c1 * (fft1[i+1,nyd2p1] - fft1[nxp3-i,nyd2p1]) + h1r = -c2 * (fft1[i+1,nyd2p1] + fft1[nxp3-i,nyd2p1]) + h1i = c2 * (fft1[i,nyd2p1] - fft1[nxp2-i,nyd2p1]) + fft2[i,nyd2p1] = (h1r * h2r + h1i * h2i) + fft2[i+1,nyd2p1] = (h1i * h2r - h2i * h1r) + fft2[nxp2-i,nyd2p1] = fft2[i,nyd2p1] + fft2[nxp3-i,nyd2p1] = - fft2[i+1,nyd2p1] + } + + # Compute the remainder of the transform. + do j = 2, nyd2p1 - 1 { + do i = 3, nxfft, 2 { + h2r = c1 * (fft1[i,j] + fft1[nxp2-i, nyp2-j]) + h2i = c1 * (fft1[i+1,j] - fft1[nxp3-i,nyp2-j]) + h1r = -c2 * (fft1[i+1,j] + fft1[nxp3-i,nyp2-j]) + h1i = c2 * (fft1[i,j] - fft1[nxp2-i,nyp2-j]) + fft2[i,j] = (h1r * h2r + h1i * h2i) + fft2[i+1,j] = (h1i * h2r - h2i * h1r) + fft2[nxp2-i,nyp2-j] = fft2[i,j] + fft2[nxp3-i,nyp2-j] = - fft2[i+1,j] + } + } +end + + +# RG_FNORM -- Normalize the reference and image data before computing +# the fft's. + +procedure rg_fnorm (array, ncols, nlines, nxfft, nyfft) + +real array[ARB] #I/O the input/output data array +int ncols, nlines #I dimensions of the input data array +int nxfft, nyfft #I dimensions of the fft + +int i, j, index +real sumr, sumi, meanr, meani + +begin + # Compute the mean. + sumr = 0.0 + sumi = 0.0 + index = 0 + do j = 1, nlines { + do i = 1, ncols { + sumr = sumr + array[index+2*i-1] + sumi = sumi + array[index+2*i] + } + index = index + 2 * nxfft + } + meanr = sumr / (ncols * nlines) + meani = sumi / (ncols * nlines) + + # Compute the sigma. + sumr = 0.0 + sumi = 0.0 + index = 0 + do j = 1, nlines { + do i = 1, ncols { + sumr = sumr + (array[index+2*i-1] - meanr) ** 2 + sumi = sumi + (array[index+2*i] - meani) ** 2 + } + index = index + 2 * nxfft + } + sumr = sqrt (sumr) + sumi = sqrt (sumi) + + # Normalize the data. + index = 0 + do j = 1, nlines { + do i = 1, ncols { + array[index+2*i-1] = (array[index+2*i-1] - meanr) / sumr + array[index+2*i] = (array[index+2*i] - meani) / sumi + } + index = index + 2 * nxfft + } +end diff --git a/pkg/images/immatch/src/xregister/rgxfit.x b/pkg/images/immatch/src/xregister/rgxfit.x new file mode 100644 index 00000000..34e6398c --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxfit.x @@ -0,0 +1,814 @@ +include <mach.h> +include <math/iminterp.h> +include <math/nlfit.h> +include "xregister.h" + +define NL_MAXITER 10 +define NL_TOL 0.001 + +# RG_FIT -- Fit the peak of the cross-correlation function using one of the +# fitting functions. + +procedure rg_fit (xc, nreg, gd, xshift, yshift) + +pointer xc #I the pointer to the cross-corrrelation structure +int nreg #I the current region +pointer gd #I the pointer to the graphics stream +real xshift, yshift #O the computed shifts + +int nrlines, xwindow, ywindow, xcbox, ycbox, xlag, ylag +real xin, yin, xout, yout +int rg_xstati() +pointer rg_xstatp() + +begin + # Check the window and centering box sizes. + nrlines = Memi[rg_xstatp(xc,RL2)+nreg-1] - + Memi[rg_xstatp(xc,RL1)+nreg-1] + 1 + xwindow = rg_xstati (xc, XWINDOW) + if (nrlines == 1) + ywindow = 1 + else + ywindow = rg_xstati (xc, YWINDOW) + xcbox = rg_xstati (xc, XCBOX) + if (nrlines == 1) + ycbox = 1 + else + ycbox = rg_xstati (xc, YCBOX) + + # Do the centering. + switch (rg_xstati (xc, PFUNC)) { + case XC_PNONE: + call rg_maxmin (Memr[rg_xstatp(xc,XCOR)], xwindow, ywindow, + xshift, yshift) + case XC_CENTROID: + call rg_imean (Memr[rg_xstatp(xc,XCOR)], xwindow, + ywindow, xcbox, ycbox, xshift, yshift) + case XC_SAWTOOTH: + call rg_sawtooth (Memr[rg_xstatp(xc,XCOR)], xwindow, + ywindow, xcbox, ycbox, xshift, yshift) + case XC_PARABOLA: + call rg_iparabolic (Memr[rg_xstatp(xc,XCOR)], xwindow, ywindow, + xcbox, ycbox, xshift, yshift) + case XC_MARK: + if (gd == NULL) + call rg_imean (Memr[rg_xstatp(xc,XCOR)], xwindow, + ywindow, xcbox, ycbox, xshift, yshift) + else + call rg_xmkpeak (gd, xwindow, ywindow, xshift, yshift) + default: + call rg_imean (Memr[rg_xstatp(xc,XCOR)], xwindow, ywindow, + xcbox, ycbox, xshift, yshift) + } + + # Store the shifts. + if (rg_xstati (xc, NREFPTS) > 0) { + xin = (Memi[rg_xstatp(xc,RC1)+nreg-1] + + Memi[rg_xstatp(xc,RC2)+nreg-1]) / 2.0 + yin = (Memi[rg_xstatp(xc,RL1)+nreg-1] + + Memi[rg_xstatp(xc,RL2)+nreg-1]) / 2.0 + call rg_etransform (xc, xin, yin, xout, yout) + xlag = xout - xin + ylag = yout - yin + } else { + xlag = rg_xstati (xc, XLAG) + ylag = rg_xstati (xc, YLAG) + } + xshift = - (xshift + xlag) + yshift = - (yshift + ylag) + Memr[rg_xstatp(xc,XSHIFTS)+nreg-1] = xshift + Memr[rg_xstatp(xc,YSHIFTS)+nreg-1] = yshift +end + + +# RG_MAXMIN -- Procedure to compute the peak of the cross-correlation function +# by determining the maximum point. + +procedure rg_maxmin (xcor, xwindow, ywindow, xshift, yshift) + +real xcor[xwindow,ywindow] #I the cross-correlation function +int xwindow, ywindow #I dimensions of cross-correlation function +real xshift, yshift #O x and shift of the peak + +int xindex, yindex + +begin + # Locate the maximum point. + call rg_alim2r (xcor, xwindow, ywindow, xindex, yindex) + xshift = xindex - (1.0 + xwindow) / 2.0 + yshift = yindex - (1.0 + ywindow) / 2.0 +end + + +# RG_IMEAN -- Compute the peak of the cross-correlation function using the +# intensity weighted mean of the marginal distributions in x and y. + +procedure rg_imean (xcor, xwindow, ywindow, xcbox, ycbox, xshift, yshift) + +real xcor[xwindow,ARB] #I the cross-correlation function +int xwindow, ywindow #I dimensions of the cross-correlation function +int xcbox, ycbox #I dimensions of the centering box +real xshift, yshift #O x and y shift of cross-correlation function + +int xindex, yindex, xlo, xhi, ylo, yhi, nx, ny +pointer sp, xmarg, ymarg + +begin + call smark (sp) + call salloc (xmarg, xcbox, TY_REAL) + call salloc (ymarg, ycbox, TY_REAL) + + # Locate the maximum point and normalize. + call rg_alim2r (xcor, xwindow, ywindow, xindex, yindex) + + # Compute the limits of the centering box. + xlo = max (1, xindex - xcbox / 2) + xhi = min (xwindow, xindex + xcbox / 2) + nx = xhi - xlo + 1 + ylo = max (1, yindex - ycbox / 2) + yhi = min (ywindow, yindex + ycbox / 2) + ny = yhi - ylo + 1 + + # Accumulate the marginals. + call rg_xmkmarg (xcor, xwindow, ywindow, xlo, xhi, ylo, yhi, + Memr[xmarg], Memr[ymarg]) + + # Compute the shifts. + call rg_centroid (Memr[xmarg], nx, xshift) + xshift = xshift + xlo - 1 - (1.0 + xwindow) / 2.0 + call rg_centroid (Memr[ymarg], ny, yshift) + yshift = yshift + ylo - 1 - (1.0 + ywindow) / 2.0 + + call sfree (sp) +end + + +# RG_IPARABOLIC -- Computer the peak of the cross-correlation function by +# doing parabolic interpolation around the peak. + +procedure rg_iparabolic (xcor, xwindow, ywindow, xcbox, ycbox, xshift, yshift) + +real xcor[xwindow,ARB] #I the cross-correlation function +int xwindow, ywindow #I dimensions of the cross-correlation fucntion +int xcbox, ycbox #I the dimensions of the centering box +real xshift, yshift #O the x and y shift of the peak + +int i, j, xindex, yindex, xlo, xhi, nx, ylo, yhi, ny +pointer sp, x, y, c, xfit, yfit + +begin + # Allocate working space. + call smark (sp) + call salloc (x, 3, TY_REAL) + call salloc (y, 3, TY_REAL) + call salloc (c, 3, TY_REAL) + call salloc (xfit, 3, TY_REAL) + call salloc (yfit, 3, TY_REAL) + + # Locate the maximum point. + call rg_alim2r (xcor, xwindow, ywindow, xindex, yindex) + + xlo = max (1, xindex - 1) + xhi = min (xwindow, xindex + 1) + nx = xhi - xlo + 1 + ylo = max (1, yindex - 1) + yhi = min (ywindow, yindex + 1) + ny = yhi - ylo + 1 + + # Initialize. + do i = 1, 3 + Memr[x+i-1] = i + + # Fit the x shift. + if (nx >= 3) { + do j = ylo, yhi { + do i = xlo, xhi + Memr[y+i-xlo] = xcor[i,j] + call rg_iparab (Memr[x], Memr[y], Memr[c]) + Memr[xfit+j-ylo] = - Memr[c+1] / (2.0 * Memr[c+2]) + Memr[yfit+j-ylo] = Memr[c] + Memr[c+1] * Memr[xfit+j-ylo] + + Memr[c+2] * Memr[xfit+j-ylo] ** 2 + } + if (ny >= 3) + call rg_iparab (Memr[xfit], Memr[yfit], Memr[c]) + xshift = - Memr[c+1] / (2.0 * Memr[c+2]) + } else + xshift = xindex - xlo + 1 + + # Fit the y shift. + if (ny >= 3) { + do i = xlo, xhi { + do j = ylo, yhi + Memr[y+j-ylo] = xcor[i,j] + call rg_iparab (Memr[x], Memr[y], Memr[c]) + Memr[xfit+i-xlo] = - Memr[c+1] / (2.0 * Memr[c+2]) + Memr[yfit+i-xlo] = Memr[c] + Memr[c+1] * Memr[xfit+i-xlo] + + Memr[c+2] * Memr[xfit+i-xlo] ** 2 + } + call rg_iparab (Memr[xfit], Memr[yfit], Memr[c]) + yshift = - Memr[c+1] / (2.0 * Memr[c+2]) + } else + yshift = yindex - ylo + 1 + + xshift = xshift + xlo - 1 - (1.0 + xwindow) / 2.0 + yshift = yshift + ylo - 1 - (1.0 + ywindow) / 2.0 + + call sfree (sp) +end + + +define NPARS_PARABOLA 3 + +# RG_PARABOLIC -- Compute the peak of the cross-correlation function by fitting +# a parabola to the peak. + +procedure rg_parabolic (xcor, xwindow, ywindow, xcbox, ycbox, xshift, yshift) + +real xcor[xwindow,ARB] #I the cross-correlation function +int xwindow, ywindow #I dimensions of the cross-correlation fucntion +int xcbox, ycbox #I the dimensions of the centering box +real xshift, yshift #O the x and y shift of the peak + +extern rg_polyfit, rg_dpolyfit +int i, xindex, yindex, xlo, xhi, ylo, yhi, nx, ny, npar, ier +pointer sp, x, w, xmarg, ymarg, params, eparams, list, nl +int locpr() + +begin + call smark (sp) + call salloc (x, max (xwindow, ywindow), TY_REAL) + call salloc (w, max (xwindow, ywindow), TY_REAL) + call salloc (xmarg, max (xwindow, ywindow), TY_REAL) + call salloc (ymarg, max (xwindow, ywindow), TY_REAL) + call salloc (params, NPARS_PARABOLA, TY_REAL) + call salloc (eparams, NPARS_PARABOLA, TY_REAL) + call salloc (list, NPARS_PARABOLA, TY_INT) + + # Locate the maximum point. + call rg_alim2r (xcor, xwindow, ywindow, xindex, yindex) + + xlo = max (1, xindex - xcbox / 2) + xhi = min (xwindow, xindex + xcbox / 2) + nx = xhi - xlo + 1 + ylo = max (1, yindex - ycbox / 2) + yhi = min (ywindow, yindex + ycbox / 2) + ny = yhi - ylo + 1 + + # Accumulate the marginals. + call rg_xmkmarg (xcor, xwindow, ywindow, xlo, xhi, ylo, yhi, + Memr[xmarg], Memr[ymarg]) + + # Compute the x shift. + if (nx >= 3) { + do i = 1, nx + Memr[x+i-1] = i + do i = 1, nx + Memr[w+i-1] = Memr[xmarg+i-1] + call rg_iparab (Memr[x+xindex-xlo-1], Memr[xmarg+xindex-xlo-1], + Memr[params]) + xshift = - Memr[params+1] / (2.0 * Memr[params+2]) + call eprintf ("\txshift=%g\n") + call pargr (xshift) + call aclrr (Memr[eparams], NPARS_PARABOLA) + do i = 1, NPARS_PARABOLA + Memi[list+i-1] = i + call nlinitr (nl, locpr (rg_polyfit), locpr (rg_dpolyfit), + Memr[params], Memr[eparams], NPARS_PARABOLA, Memi[list], + NPARS_PARABOLA, .0001, NL_MAXITER) + call nlfitr (nl, Memr[x], Memr[xmarg], Memr[w], nx, 1, WTS_USER, + ier) + call nlvectorr (nl, Memr[x], Memr[w], nx, 1) + do i = 1, nx { + call eprintf ("x=%g y=%g yfit=%g\n") + call pargr (Memr[x+i-1]) + call pargr (Memr[xmarg+i-1]) + call pargr (Memr[w+i-1]) + } + if (ier != NO_DEG_FREEDOM) { + call nlpgetr (nl, Memr[params], npar) + if (Memr[params+2] != 0) + xshift = - Memr[params+1] / (2.0 * Memr[params+2]) + else + xshift = xindex - xlo + 1 + } else + xshift = xindex - xlo + 1 + call nlfreer (nl) + } else + xshift = xindex - xlo + 1 + + # Compute the y shift. + if (ny >= 3) { + do i = 1, ny + Memr[x+i-1] = i + do i = 1, ny + Memr[w+i-1] = Memr[ymarg+i-1] + call rg_iparab (Memr[x+yindex-ylo-1], Memr[ymarg+yindex-ylo-1], + Memr[params]) + yshift = - Memr[params+1] / (2.0 * Memr[params+2]) + call eprintf ("\tyshift=%g\n") + call pargr (yshift) + call aclrr (Memr[eparams], NPARS_PARABOLA) + do i = 1, NPARS_PARABOLA + Memi[list+i-1] = i + call nlinitr (nl, locpr (rg_polyfit), locpr (rg_dpolyfit), + Memr[params], Memr[eparams], NPARS_PARABOLA, Memi[list], + NPARS_PARABOLA, 0.0001, NL_MAXITER) + call nlfitr (nl, Memr[x], Memr[ymarg], Memr[w], ny, 1, WTS_USER, + ier) + call nlvectorr (nl, Memr[x], Memr[w], ny, 1) + do i = 1, ny { + call eprintf ("x=%g y=%g yfit=%g\n") + call pargr (Memr[x+i-1]) + call pargr (Memr[ymarg+i-1]) + call pargr (Memr[w+i-1]) + } + if (ier != NO_DEG_FREEDOM) { + call nlpgetr (nl, Memr[params], npar) + if (Memr[params+2] != 0) + yshift = -Memr[params+1] / (2.0 * Memr[params+2]) + else + yshift = yindex - ylo + 1 + } else + yshift = yindex - ylo + 1 + call nlfreer (nl) + } else + yshift = yindex - ylo + 1 + + xshift = xshift + xlo - 1 - (1.0 + xwindow) / 2.0 + yshift = yshift + ylo - 1 - (1.0 + ywindow) / 2.0 + + call sfree (sp) +end + +define EMISSION 1 # emission features +define ABSORPTION 2 # emission features + +# RG_SAWTOOTH -- Compute the the x and y centers using a sawtooth +# convolution function. + +procedure rg_sawtooth (xcor, xwindow, ywindow, xcbox, ycbox, xshift, yshift) + +real xcor[xwindow,ARB] #I the cross-correlation function +int xwindow, ywindow #I the dimensions of the cross-correlation +int xcbox, ycbox #I the dimensions of the centering box +real xshift, yshift #O the x and y shifts + +int i, j, xindex, yindex, xlo, xhi, ylo, yhi, nx, ny +pointer sp, data, xfit, yfit, yclean +real ic + +begin + call smark (sp) + call salloc (data, max (xwindow, ywindow), TY_REAL) + call salloc (xfit, max (xwindow, ywindow), TY_REAL) + call salloc (yfit, max (xwindow, ywindow), TY_REAL) + call salloc (yclean, max (xwindow, ywindow), TY_REAL) + + # Locate the maximum point and normalize. + call rg_alim2r (xcor, xwindow, ywindow, xindex, yindex) + + xlo = max (1, xindex - xcbox) + xhi = min (xwindow, xindex + xcbox) + nx = xhi - xlo + 1 + ylo = max (1, yindex - ycbox) + yhi = min (ywindow, yindex + ycbox) + ny = yhi - ylo + 1 + + # Compute the y shift. + if (ny >= 3) { + do j = ylo, yhi { + do i = xlo, xhi + Memr[data+i-xlo] = xcor[i,j] + call rg_x1dcenter (real (xindex - xlo + 1), Memr[data], nx, + Memr[xfit+j-ylo], Memr[yfit+j-ylo], real (nx / 2.0), + EMISSION, real (nx / 2.0), 0.0) + } + call arbpix (Memr[yfit], Memr[yclean], ny, II_SPLINE3, + II_BOUNDARYEXT) + call rg_x1dcenter (real (yindex - ylo + 1), Memr[yclean], ny, + yshift, ic, real (ny / 2.0), EMISSION, real (ny / 2.0), 0.0) + if (IS_INDEFR(yshift)) + yshift = yindex - ylo + 1 + } else + yshift = yindex - ylo + 1 + yshift = yshift + ylo - 1 - (1.0 + ywindow) / 2.0 + + # Compute the x shift. + if (nx >= 3) { + if (ny >= 3) { + do i = xlo, xhi { + do j = ylo, yhi + Memr[data+j-ylo] = xcor[i,j] + call rg_x1dcenter (real (yindex - ylo + 1), Memr[data], ny, + Memr[xfit+i-xlo], Memr[yfit+i-xlo], real (ny / 2.0), + EMISSION, real (ny / 2.0), 0.0) + } + call arbpix (Memr[yfit], Memr[yclean], nx, II_SPLINE3, + II_BOUNDARYEXT) + call rg_x1dcenter (real (xindex - xlo + 1), Memr[yclean], nx, + xshift, ic, real (nx / 2.0), EMISSION, real (nx / 2.0), 0.0) + } else { + call rg_x1dcenter (real (xindex - xlo + 1), xcor[xlo,1], nx, + xshift, ic, real (nx / 2.0), EMISSION, real (nx / 2.0), 0.0) + } + if (IS_INDEFR(xshift)) + xshift = xindex - xlo + 1 + } else + xshift = xindex - xlo + 1 + xshift = xshift + xlo - 1 - (1.0 + xwindow) / 2.0 + + call sfree (sp) +end + + +# RG_ALIM2R -- Determine the pixel position of the data maximum. + +procedure rg_alim2r (data, nx, ny, i, j) + +real data[nx,ARB] #I the input data +int nx, ny #I the dimensions of the input array +int i, j #O the indices of the maximum pixel + +int ii, jj +real datamax + +begin + datamax = -MAX_REAL + do jj = 1, ny { + do ii = 1, nx { + if (data[ii,jj] > datamax) { + datamax = data[ii,jj] + i = ii + j = jj + } + } + } +end + + +# RG_XMKMARG -- Acumulate the marginal arrays in x and y. + +procedure rg_xmkmarg (xcor, xwindow, ywindow, xlo, xhi, ylo, yhi, xmarg, + ymarg) + +real xcor[xwindow,ARB] #I the cross-correlation function +int xwindow, ywindow #I dimensions of cross-correlation function +int xlo, xhi #I the x limits for centering +int ylo, yhi #I the y limits for centering +real xmarg[ARB] #O the output x marginal array +real ymarg[ARB] #O the output y marginal array + +int i, j, index, nx, ny + +begin + nx = xhi - xlo + 1 + ny = yhi - ylo + 1 + + # Compute the x marginal. + index = 1 - xlo + do i = xlo, xhi { + xmarg[index+i] = 0.0 + do j = ylo, yhi + xmarg[index+i] = xmarg[index+i] + xcor[i,j] + } + + # Normalize the x marginal. + call adivkr (xmarg, real (ny), xmarg, nx) + + # Compute the y marginal. + index = 1 - ylo + do j = ylo, yhi { + ymarg[index+j] = 0.0 + do i = xlo, xhi + ymarg[index+j] = ymarg[index+j] + xcor[i,j] + } + + # Normalize the ymarginal. + call adivkr (ymarg, real (nx), ymarg, ny) +end + + +# RG_CENTROID -- Compute the intensity weighted maximum of an array. + +procedure rg_centroid (a, npts, shift) + +real a[ARB] #I the input array +int npts #I the number of points +real shift #O the position of the maximum + +int i +real mean, dif, sumi, sumix +bool fp_equalr() +real asumr() + +begin + sumi = 0.0 + sumix = 0.0 + mean = asumr (a, npts) / npts + + do i = 1, npts { + dif = a[i] + dif = a[i] - mean + if (dif < 0.0) + next + sumi = sumi + dif + sumix = sumix + i * dif + } + + if (fp_equalr (sumi, 0.0)) + shift = (1.0 + npts) / 2.0 + else + shift = sumix / sumi +end + + +define MIN_WIDTH 3. # minimum centering width +define EPSILON 0.001 # accuracy of centering +define EPSILON1 0.005 # tolerance for convergence check +define ITERATIONS 100 # maximum number of iterations +define MAX_DXCHECK 3 # look back for failed convergence +define INTERPTYPE II_SPLINE3 # image interpolation type + + +# RG_X1DCENTER -- Locate the center of a one dimensional feature. +# A value of INDEF is returned in the centering fails for any reason. +# This procedure just sets up the data and adjusts for emission or +# absorption features. The actual centering is done by C1D_CENTER. + +procedure rg_x1dcenter (x, data, npts, xc, ic, width, type, radius, threshold) + +real x #I initial guess +real data[npts] #I data points +int npts #I number of data points +real xc #O computed center +real ic #O intensity at computed center +real width #I feature width +int type #I feature type +real radius #I centering radius +real threshold #I minimum range in feature + +int x1, x2, nx +real a, b, rad, wid +pointer sp, data1 + +begin + # Check starting value. + if (IS_INDEF(x) || (x < 1) || (x > npts)) { + xc = INDEF + ic = INDEF + return + } + + # Set minimum width and error radius. The minimum in the error radius + # is for defining the data window. The user error radius is used to + # check for an error in the derived center at the end of the centering. + + wid = max (width, MIN_WIDTH) + rad = max (2., radius) + + # Determine the pixel value range around the initial center, including + # the width and error radius buffer. Check for a minimum range. + + x1 = max (1., x - wid / 2 - rad - wid) + x2 = min (real (npts), x + wid / 2 + rad + wid + 1) + nx = x2 - x1 + 1 + call alimr (data[x1], nx, a, b) + if (b - a < threshold) { + xc = INDEF + ic = INDEF + return + } + + # Allocate memory for the continuum subtracted data vector. The X + # range is just large enough to include the error radius and the + # half width. + + x1 = max (1., x - wid / 2 - rad) + x2 = min (real (npts), x + wid / 2 + rad + 1) + nx = x2 - x1 + 1 + + call smark (sp) + call salloc (data1, nx, TY_REAL) + call amovr (data[x1], Memr[data1], nx) + + # Make the centering data positive, subtract the continuum, and + # apply a threshold to eliminate noise spikes. + + switch (type) { + case EMISSION: + a = 0. + call asubkr (data[x1], a + threshold, Memr[data1], nx) + call amaxkr (Memr[data1], 0., Memr[data1], nx) + case ABSORPTION: + call anegr (data[x1], Memr[data1], nx) + call asubkr (Memr[data1], threshold - b, Memr[data1], nx) + call amaxkr (Memr[data1], 0., Memr[data1], nx) + default: + call error (0, "Unknown feature type") + } + + # Determine the center. + call rg_xcenter (x - x1 + 1, Memr[data1], nx, xc, ic, wid) + + # Check user centering error radius. + if (!IS_INDEF(xc)) { + xc = xc + x1 - 1 + if (abs (x - xc) > radius) { + xc = INDEF + ic = INDEF + } + } + + # Free memory and return the center position. + call sfree (sp) +end + + +# RG_XCENTER -- One dimensional centering algorithm. + +procedure rg_xcenter (x, data, npts, xc, ic, width) + +real x #I starting guess +int npts #I number of points in data vector +real data[npts] #I data vector +real xc #O computed xc +real ic #O computed intensity at xc +real width #I centering width + +int i, j, iteration, dxcheck +real hwidth, dx, dxabs, dxlast +real a, b, sum1, sum2, intgrl1, intgrl2 +pointer asi1, asi2, sp, data1 + +real asigrl(), asieval() + +define done_ 99 + +begin + # Find the nearest local maxima as the starting point. + # This is required because the threshold limit may have set + # large regions of the data to zero and without a gradient + # the centering will fail. + + i = x + for (i=x+.5; (i<npts) && (data[i]<=data[i+1]); i=i+1) + ; + for (j=x+.5; (j>1) && (data[j]<=data[j-1]); j=j-1) + ; + + if (i-x < x-j) + xc = i + else + xc = j + + # Check data range. + hwidth = width / 2 + if ((xc - hwidth < 1) || (xc + hwidth > npts)) { + xc = INDEF + ic = INDEF + return + } + + # Set interpolation functions. + call asiinit (asi1, INTERPTYPE) + call asiinit (asi2, INTERPTYPE) + call asifit (asi1, data, npts) + + # Allocate, compute, and interpolate the x*y values. + call smark (sp) + call salloc (data1, npts, TY_REAL) + do i = 1, npts + Memr[data1+i-1] = data[i] * i + call asifit (asi2, Memr[data1], npts) + call sfree (sp) + + # Iterate to find center. This loop exits when 1) the maximum + # number of iterations is reached, 2) the delta is less than + # the required accuracy (criterion for finding a center), 3) + # there is a problem in the computation, 4) successive steps + # continue to exceed the minimum delta. + + dxlast = 1. + do iteration = 1, ITERATIONS { + + # Triangle centering function. + a = xc - hwidth + b = xc - hwidth / 2 + intgrl1 = asigrl (asi1, a, b) + intgrl2 = asigrl (asi2, a, b) + sum1 = (xc - hwidth) * intgrl1 - intgrl2 + sum2 = -intgrl1 + a = b + b = xc + hwidth / 2 + intgrl1 = asigrl (asi1, a, b) + intgrl2 = asigrl (asi2, a, b) + sum1 = sum1 - xc * intgrl1 + intgrl2 + sum2 = sum2 + intgrl1 + a = b + b = xc + hwidth + intgrl1 = asigrl (asi1, a, b) + intgrl2 = asigrl (asi2, a, b) + sum1 = sum1 + (xc + hwidth) * intgrl1 - intgrl2 + sum2 = sum2 - intgrl1 + + # Return no center if sum2 is zero. + if (sum2 == 0.) + break + + # Limit dx change in one iteration to 1 pixel. + dx = max (-1., min (1., sum1 / abs (sum2))) + dxabs = abs (dx) + xc = xc + dx + ic = asieval (asi1, xc) + + # Check data range. Return no center if at edge of data. + if ((xc - hwidth < 1) || (xc + hwidth > npts)) + break + + # Convergence tests. + if (dxabs < EPSILON) + goto done_ + if (dxabs > dxlast + EPSILON1) { + dxcheck = dxcheck + 1 + if (dxcheck > MAX_DXCHECK) + break + } else { + dxcheck = 0 + dxlast = dxabs + } + } + + # If we get here then no center was found. + xc = INDEF + ic = INDEF + +done_ call asifree (asi1) + call asifree (asi2) +end + + +# RG_IPARAB -- Compute the coefficients of the parabola through three +# evenly spaced points. + +procedure rg_iparab (x, y, c) + +real x[NPARS_PARABOLA] #I input x values +real y[NPARS_PARABOLA] #I input y values +real c[NPARS_PARABOLA] #O computed coefficients + +begin + c[3] = (y[1]-y[2]) * (x[2]-x[3]) / (x[1]-x[2]) - (y[2]-y[3]) + c[3] = c[3] / ((x[1]**2-x[2]**2) * (x[2]-x[3]) / (x[1]-x[2]) - + (x[2]**2-x[3]**2)) + + c[2] = (y[1] - y[2]) - c[3] * (x[1]**2 - x[2]**2) + c[2] = c[2] / (x[1] - x[2]) + + c[1] = y[1] - c[2] * x[1] - c[3] * x[1]**2 +end + + +# RG_POLYFIT -- Evaluate an nth order polynomial. + +procedure rg_polyfit (x, nvars, p, np, z) + +real x #I position coordinate +int nvars #I number of variables +real p[ARB] #I coefficients of polynomial +int np #I number of parameters +real z #O function return + +int i +real r + +begin + r = 0.0 + do i = 2, np + r = r + x**(i-1) * p[i] + z = p[1] + r +end + + +# RG_DPOLYFIT -- Evaluate an nth order polynomial and its derivatives. + +procedure rg_dpolyfit (x, nvars, p, dp, np, z, der) + +real x #I position coordinate +int nvars #I number of variables +real p[ARB] #I coefficients of polynomial +real dp[ARB] #I parameter derivative increments +int np #I number of parameters +real z #O function value +real der[ARB] #O derivatives + +int i + +begin + der[1] = 1.0 + z = 0.0 + do i = 2, np { + der[i] = x ** (i-1) + z = z + x**(i-1) * p[i] + } + z = p[1] + z +end diff --git a/pkg/images/immatch/src/xregister/rgxgpars.x b/pkg/images/immatch/src/xregister/rgxgpars.x new file mode 100644 index 00000000..82943730 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxgpars.x @@ -0,0 +1,68 @@ +include "xregister.h" + +# RG_XGPARS -- Read in the XREGISTER task algorithm parameters. + +procedure rg_xgpars (xc) + +pointer xc #I pointer to the main structure + +int xlag, ylag, xwindow, ywindow, xcbox, ycbox +pointer sp, str +int clgwrd(), clgeti() +real clgetr() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Initialize the correlation structure. + call rg_xinit (xc, clgwrd ("correlation", Memc[str], SZ_LINE, + XC_CTYPES)) + + # Fetch the initial shift information. + xlag = clgeti ("xlag") + ylag = clgeti ("ylag") + call rg_xseti (xc, IXLAG, xlag) + call rg_xseti (xc, IYLAG, ylag) + call rg_xseti (xc, XLAG, xlag) + call rg_xseti (xc, YLAG, ylag) + call rg_xseti (xc, DXLAG, clgeti ("dxlag")) + call rg_xseti (xc, DYLAG, clgeti ("dylag")) + + # Get the background value computation parameters. + call rg_xseti (xc, BACKGRD, clgwrd ("background", Memc[str], SZ_LINE, + XC_BTYPES)) + call rg_xsets (xc, BSTRING, Memc[str]) + call rg_xseti (xc, BORDER, clgeti ("border")) + call rg_xsetr (xc, LOREJECT, clgetr ("loreject")) + call rg_xsetr (xc, HIREJECT, clgetr ("hireject")) + call rg_xsetr (xc, APODIZE, clgetr ("apodize")) + call rg_xseti (xc, FILTER, clgwrd ("filter", Memc[str], SZ_LINE, + XC_FTYPES)) + call rg_xsets (xc, FSTRING, Memc[str]) + + # Get the window parameters and force the window size to be odd. + xwindow = clgeti ("xwindow") + if (mod (xwindow,2) == 0) + xwindow = xwindow + 1 + call rg_xseti (xc, XWINDOW, xwindow) + ywindow = clgeti ("ywindow") + if (mod (ywindow,2) == 0) + ywindow = ywindow + 1 + call rg_xseti (xc, YWINDOW, ywindow) + + # Get the peak fitting parameters. + call rg_xseti (xc, PFUNC, clgwrd ("function", Memc[str], SZ_LINE, + XC_PTYPES)) + xcbox = clgeti ("xcbox") + if (mod (xcbox,2) == 0) + xcbox = xcbox + 1 + call rg_xseti (xc, XCBOX, xcbox) + ycbox = clgeti ("ycbox") + if (mod (ycbox,2) == 0) + ycbox = ycbox + 1 + call rg_xseti (xc, YCBOX, ycbox) + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/xregister/rgxicorr.x b/pkg/images/immatch/src/xregister/rgxicorr.x new file mode 100644 index 00000000..e96c6dec --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxicorr.x @@ -0,0 +1,583 @@ +include <imhdr.h> +include <fset.h> +include <ctype.h> +include "xregister.h" + +define HELPFILE "immatch$src/xregister/xregister.key" +define OHELPFILE "immatch$src/xregister/oxregister.key" + +define XC_PCONTOUR 1 +define XC_PLINE 2 +define XC_PCOL 3 + + +# RG_XICORR -- Compute the shifts for each image interactively using +# cross-correlation techniques. + +int procedure rg_xicorr (imr, im1, im2, db, dformat, reglist, tfd, xc, gd, id) + +pointer imr #I/O pointer to the reference image +pointer im1 #I/O pointer to the input image +pointer im2 #I/O pointer to the output image +pointer db #I/O pointer to the shifts database file +int dformat #I is the shifts file in database format +int reglist #I/O the regions list descriptor +int tfd #I/O the transform file descriptor +pointer xc #I pointer to the cross-corrrelation structure +pointer gd #I the graphics stream pointer +pointer id #I the display stream pointer + +int newdata, newcross, newcenter, wcs, key, cplottype, newplot +int ip, ncolr, nliner +pointer sp, cmd +real xshift, yshift, wx, wy +int rg_xstati(), rg_icross(), clgcur(), rg_xgtverify(), rg_xgqverify() +int ctoi() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Initialize. + newdata = YES + newcross = YES + newcenter = YES + ncolr = (1 + rg_xstati (xc, XWINDOW)) / 2 + nliner = (1 + rg_xstati (xc, YWINDOW)) / 2 + cplottype = XC_PCONTOUR + newplot = YES + xshift = 0.0 + yshift = 0.0 + + # Compute the cross-correlation function for the first region + # and print the results. + if (rg_xstati (xc, NREGIONS) <= 0) { + call gclear (gd) + call printf ("The regions list is empty\n") + } else if (rg_icross (xc, imr, im1, rg_xstati (xc, CREGION)) != ERR) { + call rg_xcplot (xc, gd, ncolr, nliner, cplottype) + call rg_fit (xc, rg_xstati (xc, CREGION), gd, xshift, yshift) + call rg_xpwrec (xc, rg_xstati (xc, CREGION)) + newdata = NO + newcross = NO + newcenter = NO + newplot = NO + } else { + call gclear (gd) + call printf ( + "Error computing X-correlation function for region %d\n") + call pargi (rg_xstati (xc, CREGION)) + } + + + # Loop over the cursor commands. + while (clgcur ("gcommands", wx, wy, wcs, key, Memc[cmd], SZ_LINE) != + EOF) { + + switch (key) { + + # Print the help page. + case '?': + call gpagefile (gd, HELPFILE, "") + + # Redraw the current plot. + case 'r': + newplot = YES + + # Draw a contour plot of the cross-correlation function. + case 'c': + if (cplottype != XC_PCONTOUR) + newplot = YES + ncolr = (rg_xstati (xc, XWINDOW) + 1) / 2 + nliner = (rg_xstati (xc, YWINDOW) + 1) / 2 + cplottype = XC_PCONTOUR + + # Plot a column of the cross-correlation function. + case 'x': + if (cplottype != XC_PCOL) + newplot = YES + if (cplottype == XC_PCONTOUR) { + ncolr = nint (wx) + nliner = nint (wy) + } else if (cplottype == XC_PLINE) { + ncolr = nint (wx) + } + cplottype = XC_PCOL + + # Plot a line of the cross-correlation function. + case 'y': + if (cplottype != XC_PLINE) + newplot = YES + if (cplottype == XC_PCONTOUR) { + ncolr = nint (wx) + nliner = nint (wy) + } else if (cplottype == XC_PCOL) { + ncolr = nint (wx) + } + cplottype = XC_PLINE + + # Quit the task gracefully. + case 'q': + if (rg_xgqverify ("xregister", db, dformat, xc, key) == YES) { + call sfree (sp) + return (rg_xgtverify (key)) + } + + # The Data overlay menu. + case 'o': + #call gdeactivate (gd, 0) + call rg_xoverlay (gd, xc, rg_xstati (xc, CREGION), imr, im1) + #call greactivate (gd, 0) + newplot = YES + + # Process colon commands. + case ':': + for (ip = 1; IS_WHITE(Memc[cmd+ip-1]); ip = ip + 1) + ; + switch (Memc[cmd+ip-1]) { + case 'x': + if (Memc[cmd+ip] != EOS && Memc[cmd+ip] != ' ') { + call rg_xcolon (gd, xc, imr, im1, im2, db, dformat, + tfd, reglist, Memc[cmd], newdata, newcross, + newcenter) + } else { + ip = ip + 1 + if (ctoi (Memc[cmd], ip, ncolr) <= 0) + ncolr = (1 + rg_xstati (xc, XWINDOW)) / 2 + cplottype = XC_PCOL + newplot = YES + } + case 'y': + if (Memc[cmd+ip] != EOS && Memc[cmd+ip] != ' ') { + call rg_xcolon (gd, xc, imr, im1, im2, db, dformat, + tfd, reglist, Memc[cmd], newdata, newcross, + newcenter) + } else { + ip = ip + 1 + if (ctoi (Memc[cmd], ip, nliner) <= 0) + nliner = (1 + rg_xstati (xc, YWINDOW)) / 2 + cplottype = XC_PLINE + newplot = YES + } + default: + call rg_xcolon (gd, xc, imr, im1, im2, db, dformat, tfd, + reglist, Memc[cmd], newdata, newcross, newcenter) + } + + # Compute an image lag interactively. + case 't': + call gdeactivate (gd, 0) + call rg_itransform (xc, imr, im1, id) + newdata = YES; newcross = YES; newcenter = YES + call greactivate (gd, 0) + + # Write the parameters to the parameter file. + case 'w': + call rg_pxpars (xc) + + case 'f': + + if (rg_xstati (xc, NREGIONS) > 0) { + + if (newdata == YES) { + call rg_xcindefr (xc, rg_xstati(xc,CREGION)) + newdata = NO + } + + if (newcross == YES) { + call printf ( + "Recomputing X-correlation function ...\n") + if (rg_icross (xc, imr, im1, rg_xstati (xc, + CREGION)) != ERR) { + ncolr = (1 + rg_xstati (xc, XWINDOW)) / 2 + if (IM_NDIM(imr) == 1) + nliner = 1 + else + nliner = (1 + rg_xstati (xc, YWINDOW)) / 2 + call rg_xcplot (xc, gd, ncolr, nliner, cplottype) + call rg_fit (xc, rg_xstati (xc, CREGION), gd, + xshift, yshift) + call rg_xpwrec (xc, rg_xstati (xc, CREGION)) + newcross = NO + newcenter = NO + newplot = NO + } else { + call printf ( + "Error computing X-correlation function for region %d\n") + call pargi (rg_xstati (xc, CREGION)) + } + } + + if (newcenter == YES) { + call rg_fit (xc, rg_xstati (xc, CREGION), gd, + xshift, yshift) + call rg_xpwrec (xc, rg_xstati (xc, CREGION)) + newcenter = NO + } + + } else + call printf ("The regions list is empty\n") + + + + # Do nothing gracefully. + default: + call printf ("Unknown or ambiguous keystroke command\n") + } + + # Replot the correlation function. + if (newplot == YES) { + if (newdata == YES) { + call printf ( + "Warning: X-correlation function should be refit\n") + } else if (newcross == YES) { + call printf ( + "Warning: X-correlation function should be refit\n") + } else if (newcenter == YES) { + call printf ( + "Warning: X-correlation function should be refit\n") + } else if (rg_xstatp (xc, XCOR) != NULL) { + call rg_xcplot (xc, gd, ncolr, nliner, cplottype) + call rg_xpwrec (xc, rg_xstati (xc, CREGION)) + newplot = NO + } else { + call printf ( + "Warning: X-correlation function is undefined\n") + } + } + } + + call sfree (sp) +end + + +# RG_XOVERLAY -- The image overlay plot menu. + +procedure rg_xoverlay (gd, xc, nreg, imr, im1) + +pointer gd #I graphics stream pointer +pointer xc #I pointer to the crosscor structure +int nreg #I the current region number +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image + +int ip, wcs, key, ixlag, iylag, ixshift, iyshift +int nrimcols, nrimlines, nimcols, nimlines, ncolr, ncoli, nliner, nlinei +pointer sp, cmd +real wx, wy, rxlag, rylag, xshift, yshift +int clgcur(), ctoi(), rg_xstati() +pointer rg_xstatp() + +begin + if (gd == NULL) + return + + nrimcols = IM_LEN(imr,1) + if (IM_NDIM(imr) == 1) + nrimlines = 1 + else + nrimlines = IM_LEN(imr,2) + nimcols = IM_LEN(im1,1) + if (IM_NDIM(im1) == 1) + nimlines = 1 + else + nimlines = IM_LEN(im1,2) + if (rg_xstati (xc, NREFPTS) > 0) { + wx = (1. + nrimcols) / 2.0 + wy = (1. + nrimlines) / 2.0 + call rg_etransform (xc, wx, wy, rxlag, rylag) + ixlag = rxlag - wx + iylag = rylag - wy + } else { + ixlag = rg_xstati (xc, XLAG) + iylag = rg_xstati (xc, YLAG) + } + xshift = -Memr[rg_xstatp(xc,XSHIFTS)+nreg-1] + yshift = -Memr[rg_xstatp(xc,YSHIFTS)+nreg-1] + + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + while (clgcur ("icommands", wx, wy, wcs, key, Memc[cmd], + SZ_LINE) != EOF) { + + switch (key) { + + # Print the help menu. + case '?': + call gdeactivate (gd, 0) + call pagefile (OHELPFILE, "") + call greactivate (gd, 0) + + # Quit. + case 'q': + break + + # Plot the same line of the reference and input image. + case 'l': + call rg_xpline (gd, imr, im1, nint (wy), 0, 0) + + # Plot the same column of the reference and input image + case 'c': + call rg_xpcol (gd, imr, im1, nint (wx), 0, 0) + + case 'y': + call rg_xpline (gd, imr, im1, nint (wy), ixlag, iylag) + + case 'x': + call rg_xpcol (gd, imr, im1, nint (wx), ixlag, iylag) + + case 'h': + call rg_xpline (gd, imr, im1, nint (wy), nint (xshift), + nint (yshift)) + + case 'v': + call rg_xpcol (gd, imr, im1, nint (wx), nint (xshift), + nint (yshift)) + + case ':': + ip = 1 + call rg_cokeys (Memc[cmd], ip, SZ_LINE, key) + switch (key) { + case 'l': + ixshift = 0 + if (ctoi (Memc[cmd], ip, nliner) <= 0) + nliner = (1 + nrimlines) / 2 + nliner = max (1, min (nliner, nrimlines)) + if (ctoi (Memc[cmd], ip, nlinei) <= 0) + nlinei = nliner + iyshift = nlinei - nliner + call rg_xpline (gd, imr, im1, nliner, ixshift, iyshift) + + case 'c': + if (ctoi (Memc[cmd], ip, ncolr) <= 0) + ncolr = (1 + nrimcols) / 2 + ncolr = max (1, min (ncolr, nrimcols)) + if (ctoi (Memc[cmd], ip, ncoli) <= 0) + ncoli = ncolr + ncoli = max (1, min (ncoli, nimcols)) + ixshift = ncoli - ncolr + iyshift = 0 + call rg_xpcol (gd, imr, im1, ncolr, ixshift, iyshift) + + case 'y': + if (ctoi (Memc[cmd], ip, nliner) <= 0) + nliner = (1 + nrimlines) / 2 + nliner = max (1, min (nliner, nrimlines)) + call rg_xpline (gd, imr, im1, nliner, ixlag, iylag) + + case 'x': + if (ctoi (Memc[cmd], ip, ncolr) <= 0) + ncolr = (1 + nrimcols) / 2 + ncolr = max (1, min (ncolr, nrimcols)) + call rg_xpcol (gd, imr, im1, ncolr, ixlag, iylag) + + case 'h': + if (ctoi (Memc[cmd], ip, nliner) <= 0) + nliner = (1 + nrimlines) / 2 + nliner = max (1, min (nliner, nrimlines)) + call rg_xpline (gd, imr, im1, nliner, nint (xshift), + nint (yshift)) + + case 'v': + if (ctoi (Memc[cmd], ip, ncolr) <= 0) + ncolr = (1 + nrimcols) / 2 + ncolr = max (1, min (ncolr, nrimcols)) + call rg_xpcol (gd, imr, im1, ncolr, nint (xshift), + nint (yshift)) + default: + call printf ("Ambiguous or unknown overlay menu command\n") + } + case 'g': + while (clgcur ("gcommands", wx, wy, wcs, key, Memc[cmd], + SZ_LINE) != EOF) { + if (key == 'q') + break + } + default: + call printf ("Ambiguous or unknown overlay menu command\n") + } + + } + + call sfree (sp) +end + + +# RG_XCPLOT -- Draw the default plot of the cross-correlation function. + +procedure rg_xcplot (xc, gd, col, line, plottype) + +pointer xc #I pointer to cross-correlation structure +pointer gd #I pointer to the graphics stream +int col #I column of cross-correlation function to plot +int line #I line of cross-correlation function to plot +int plottype #I the default plot type + +int nreg, xwindow, ywindow +pointer sp, title, str, prc1, prc2, prl1, prl2 +int rg_xstati(), strlen() +pointer rg_xstatp() + +begin + if (gd == NULL) + return + + # Allocate working space. + call smark (sp) + call salloc (title, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the regions. + nreg = rg_xstati (xc, CREGION) + prc1 = rg_xstatp (xc, RC1) + prc2 = rg_xstatp (xc, RC2) + prl1 = rg_xstatp (xc, RL1) + prl2 = rg_xstatp (xc, RL2) + + # Initialize the window size. + xwindow = rg_xstati (xc, XWINDOW) + if ((Memi[prl2+nreg-1] - Memi[prl1+nreg-1] + 1) == 1) + ywindow = 1 + else + ywindow = rg_xstati (xc, YWINDOW) + + # Construct a title. + call sprintf (Memc[title], SZ_LINE, + "Reference: %s Image: %s Region: [%d:%d,%d:%d]") + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call rg_xstats (xc, IMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call pargi (Memi[prc1+nreg-1]) + call pargi (Memi[prc2+nreg-1]) + call pargi (Memi[prl1+nreg-1]) + call pargi (Memi[prl2+nreg-1]) + + # Draw the plot. + if (ywindow == 1) { + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nX-Correlation Function: line %d") + call pargi (1) + call rg_xcpline (gd, Memc[title], Memr[rg_xstatp(xc,XCOR)], + xwindow, ywindow, 1) + } else { + switch (plottype) { + case XC_PCONTOUR: + call rg_contour (gd, "X-Correlation Function", Memc[title], + Memr[rg_xstatp (xc, XCOR)], xwindow, ywindow) + case XC_PLINE: + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nX-Correlation Function: line %d") + call pargi (line) + call rg_xcpline (gd, Memc[title], Memr[rg_xstatp(xc,XCOR)], + xwindow, ywindow, line) + case XC_PCOL: + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nX-Correlation Function: column %d") + call pargi (col) + call rg_xcpcol (gd, Memc[title], Memr[rg_xstatp(xc,XCOR)], + xwindow, ywindow, col) + default: + call rg_contour (gd, "X-Correlation Function", Memc[title], + Memr[rg_xstatp (xc, XCOR)], xwindow, ywindow) + } + } + + call sfree (sp) +end + + +# RG_COKEYS -- Fetch the first keystroke of a colon command. + +procedure rg_cokeys (cmd, ip, maxch, key) + +char cmd[ARB] #I the command string +int ip #I/O pointer into the command string +int maxch #I maximum number of characters +int key #O the keystroke + +begin + ip = 1 + while (IS_WHITE(cmd[ip]) && cmd[ip] != EOS && ip <= maxch) + ip = ip + 1 + + if (cmd[ip] == EOS && ip > maxch) + key = EOS + else { + key = cmd[ip] + ip = ip + 1 + } +end + + +define QUERY "Hit [return=continue, n=next image, q=quit, w=quit and update parameters]: " + +# RG_XGQVERIFY -- Print a message on the status line asking the user if they +# really want to quit, returning YES if they really want to quit, NO otherwise. + +int procedure rg_xgqverify (task, db, dformat, rg, ch) + +char task[ARB] #I the calling task name +pointer db #I pointer to the shifts database file +int dformat #I is the shifts file in database format +pointer rg #I pointer to the task structure +int ch #I the input keystroke command + +int wcs, stat +pointer sp, cmd +real wx, wy +bool streq() +int clgcur() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Print the status line query in reverse video and get the keystroke. + call printf (QUERY) + #call flush (STDOUT) + if (clgcur ("gcommands", wx, wy, wcs, ch, Memc[cmd], SZ_LINE) == EOF) + ; + + # Process the command. + if (ch == 'q') { + call rg_xwrec (db, dformat, rg) + stat = YES + } else if (ch == 'w') { + call rg_xwrec (db, dformat, rg) + if (streq ("xregister", task)) + call rg_pxpars (rg) + stat = YES + } else if (ch == 'n') { + call rg_xwrec (db, dformat, rg) + stat = YES + } else { + stat = NO + } + + call sfree (sp) + return (stat) +end + + +# RG_XGTVERIFY -- Verify whether or not the user truly wishes to quit the +# task. + +int procedure rg_xgtverify (ch) + +int ch #I the input keystroke command + +begin + if (ch == 'q') { + return (YES) + } else if (ch == 'w') { + return (YES) + } else if (ch == 'n') { + return (NO) + } else { + return (NO) + } +end diff --git a/pkg/images/immatch/src/xregister/rgximshift.x b/pkg/images/immatch/src/xregister/rgximshift.x new file mode 100644 index 00000000..08cb3f62 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgximshift.x @@ -0,0 +1,391 @@ +include <imhdr.h> +include <imset.h> +include <math/iminterp.h> + +define NYOUT 16 # number of lines output at once +define NMARGIN 3 # number of boundary pixels required +define NMARGIN_SPLINE3 16 # number of spline boundary pixels required + + +# RG_XSHIFTIM - Shift a 1 or 2D image by a fractional pixel amount +# x and y + +procedure rg_xshiftim (im1, im2, xshift, yshift, interpstr, boundary_type, + constant) + +pointer im1 #I pointer to input image +pointer im2 #I pointer to output image +real xshift #I shift in x direction +real yshift #I shift in y direction +char interpstr[ARB] #I type of interpolant +int boundary_type #I type of boundary extension +real constant #I value of constant for boundary extension + +int interp_type +pointer sp, str +bool fp_equalr() +int strdic() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + interp_type = strdic (interpstr, Memc[str], SZ_FNAME, II_BFUNCTIONS) + + if (interp_type == II_NEAREST) + call rg_xishiftim (im1, im2, nint (xshift), nint (yshift), + interp_type, boundary_type, constant) + else if (fp_equalr (xshift, real (int (xshift))) && fp_equalr (yshift, + real (int (xshift)))) + call rg_xishiftim (im1, im2, int (xshift), int (yshift), + interp_type, boundary_type, constant) + else + call rg_xfshiftim (im1, im2, xshift, yshift, interpstr, + boundary_type, constant) + call sfree (sp) +end + + +# RG_XISHIFTIM -- Shift a 2-D image by integral pixels in x and y. + +procedure rg_xishiftim (im1, im2, nxshift, nyshift, interp_type, boundary_type, + constant) + +pointer im1 #I pointer to the input image +pointer im2 #I pointer to the output image +int nxshift, nyshift #I shift in x and y +int interp_type #I type of interpolant +int boundary_type #I type of boundary extension +real constant #I constant for boundary extension + +int ixshift, iyshift +pointer buf1, buf2 +long v[IM_MAXDIM] +int ncols, nlines, nbpix +int i, x1col, x2col, yline + +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() +pointer imgs2s(), imgs2i(), imgs2l(), imgs2r(), imgs2d(), imgs2x() +errchk impnls, impnli, impnll, impnlr, impnld, impnlx +errchk imgs2s, imgs2i, imgs2l, imgs2r, imgs2d, imgs2x +string wrerr "ISHIFTXY: Error writing in image." + +begin + ixshift = nxshift + iyshift = nyshift + + ncols = IM_LEN(im1,1) + nlines = IM_LEN(im1,2) + + # Cannot shift off image. + if (ixshift < -ncols || ixshift > ncols) + call error (3, "ISHIFTXY: X shift out of bounds.") + if (iyshift < -nlines || iyshift > nlines) + call error (4, "ISHIFTXY: Y shift out of bounds.") + + # Calculate the shift. + switch (boundary_type) { + case BT_CONSTANT,BT_REFLECT,BT_NEAREST: + ixshift = min (ncols, max (-ncols, ixshift)) + iyshift = min (nlines, max (-nlines, iyshift)) + case BT_WRAP: + ixshift = mod (ixshift, ncols) + iyshift = mod (iyshift, nlines) + } + + # Set the boundary extension values. + nbpix = max (abs (ixshift), abs (iyshift)) + call imseti (im1, IM_NBNDRYPIX, nbpix) + call imseti (im1, IM_TYBNDRY, boundary_type) + if (boundary_type == BT_CONSTANT) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Get column boundaries in the input image. + x1col = max (-ncols + 1, - ixshift + 1) + x2col = min (2 * ncols, ncols - ixshift) + + call amovkl (long (1), v, IM_MAXDIM) + + # Shift the image using the appropriate data type operators. + switch (IM_PIXTYPE(im1)) { + case TY_SHORT: + do i = 1, nlines { + if (impnls (im2, buf2, v) == EOF) + call error (5, wrerr) + yline = i - iyshift + buf1 = imgs2s (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (5, wrerr) + call amovs (Mems[buf1], Mems[buf2], ncols) + } + case TY_INT: + do i = 1, nlines { + if (impnli (im2, buf2, v) == EOF) + call error (5, wrerr) + yline = i - iyshift + buf1 = imgs2i (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (5, wrerr) + call amovi (Memi[buf1], Memi[buf2], ncols) + } + case TY_USHORT, TY_LONG: + do i = 1, nlines { + if (impnll (im2, buf2, v) == EOF) + call error (5, wrerr) + yline = i - iyshift + buf1 = imgs2l (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (5, wrerr) + call amovl (Meml[buf1], Meml[buf2], ncols) + } + case TY_REAL: + do i = 1, nlines { + if (impnlr (im2, buf2, v) == EOF) + call error (5, wrerr) + yline = i - iyshift + buf1 = imgs2r (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (5, wrerr) + call amovr (Memr[buf1], Memr[buf2], ncols) + } + case TY_DOUBLE: + do i = 1, nlines { + if (impnld (im2, buf2, v) == EOF) + call error (0, wrerr) + yline = i - iyshift + buf1 = imgs2d (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (0, wrerr) + call amovd (Memd[buf1], Memd[buf2], ncols) + } + case TY_COMPLEX: + do i = 1, nlines { + if (impnlx (im2, buf2, v) == EOF) + call error (0, wrerr) + yline = i - iyshift + buf1 = imgs2x (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (0, wrerr) + call amovx (Memx[buf1], Memx[buf2], ncols) + } + default: + call error (6, "ISHIFTXY: Unknown IRAF type.") + } +end + + + +# RG_XFSHIFTIM -- Shift a 1 or 2D image by a fractional pixel amount +# in x and y. + +procedure rg_xfshiftim (im1, im2, xshift, yshift, interpstr, boundary_type, + constant) + +pointer im1 #I pointer to input image +pointer im2 #I pointer to output image +real xshift #I shift in x direction +real yshift #I shift in y direction +char interpstr[ARB] #I type of interpolant +int boundary_type #I type of boundary extension +real constant #I value of constant for boundary extension + +int i, interp_type, nsinc, nincr +int ncols, nlines, nbpix, fstline, lstline, nxymargin +int cin1, cin2, nxin, lin1, lin2, nyin +int lout1, lout2, nyout +real xshft, yshft, deltax, deltay, dx, dy, cx, ly +pointer sp, x, y, msi, sinbuf, soutbuf +bool fp_equalr() +int msigeti() +pointer imps2r() + +errchk imgs2r, imps2r +errchk msiinit, msifree, msifit, msigrid +errchk smark, salloc, sfree + +begin + ncols = IM_LEN(im1,1) + nlines = IM_LEN(im1,2) + + # Check for out of bounds shift. + if (xshift < -ncols || xshift > ncols) + call error (0, "XC_SHIFTIM: X shift out of bounds.") + if (yshift < -nlines || yshift > nlines) + call error (0, "XC_SHIFTIM: Y shift out of bounds.") + + # Get the real shift. + if (boundary_type == BT_WRAP) { + xshft = mod (xshift, real (ncols)) + yshft = mod (yshift, real (nlines)) + } else { + xshft = xshift + yshft = yshift + } + + # Allocate temporary space. + call smark (sp) + call salloc (x, 2 * ncols, TY_REAL) + call salloc (y, 2 * nlines, TY_REAL) + sinbuf = NULL + + # Define the x and y interpolation coordinates. + dx = abs (xshft - int (xshft)) + if (fp_equalr (dx, 0.0)) + deltax = 0.0 + else if (xshft > 0.) + deltax = 1. - dx + else + deltax = dx + dy = abs (yshft - int (yshft)) + if (fp_equalr (dy, 0.0)) + deltay = 0.0 + else if (yshft > 0.) + deltay = 1. - dy + else + deltay = dy + + # Initialize the 2-D interpolation routines. + call msitype (interpstr, interp_type, nsinc, nincr, cx) + if (interp_type == II_BILSINC || interp_type == II_BISINC) + call msisinit (msi, interp_type, nsinc, 1, 1, + deltax - nint (deltax), deltay - nint (deltay), 0.0) + else + call msisinit (msi, interp_type, nsinc, 1, 1, cx, cx, 0.0) + + # Set boundary extension parameters. + if (interp_type == II_BISPLINE3) + nxymargin = NMARGIN_SPLINE3 + else if (interp_type == II_BISINC || interp_type == II_BILSINC) + nxymargin = msigeti (msi, II_MSINSINC) + else + nxymargin = NMARGIN + nbpix = max (int (abs(xshft)+1.0), int (abs(yshft)+1.0)) + nxymargin + call imseti (im1, IM_NBNDRYPIX, nbpix) + call imseti (im1, IM_TYBNDRY, boundary_type) + if (boundary_type == BT_CONSTANT) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Define the x interpolation coordinates. + deltax = deltax + nxymargin + if (interp_type == II_BIDRIZZLE) { + do i = 1, ncols { + Memr[x+2*i-2] = i + deltax - 0.5 + Memr[x+2*i-1] = i + deltax + 0.5 + } + } else { + do i = 1, ncols + Memr[x+i-1] = i + deltax + } + + # Define the y interpolation coordinates. + deltay = deltay + nxymargin + if (interp_type == II_BIDRIZZLE) { + do i = 1, NYOUT { + Memr[y+2*i-2] = i + deltay - 0.5 + Memr[y+2*i-1] = i + deltay + 0.5 + } + } else { + do i = 1, NYOUT + Memr[y+i-1] = i + deltay + } + + # Define column range in the input image. + cx = 1. - nxymargin - xshft + if ((cx <= 0.) && (! fp_equalr (dx, 0.0))) + cin1 = int (cx) - 1 + else + cin1 = int (cx) + cin2 = ncols - xshft + nxymargin + 1 + nxin = cin2 - cin1 + 1 + + # Loop over output sections. + for (lout1 = 1; lout1 <= nlines; lout1 = lout1 + NYOUT) { + + # Define range of output lines. + lout2 = min (lout1 + NYOUT - 1, nlines) + nyout = lout2 - lout1 + 1 + + # Define correspoding range of input lines. + ly = lout1 - nxymargin - yshft + if ((ly <= 0) && (! fp_equalr (dy, 0.0))) + lin1 = int (ly) - 1 + else + lin1 = int (ly) + lin2 = lout2 - yshft + nxymargin + 1 + nyin = lin2 - lin1 + 1 + + # Get appropriate input image section and compute the coefficients. + if ((sinbuf == NULL) || (lin1 < fstline) || (lin2 > lstline)) { + fstline = lin1 + lstline = lin2 + call rg_buf (im1, cin1, cin2, lin1, lin2, sinbuf) + call msifit (msi, Memr[sinbuf], nxin, nyin, nxin) + } + + # Output the image section. + soutbuf = imps2r (im2, 1, ncols, lout1, lout2) + if (soutbuf == EOF) + call error (0, "GSHIFTXY: Error writing output image.") + + # Evaluate the interpolant. + call msigrid (msi, Memr[x], Memr[y], Memr[soutbuf], ncols, nyout, + ncols) + } + + call msifree (msi) + call sfree (sp) +end + + +# RG_BUF -- Procedure to provide a buffer of image lines with minimum reads + +procedure rg_buf (im, col1, col2, line1, line2, buf) + +pointer im #I pointer to input image +int col1, col2 #I column range of input buffer +int line1, line2 #I line range of input buffer +pointer buf #I buffer + +int i, ncols, nlines, nclast, llast1, llast2, nllast +pointer buf1, buf2 + +pointer imgs2r() + +begin + ncols = col2 - col1 + 1 + nlines = line2 - line1 + 1 + + if (buf == NULL) { + call malloc (buf, ncols * nlines, TY_REAL) + llast1 = line1 - nlines + llast2 = line2 - nlines + } else if ((nlines != nllast) || (ncols != nclast)) { + call realloc (buf, ncols * nlines, TY_REAL) + llast1 = line1 - nlines + llast2 = line2 - nlines + } + + if (line1 < llast1) { + do i = line2, line1, -1 { + if (i > llast1) + buf1 = buf + (i - llast1) * ncols + else + buf1 = imgs2r (im, col1, col2, i, i) + buf2 = buf + (i - line1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } else if (line2 > llast2) { + do i = line1, line2 { + if (i < llast2) + buf1 = buf + (i - llast1) * ncols + else + buf1 = imgs2r (im, col1, col2, i, i) + buf2 = buf + (i - line1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } + + llast1 = line1 + llast2 = line2 + nclast = ncols + nllast = nlines +end diff --git a/pkg/images/immatch/src/xregister/rgxplot.x b/pkg/images/immatch/src/xregister/rgxplot.x new file mode 100644 index 00000000..8b347ab5 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxplot.x @@ -0,0 +1,317 @@ +include <imhdr.h> +include <gset.h> + +# RG_XPLINE -- Plot a line of reference and input image. + +procedure rg_xpline (gd, imr, im, nliner, xshift, yshift) + +pointer gd #I pointer to the graphics stream +pointer imr #I pointer to the reference image +pointer im #I pointer to the image +int nliner #I the reference line +int xshift #I x shift +int yshift #I y shift + +int i, rncols, rnlines, incols, inlines +pointer sp, title, xr, xi, ptrr, ptri +real ymin, ymax, tymin, tymax +int strlen() +pointer imgl1r(), imgl2r() + +begin + # Return if no graphics stream. + if (gd == NULL) + return + + # Check for valid line number. + rncols = IM_LEN(imr,1) + if (IM_NDIM(imr) == 1) + rnlines = 1 + else + rnlines = IM_LEN(imr,2) + incols = IM_LEN(im,1) + if (IM_NDIM(im) == 1) + inlines = 1 + else + inlines = IM_LEN(im,2) + if ((nliner < 1) || (nliner > rnlines)) + return + if (((nliner + yshift) < 1) || ((nliner + yshift) > inlines)) + return + + # Allocate working space. + call smark (sp) + call salloc (title, SZ_LINE, TY_CHAR) + call salloc (xr, rncols, TY_REAL) + call salloc (xi, rncols, TY_REAL) + + # Initialize the x data data. + do i = 1, rncols { + Memr[xr+i-1] = i + Memr[xi+i-1] = i - xshift + } + + # Initalize the y data. + if (IM_NDIM(imr) == 1) + ptrr = imgl1r (imr) + else + ptrr = imgl2r (imr, nliner) + if (IM_NDIM(im) == 1) + ptri = imgl1r (im) + else + ptri = imgl2r (im, nliner + yshift) + call alimr (Memr[ptrr], rncols, ymin, ymax) + call alimr (Memr[ptri], incols, tymin, tymax) + ymin = min (ymin, tymin) + ymax = max (ymax, tymax) + + # Construct the title. + call sprintf (Memc[title], SZ_LINE, + "Refimage: %s Image: %s\n") + call pargstr (IM_HDRFILE(imr)) + call pargstr (IM_HDRFILE(im)) + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "Refline (solid): %d Inline (dashed): %d Xlag: %d Ylag: %d") + call pargi (nliner) + call pargi (nliner + yshift) + call pargi (xshift) + call pargi (yshift) + + # Set up the axes labels and window. + call gclear (gd) + call gswind (gd, 1.0, real(rncols), ymin, ymax) + call glabax (gd, Memc[title], "Column Number", "Counts") + + # Plot the two lines. + call gseti (gd, G_PLTYPE, GL_SOLID) + call gpline (gd, Memr[xr], Memr[ptrr], rncols) + call gseti (gd, G_PLTYPE, GL_DASHED) + call gpline (gd, Memr[xi], Memr[ptri], incols) + call gflush (gd) + + call sfree (sp) +end + + +# RG_XPCOL -- Plot a column in the reference and input image. + +procedure rg_xpcol (gd, imr, im, ncolr, xshift, yshift) + +pointer gd #I pointer to the graphics stream +pointer imr #I pointer to the reference image +pointer im #I pointer to the image +int ncolr #I the line number +int xshift #I xshift to be applied +int yshift #I yshift to be applied + +int i, rncols, rnlines, incols, inlines +pointer sp, title, xr, xi, ptrr, ptri +real ymin, ymax, tymin, tymax +int strlen() +pointer imgs1r(), imgs2r() + +begin + # Return if no graphics stream. + if (gd == NULL) + return + + # Check for valid column number. + rncols = IM_LEN(imr,1) + if (IM_NDIM(imr) == 1) + rnlines = 1 + else + rnlines = IM_LEN(imr,2) + incols = IM_LEN(im,1) + if (IM_NDIM(im) == 1) + inlines = 1 + else + inlines = IM_LEN(im,2) + if ((ncolr < 1) || (ncolr > rncols)) + return + if (((ncolr - xshift) < 1) || ((ncolr - xshift) > incols)) + return + + # Allocate valid working space. + call smark (sp) + call salloc (title, SZ_LINE, TY_CHAR) + call salloc (xr, rnlines, TY_REAL) + call salloc (xi, inlines, TY_REAL) + + # Initialize the data. + do i = 1, rnlines { + Memr[xr+i-1] = i + Memr[xi+i-1] = i - yshift + } + if (IM_NDIM(imr) == 1) + ptrr = imgs1r (imr, ncolr, ncolr) + else + ptrr = imgs2r (imr, ncolr, ncolr, 1, rnlines) + if (IM_NDIM(im) == 1) + ptri = imgs1r (im, ncolr + xshift, ncolr + xshift) + else + ptri = imgs2r (im, ncolr + xshift, ncolr + xshift, 1, inlines) + call alimr (Memr[ptrr], rnlines, ymin, ymax) + call alimr (Memr[ptri], inlines, tymin, tymax) + ymin = min (ymin, tymin) + ymax = max (ymax, tymax) + + # Construct the title. + call sprintf (Memc[title], SZ_LINE, "Refimage: %s Image: %s\n") + call pargstr (IM_HDRFILE(imr)) + call pargstr (IM_HDRFILE(im)) + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "Refcol (solid): %d Imcol (dashed): %d Xlag: %d Ylag: %d") + call pargi (ncolr) + call pargi (ncolr + xshift) + call pargi (xshift) + call pargi (yshift) + + # Set up the labels and the axes. + call gclear (gd) + call gswind (gd, 1.0, real (rnlines), ymin, ymax) + call glabax (gd, Memc[title], "Line Number", "Counts") + + # Plot the profile. + call gseti (gd, G_PLTYPE, GL_SOLID) + call gpline (gd, Memr[xr], Memr[ptrr], rnlines) + call gseti (gd, G_PLTYPE, GL_DASHED) + call gpline (gd, Memr[xi], Memr[ptri], rnlines) + call gflush (gd) + + call sfree (sp) +end + + +# RG_XCPLINE -- Plot a line of the 2D correlation function. + +procedure rg_xcpline (gd, title, data, nx, ny, nline) + +pointer gd #I pointer to the graphics stream +char title[ARB] #I title for the plot +real data[nx,ARB] #I the input data array +int nx, ny #I dimensions of the input data array +int nline #I the line number + +int i +pointer sp, str, x +real ymin, ymax + +begin + # Return if no graphics stream. + if (gd == NULL) + return + + # Check for valid line number. + if (nline < 1 || nline > ny) + return + + # Allocate some working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (x, nx, TY_REAL) + + # Initialize the data. + do i = 1, nx + Memr[x+i-1] = i + call alimr (data[1,nline], nx, ymin, ymax) + + # Set up the labels and the axes. + call gclear (gd) + call gswind (gd, 1.0, real (nx), ymin, ymax) + call glabax (gd, title, "X Lag", "X-Correlation Function") + + # Plot the line profile. + call gseti (gd, G_PLTYPE, GL_SOLID) + call gpline (gd, Memr[x], data[1,nline], nx) + call gflush (gd) + + call sfree (sp) +end + + +# RG_XCPCOL -- Plot a column of the cross-correlation function. + +procedure rg_xcpcol (gd, title, data, nx, ny, ncol) + +pointer gd #I pointer to the graphics stream +char title[ARB] #I title of the column plot +real data[nx,ARB] #I the input data array +int nx, ny #I the dimensions of the input data array +int ncol #I line number + +int i +pointer sp, x, y +real ymin, ymax + +begin + # Return if no graphics stream. + if (gd == NULL) + return + + # Check for valid column number. + if (ncol < 1 || ncol > nx) + return + + # Initialize. + call smark (sp) + call salloc (x, ny, TY_REAL) + call salloc (y, ny, TY_REAL) + + # Get the data to be plotted. + do i = 1, ny { + Memr[x+i-1] = i + Memr[y+i-1] = data[ncol,i] + } + call alimr (Memr[y], ny, ymin, ymax) + + # Set up the labels and the axes. + call gclear (gd) + call gswind (gd, 1.0, real (ny), ymin, ymax) + call glabax (gd, title, "Y Lag", "X-Correlation Function") + + # Plot the profile. + call gseti (gd, G_PLTYPE, GL_SOLID) + call gpline (gd, Memr[x], Memr[y], ny) + call gflush (gd) + + call sfree (sp) +end + + +# RG_XMKPEAK -- Procedure to mark the peak from a correlation function +# contour plot. + +procedure rg_xmkpeak (gd, xwindow, ywindow, xshift, yshift) + +pointer gd #I pointer to the graphics stream +int xwindow #I x dimension of correlation function +int ywindow #I y dimension of correlation function +real xshift #O x shift +real yshift #O y shift + +int wcs, key +pointer sp, cmd +real wx, wy +int clgcur() + +begin + if (gd == NULL) + return + + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + call printf ("Mark peak of the cross correlation function\n") + if (clgcur ("gcommands", wx, wy, wcs, key, Memc[cmd], SZ_LINE) == EOF) + ; + if (wx < 1.0 || wx > real (xwindow) || wy < 1.0 || wy > + real (ywindow)) { + xshift = 0.0 + yshift = 0.0 + } else { + xshift = wx - (1 + xwindow) / 2 + yshift = wy - (1 + ywindow) / 2 + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/xregister/rgxppars.x b/pkg/images/immatch/src/xregister/rgxppars.x new file mode 100644 index 00000000..2dc6aafd --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxppars.x @@ -0,0 +1,49 @@ +include "xregister.h" + +# RG_PXPARS -- Update the cross-correlation algorithm parameters. + +procedure rg_pxpars (xc) + +pointer xc #I pointer to the cross-correlation structure + +pointer sp, str +int rg_xstati() +real rg_xstatr() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Define the regions. + call rg_xstats (xc, REGIONS, Memc[str], SZ_LINE) + call clpstr ("regions", Memc[str]) + call clputi ("xlag", rg_xstati (xc, XLAG)) + call clputi ("ylag", rg_xstati (xc, YLAG)) + call clputi ("dxlag", rg_xstati (xc, DXLAG)) + call clputi ("dylag", rg_xstati (xc, DYLAG)) + + # Store the background fitting parameters. + call rg_xstats (xc, BSTRING, Memc[str], SZ_LINE) + call clpstr ("background", Memc[str]) + call clputi ("border", rg_xstati (xc, BORDER)) + call clputr ("loreject", rg_xstatr (xc, LOREJECT)) + call clputr ("hireject", rg_xstatr (xc, HIREJECT)) + call clputr ("apodize", rg_xstatr (xc, APODIZE)) + call rg_xstats (xc, FSTRING, Memc[str], SZ_LINE) + call clpstr ("filter", Memc[str]) + + # Store the cross-correlation parameters. + call rg_xstats (xc, CSTRING, Memc[str], SZ_LINE) + call clpstr ("correlation", Memc[str]) + call clputi ("xwindow", rg_xstati (xc, XWINDOW)) + call clputi ("ywindow", rg_xstati (xc, YWINDOW)) + + # Store the peak centering parameters. + call rg_xstats (xc, PSTRING, Memc[str], SZ_LINE) + call clpstr ("function", Memc[str]) + call clputi ("xcbox", rg_xstati (xc, XCBOX)) + call clputi ("ycbox", rg_xstati (xc, YCBOX)) + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/xregister/rgxregions.x b/pkg/images/immatch/src/xregister/rgxregions.x new file mode 100644 index 00000000..ed682f61 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxregions.x @@ -0,0 +1,459 @@ +include <fset.h> +include <ctype.h> +include <imhdr.h> +include "xregister.h" + +# RG_XREGIONS -- Decode the image sections into regions. If the sections string +# is NULL then the regions list is initially empty and depending on the mode +# of the task, XREGISTER will or will not complain.Otherwise the image +# sections specified in the sections string or file are decoded into a +# regions list. + +int procedure rg_xregions (list, im, xc, rp) + +int list #I pointer to the regions list +pointer im #I pointer to the reference image +pointer xc #I pointer to the cross-correlation structure +int rp #I index of the current region + +int fd, nregions +pointer sp, fname, regions +int rg_xgrid(), rg_xgregions(), rg_xrregions(), rg_xstati(), fntgfnb() +int open() +errchk fntgfnb(), open(), close() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (regions, SZ_LINE, TY_CHAR) + + call rg_xstats (xc, REGIONS, Memc[regions], SZ_LINE) + if (rp < 1 || rp > MAX_NREGIONS || Memc[regions] == EOS) { + nregions = 0 + } else if (rg_xgrid (im, xc, rp, MAX_NREGIONS) > 0) { + nregions = rg_xstati (xc, NREGIONS) + } else if (rg_xgregions (im, xc, rp, MAX_NREGIONS) > 0) { + nregions = rg_xstati (xc, NREGIONS) + } else if (list != NULL) { + iferr { + if (fntgfnb (list, Memc[fname], SZ_FNAME) != EOF) { + fd = open (Memc[fname], READ_ONLY, TEXT_FILE) + nregions= rg_xrregions (fd, im, xc, rp, MAX_NREGIONS) + call close (fd) + } + } then + nregions = 0 + } else + nregions = 0 + + call sfree (sp) + + return (nregions) +end + + +# RG_XMKREGIONS -- Create a list of regions by marking image sections +# on the image display. + +int procedure rg_xmkregions (im, xc, rp, max_nregions, regions, maxch) + +pointer im #I pointer to the reference image +pointer xc #I pointer to the cross-correlation structure +int rp #I index of the current region +int max_nregions #I the maximum number of regions +char regions[ARB] #O the output regions string +int maxch #I maximum size of the output regions string + +int op, nregions, wcs, key +pointer sp, region, section, cmd +real xll, yll, xur, yur +int rg_xstati(), clgcur(), gstrcpy() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_xrealloc (xc, max_nregions) + + # Initialize. + nregions = min (rp-1, rg_xstati (xc, NREGIONS)) + op = 1 + + # Mark the sections on the display. + while (nregions < max_nregions) { + + call printf ("Mark lower left corner of region %d [q to quit].\n") + call pargi (nregions + 1) + if (clgcur ("icommands", xll, yll, wcs, key, Memc[cmd], + SZ_LINE) == EOF) + break + if (key == 'q') + break + + call printf ("Mark upper right corner of region %d [q to quit].\n") + call pargi (nregions + 1) + if (clgcur ("icommands", xur, yur, wcs, key, Memc[cmd], + SZ_LINE) == EOF) + break + if (key == 'q') + break + + if (xll < 1.0 || xur > IM_LEN(im,1) || yll < 1.0 || yur > + IM_LEN(im,2)) + break + + Memi[rg_xstatp(xc,RC1)+nregions] = nint (xll) + Memi[rg_xstatp(xc,RC2)+nregions] = nint (xur) + Memi[rg_xstatp(xc,RL1)+nregions] = nint (yll) + Memi[rg_xstatp(xc,RL2)+nregions] = nint (yur) + Memr[rg_xstatp(xc,RZERO)+nregions] = INDEFR + Memr[rg_xstatp(xc,RXSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,RYSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,XSHIFTS)+nregions] = INDEFR + Memr[rg_xstatp(xc,YSHIFTS)+nregions] = INDEFR + nregions = nregions + 1 + + # Write the first 9 regions into the regions string. + call sprintf (Memc[cmd], SZ_LINE, "[%d:%d,%d:%d] ") + call pargi (nint (xll)) + call pargi (nint (xur)) + call pargi (nint (yll)) + call pargi (nint (yur)) + op = op + gstrcpy (Memc[cmd], regions[op], maxch - op + 1) + } + call printf ("\n") + + # Reallocate the correct amount of space. + call rg_xseti (xc, NREGIONS, nregions) + if (nregions > 0) + call rg_xrealloc (xc, nregions) + else + call rg_xrfree (xc) + + call sfree (sp) + + return (nregions) +end + + +# RG_XGRID - Decode the regions from a grid specification. + +int procedure rg_xgrid (im, xc, rp, max_nregions) + +pointer im #I pointer to the reference image +pointer xc #I pointer to the cross-correlation structure +int rp #I index of the current region +int max_nregions #I the maximum number of regions + +int i, istart, iend, j, jstart, jend, ncols, nlines, nxsample, nysample +int nxcols, nylines, nregions +pointer sp, region, section +int rg_xstati(), nscan(), strcmp() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_xrealloc (xc, max_nregions) + + # Initialize. + call rg_xstats (xc, REGIONS, Memc[region], SZ_LINE) + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + nregions = min (rp - 1, rg_xstati (xc, NREGIONS)) + + # Decode the grid specification. + call sscan (Memc[region]) + call gargwrd (Memc[section], SZ_LINE) + call gargi (nxsample) + call gargi (nysample) + if ((nscan() != 3) || (strcmp (Memc[section], "grid") != 0)) { + call sfree (sp) + return (nregions) + } + + # Decode the regions. + if ((nxsample * nysample) > max_nregions) { + nxsample = nint (sqrt (real (max_nregions) * real (ncols) / + real (nlines))) + nysample = real (max_nregions) / real (nxsample) + } + nxcols = ncols / nxsample + nylines = nlines / nysample + jstart = 1 + (nlines - nysample * nylines) / 2 + jend = jstart + (nysample - 1) * nylines + do j = jstart, jend, nylines { + istart = 1 + (ncols - nxsample * nxcols) / 2 + iend = istart + (nxsample - 1) * nxcols + do i = istart, iend, nxcols { + Memi[rg_xstatp(xc,RC1)+nregions] = i + Memi[rg_xstatp(xc,RC2)+nregions] = i + nxcols - 1 + Memi[rg_xstatp(xc,RL1)+nregions] = j + Memi[rg_xstatp(xc,RL2)+nregions] = j + nylines - 1 + Memr[rg_xstatp(xc,RZERO)+nregions] = INDEFR + Memr[rg_xstatp(xc,RXSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,RYSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,XSHIFTS)+nregions] = INDEFR + Memr[rg_xstatp(xc,YSHIFTS)+nregions] = INDEFR + nregions = nregions + 1 + } + } + + call rg_xseti (xc, NREGIONS, nregions) + if (nregions > 0) + call rg_xrealloc (xc, nregions) + else + call rg_xrfree (xc) + call sfree (sp) + + return (nregions) +end + + +# RG_XRREGIONS -- Read and decode the regions from a file. + +int procedure rg_xrregions (fd, im, xc, rp, max_nregions) + +int fd #I regions file descriptor +pointer im #I pointer to the reference image +pointer xc #I pointer to the cross-correlation structure +int rp #I index of the current region +int max_nregions #I the maximum number of regions + +int ncols, nlines, nregions, x1, y1, x2, y2, step +pointer sp, line, section +int rg_xstati(), getline(), rg_xgsections() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_xrealloc (xc, max_nregions) + + # Initialize. + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + nregions = min (rp - 1, rg_xstati (xc, NREGIONS)) + + # Decode the regions string. + while ((getline (fd, Memc[line]) != EOF) && nregions < max_nregions) { + call sscan (Memc[line]) + call gargwrd (Memc[section], SZ_LINE) + while ((Memc[section] != EOS) && (nregions < max_nregions)) { + if (rg_xgsections (Memc[section], x1, x2, step, y1, y2, step, + ncols, nlines) == OK) { + Memi[rg_xstatp(xc,RC1)+nregions] = x1 + Memi[rg_xstatp(xc,RC2)+nregions] = x2 + Memi[rg_xstatp(xc,RL1)+nregions] = y1 + Memi[rg_xstatp(xc,RL2)+nregions] = y2 + Memr[rg_xstatp(xc,RZERO)+nregions] = INDEFR + Memr[rg_xstatp(xc,RXSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,RYSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,XSHIFTS)+nregions] = INDEFR + Memr[rg_xstatp(xc,YSHIFTS)+nregions] = INDEFR + nregions = nregions + 1 + } + call gargwrd (Memc[section], SZ_LINE) + } + } + + # Reallocate the correct amount of space. + call rg_xseti (xc, NREGIONS, nregions) + if (nregions > 0) + call rg_xrealloc (xc, nregions) + else + call rg_xrfree (xc) + + call sfree (sp) + + return (nregions) +end + + +# RG_XGREGIONS -- Decode a list of regions from a string containing +# a list of sections. + +int procedure rg_xgregions (im, xc, rp, max_nregions) + +pointer im #I pointer to the reference image +pointer xc #I pointer to cross-correlation structure +int rp #I the index of the current region +int max_nregions #I the maximum number of regions + +int ncols, nlines, nregions, x1, x2, y1, y2, step +pointer sp, section, region +int rg_xstati(), rg_xgsections() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information. + call rg_xrealloc (xc, max_nregions) + + # Initialize. + call rg_xstats (xc, REGIONS, Memc[region], SZ_LINE) + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + nregions = min (rp - 1, rg_xstati (xc, NREGIONS)) + + # Decode the sections + call sscan (Memc[region]) + call gargwrd (Memc[section], SZ_LINE) + while ((Memc[section] != EOS) && (nregions < max_nregions)) { + if (rg_xgsections (Memc[section], x1, x2, step, y1, y2, step, + ncols, nlines) == OK) { + Memi[rg_xstatp(xc,RC1)+nregions] = x1 + Memi[rg_xstatp(xc,RC2)+nregions] = x2 + Memi[rg_xstatp(xc,RL1)+nregions] = y1 + Memi[rg_xstatp(xc,RL2)+nregions] = y2 + Memr[rg_xstatp(xc,RZERO)+nregions] = INDEFR + Memr[rg_xstatp(xc,RXSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,RYSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,XSHIFTS)+nregions] = INDEFR + Memr[rg_xstatp(xc,YSHIFTS)+nregions] = INDEFR + nregions = nregions + 1 + } + call gargwrd (Memc[section], SZ_LINE) + } + + + # Reallocate the correct amount of space. + call rg_xseti (xc, NREGIONS, nregions) + if (nregions > 0) + call rg_xrealloc (xc, nregions) + else + call rg_xrfree (xc) + + call sfree (sp) + + return (nregions) +end + + +# RG_XGSECTIONS -- Decode an image section into column and line limits +# and a step size. Sections which describe the whole image are decoded into +# a block ncols * nlines long. + +int procedure rg_xgsections (section, x1, x2, xstep, y1, y2, ystep, ncols, + nlines) + +char section[ARB] #I the input section string +int x1, x2 #O the output column section limits +int xstep #O the output column step size +int y1, y2 #O the output line section limits +int ystep #O the output line step size +int ncols, nlines #I the maximum number of lines and columns + +int ip +int rg_xgdim() + +begin + ip = 1 + if (rg_xgdim (section, ip, x1, x2, xstep, ncols) == ERR) + return (ERR) + if (rg_xgdim (section, ip, y1, y2, ystep, nlines) == ERR) + return (ERR) + + return (OK) +end + + +# RG_XGDIM -- Decode a single subscript expression to produce the +# range of values for that subscript (X1:X2), and the sampling step size, STEP. +# Note that X1 may be less than, greater than, or equal to X2, and STEP may +# be a positive or negative nonzero integer. Various shorthand notations are +# permitted, as is embedded whitespace. + +int procedure rg_xgdim (section, ip, x1, x2, step, limit) + +char section[ARB] #I the input image section +int ip #I/O pointer to the position in section string +int x1 #O first limit of dimension +int x2 #O second limit of dimension +int step #O step size of dimension +int limit #I maximum size of dimension + +int temp +int ctoi() + +begin + x1 = 1 + x2 = limit + step = 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + if (section[ip] =='[') + ip = ip + 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + # Get X1, X2. + if (ctoi (section, ip, temp) > 0) { # [x1 + x1 = max (1, min (temp, limit)) + if (section[ip] == ':') { + ip = ip + 1 + if (ctoi (section, ip, temp) == 0) # [x1:x2 + return (ERR) + x2 = max (1, min (temp, limit)) + } else + x2 = x1 + + } else if (section[ip] == '-') { + x1 = limit + x2 = 1 + ip = ip + 1 + if (section[ip] == '*') + ip = ip + 1 + + } else if (section[ip] == '*') # [* + ip = ip + 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + # Get sample step size, if give. + if (section[ip] == ':') { # ..:step + ip = ip + 1 + if (ctoi (section, ip, step) == 0) + return (ERR) + else if (step == 0) + return (ERR) + } + + # Allow notation such as "-*:5", (or even "-:5") where the step + # is obviously supposed to be negative. + + if (x1 > x2 && step > 0) + step = -step + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + if (section[ip] == ',') { + ip = ip + 1 + return (OK) + } else if (section[ip] == ']') + return (OK) + else + return (ERR) +end diff --git a/pkg/images/immatch/src/xregister/rgxshow.x b/pkg/images/immatch/src/xregister/rgxshow.x new file mode 100644 index 00000000..3a746d9c --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxshow.x @@ -0,0 +1,172 @@ +include "xregister.h" + +# RG_XSHOW -- Show the XREGISTER parameters. + +procedure rg_xshow (xc) + +pointer xc #I pointer to the main xregister structure + +begin + call rg_xnshow (xc) + call printf ("\n") + call rg_xbshow (xc) + call printf ("\n") + call rg_xxshow (xc) + call printf ("\n") + call rg_xpshow (xc) +end + + +# RG_XNSHOW -- Show the input/output data XREGISTER parameters. + +procedure rg_xnshow (xc) + +pointer xc #I pointer to the main xregister structure + +pointer sp, str +int rg_xstati() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Set the object characteristics. + call printf ("\nInput/output data\n") + call rg_xstats (xc, IMAGE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str]) + call rg_xstats (xc, REGIONS, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_REGIONS) + call pargstr (Memc[str]) + call printf (" %s = %d %s = %d\n") + call pargstr (KY_XLAG) + call pargi (rg_xstati (xc, XLAG)) + call pargstr (KY_YLAG) + call pargi (rg_xstati (xc, YLAG)) + call printf (" %s = %d %s = %d\n") + call pargstr (KY_DXLAG) + call pargi (rg_xstati (xc, DXLAG)) + call pargstr (KY_DYLAG) + call pargi (rg_xstati (xc, DYLAG)) + call rg_xstats (xc, DATABASE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_DATABASE) + call pargstr (Memc[str]) + call rg_xstats (xc, RECORD, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_RECORD) + call pargstr (Memc[str]) + call rg_xstats (xc, REFFILE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_REFFILE) + call pargstr (Memc[str]) + call rg_xstats (xc, OUTIMAGE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_OUTIMAGE) + call pargstr (Memc[str]) + + call sfree (sp) +end + + +# RG_XBSHOW -- Show the background fitting parameters. + +procedure rg_xbshow (xc) + +pointer xc #I pointer to the main xregister structure + +int back +pointer sp, str +int rg_xstati() +real rg_xstatr() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + back = rg_xstati (xc, BACKGRD) + call printf ("Background fitting parameters:\n") + call rg_xstats (xc, BSTRING, Memc[str], SZ_LINE) + call printf (" %s: %s\n") + call pargstr (KY_BACKGROUND) + call pargstr (Memc[str]) + call printf (" %s = %d\n") + call pargstr (KY_BORDER) + call pargi (rg_xstati (xc, BORDER)) + call printf (" %s = %g %s = %g\n") + call pargstr (KY_LOREJECT) + call pargr (rg_xstatr (xc, LOREJECT)) + call pargstr (KY_HIREJECT) + call pargr (rg_xstatr (xc, HIREJECT)) + call printf (" %s = %g\n") + call pargstr (KY_APODIZE) + call pargr (rg_xstatr (xc, APODIZE)) + call rg_xstats (xc, FSTRING, Memc[str], SZ_LINE) + call printf (" %s: %s\n") + call pargstr (KY_FILTER) + call pargstr (Memc[str]) + + call sfree (sp) +end + + +# RG_XXSHOW -- Show the cross-correlation function parameters. + +procedure rg_xxshow (xc) + +pointer xc #I pointer to the main xregister structure + +pointer sp, str +int rg_xstati() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + call printf ("Cross correlation function:\n") + call rg_xstats (xc, CSTRING, Memc[str], SZ_LINE) + call printf (" %s: %s\n") + call pargstr (KY_CORRELATION) + call pargstr (Memc[str]) + call printf (" %s = %d %s = %d\n") + call pargstr (KY_XWINDOW) + call pargi (rg_xstati (xc, XWINDOW)) + call pargstr (KY_YWINDOW) + call pargi (rg_xstati (xc, YWINDOW)) + + call sfree (sp) +end + + +# RG_XPSHOW -- Show the peak centering parameters. + +procedure rg_xpshow (xc) + +pointer xc #I pointer to the main xregister structure + +pointer sp, str +int rg_xstati() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + call printf ("Peak centering parameters:\n") + call rg_xstats (xc, PSTRING, Memc[str], SZ_LINE) + call printf (" %s: %s\n") + call pargstr (KY_PEAKCENTER) + call pargstr (Memc[str]) + call printf (" %s = %d %s = %d\n") + call pargstr (KY_XCBOX) + call pargi (rg_xstati (xc, XCBOX)) + call pargstr (KY_YCBOX) + call pargi (rg_xstati (xc, YCBOX)) + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/xregister/rgxtools.x b/pkg/images/immatch/src/xregister/rgxtools.x new file mode 100644 index 00000000..e1fb921e --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxtools.x @@ -0,0 +1,685 @@ +include "xregister.h" + +# RG_XINIT -- Initialize the cross-correlation code fitting structure. + +procedure rg_xinit (xc, cfunc) + +pointer xc #O pointer to the cross-correlation structure +int cfunc #I the input cross-correlation function + +begin + call malloc (xc, LEN_XCSTRUCT, TY_STRUCT) + + # Initialize the regions pointers. + XC_RC1(xc) = NULL + XC_RC2(xc) = NULL + XC_RL1(xc) = NULL + XC_RL2(xc) = NULL + XC_RZERO(xc) = NULL + XC_RXSLOPE(xc) = NULL + XC_RYSLOPE(xc) = NULL + XC_XSHIFTS(xc) = NULL + XC_YSHIFTS(xc) = NULL + XC_TXSHIFT(xc) = 0.0 + XC_TYSHIFT(xc) = 0.0 + XC_NREGIONS(xc) = 0 + XC_CREGION(xc) = 1 + + # Set up transformation parameters. + XC_NREFPTS(xc) = 0 + call malloc (XC_XREF(xc), MAX_NREF, TY_REAL) + call malloc (XC_YREF(xc), MAX_NREF, TY_REAL) + call malloc (XC_TRANSFORM(xc), MAX_NTRANSFORM, TY_REAL) + + # Initialize the region offsets + XC_IXLAG(xc) = DEF_IXLAG + XC_IYLAG(xc) = DEF_IYLAG + XC_XLAG(xc) = DEF_IXLAG + XC_YLAG(xc) = DEF_IYLAG + XC_DXLAG(xc) = DEF_DXLAG + XC_DYLAG(xc) = DEF_DYLAG + + # Define the background fitting parameters. + XC_BACKGRD(xc) = XC_BNONE + call strcpy ("none", XC_BSTRING(xc), SZ_FNAME) + XC_BVALUER(xc) = 0.0 + XC_BVALUE(xc) = 0.0 + XC_BORDER(xc) = DEF_BORDER + XC_LOREJECT(xc) = DEF_LOREJECT + XC_HIREJECT(xc) = DEF_HIREJECT + XC_APODIZE(xc) = 0.0 + XC_FILTER(xc) = XC_FNONE + call strcpy ("none", XC_FSTRING(xc), SZ_FNAME) + + # Get the correlation parameters. + XC_CFUNC(xc) = cfunc + switch (cfunc) { + case XC_DISCRETE: + call strcpy ("discrete", XC_CSTRING(xc), SZ_FNAME) + case XC_FOURIER: + call strcpy ("fourier", XC_CSTRING(xc), SZ_FNAME) + case XC_FILE: + call strcpy ("file", XC_CSTRING(xc), SZ_FNAME) + case XC_DIFFERENCE: + call strcpy ("difference", XC_CSTRING(xc), SZ_FNAME) + default: + call strcpy ("unknown", XC_CSTRING(xc), SZ_FNAME) + } + XC_XWINDOW(xc) = DEF_XWINDOW + XC_YWINDOW(xc) = DEF_YWINDOW + XC_XCOR(xc) = NULL + + # Define the peak fitting function. + XC_PFUNC(xc) = DEF_PFUNC + call sprintf (XC_PSTRING(xc), SZ_FNAME, "%s") + call pargstr ("centroid") + XC_XCBOX(xc) = DEF_XCBOX + XC_YCBOX(xc) = DEF_YCBOX + + # Initialize the strings. + XC_IMAGE(xc) = EOS + XC_REFIMAGE(xc) = EOS + XC_REGIONS(xc) = EOS + XC_DATABASE(xc) = EOS + XC_OUTIMAGE(xc) = EOS + XC_REFFILE(xc) = EOS + XC_RECORD(xc) = EOS + + # Initialize the buffers. + call rg_xrinit (xc) + +end + + +# RG_XRINIT -- Initialize the regions definition portion of the +# cross correlation code fitting structure. + +procedure rg_xrinit (xc) + +pointer xc #I pointer to crosscor structure + +begin + call rg_xrfree (xc) + + XC_NREGIONS(xc) = 0 + XC_CREGION(xc) = 1 + + call malloc (XC_RC1(xc), MAX_NREGIONS, TY_INT) + call malloc (XC_RC2(xc), MAX_NREGIONS, TY_INT) + call malloc (XC_RL1(xc), MAX_NREGIONS, TY_INT) + call malloc (XC_RL2(xc), MAX_NREGIONS, TY_INT) + call malloc (XC_RZERO(xc), MAX_NREGIONS, TY_REAL) + call malloc (XC_RXSLOPE(xc), MAX_NREGIONS, TY_REAL) + call malloc (XC_RYSLOPE(xc), MAX_NREGIONS, TY_REAL) + call malloc (XC_XSHIFTS(xc), MAX_NREGIONS, TY_REAL) + call malloc (XC_YSHIFTS(xc), MAX_NREGIONS, TY_REAL) + + call amovki (INDEFI, Memi[XC_RC1(xc)], MAX_NREGIONS) + call amovki (INDEFI, Memi[XC_RC2(xc)], MAX_NREGIONS) + call amovki (INDEFI, Memi[XC_RL1(xc)], MAX_NREGIONS) + call amovki (INDEFI, Memi[XC_RL2(xc)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[XC_RZERO(xc)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[XC_RXSLOPE(xc)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[XC_RYSLOPE(xc)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[XC_XSHIFTS(xc)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[XC_YSHIFTS(xc)], MAX_NREGIONS) + + XC_TXSHIFT(xc) = 0.0 + XC_TYSHIFT(xc) = 0.0 +end + + +# RG_XCINDEFR -- Re-initialize the background and answers regions portion of +# the cross-correlation fitting structure + +procedure rg_xcindefr (xc, creg) + +pointer xc #I pointer to the cross-correlation structure +int creg #I the current region + +int nregions +int rg_xstati() + +begin + nregions = rg_xstati (xc, NREGIONS) + if (creg < 1 || creg > nregions) + return + + if (nregions > 0) { + Memr[XC_RZERO(xc)+creg-1] = INDEFR + Memr[XC_RXSLOPE(xc)+creg-1] = INDEFR + Memr[XC_RYSLOPE(xc)+creg-1] = INDEFR + Memr[XC_XSHIFTS(xc)+creg-1] = INDEFR + Memr[XC_YSHIFTS(xc)+creg-1] = INDEFR + } + + XC_TXSHIFT(xc) = 0.0 + XC_TYSHIFT(xc) = 0.0 +end + + +# RG_XINDEFR -- Re-initialize the background and answers regions portion of +# the cross-correlation fitting structure for all regions and reset the +# current region to 1. + +procedure rg_xindefr (xc) + +pointer xc #I pointer to the cross-correlation structure + +int nregions +int rg_xstati() + +begin + nregions = rg_xstati (xc, NREGIONS) + + if (nregions > 0) { + call amovkr (INDEFR, Memr[XC_RZERO(xc)], nregions) + call amovkr (INDEFR, Memr[XC_RXSLOPE(xc)], nregions) + call amovkr (INDEFR, Memr[XC_RYSLOPE(xc)], nregions) + call amovkr (INDEFR, Memr[XC_XSHIFTS(xc)], nregions) + call amovkr (INDEFR, Memr[XC_YSHIFTS(xc)], nregions) + } + + XC_CREGION(xc) = 1 + XC_TXSHIFT(xc) = 0.0 + XC_TYSHIFT(xc) = 0.0 +end + + +# RG_XREALLOC -- Reallocate the regions bufffers and initialize if necessary. + +procedure rg_xrealloc (xc, nregions) + +pointer xc #I pointer to crosscor structure +int nregions #I number of regions + +int nr +int rg_xstati() + +begin + nr = rg_xstati (xc, NREGIONS) + + call realloc (XC_RC1(xc), nregions, TY_INT) + call realloc (XC_RC2(xc), nregions, TY_INT) + call realloc (XC_RL1(xc), nregions, TY_INT) + call realloc (XC_RL2(xc), nregions, TY_INT) + call realloc (XC_RZERO(xc), nregions, TY_REAL) + call realloc (XC_RXSLOPE(xc), nregions, TY_REAL) + call realloc (XC_RYSLOPE(xc), nregions, TY_REAL) + call realloc (XC_XSHIFTS(xc), nregions, TY_REAL) + call realloc (XC_YSHIFTS(xc), nregions, TY_REAL) + + call amovki (INDEFI, Memi[XC_RC1(xc)+nr], nregions - nr) + call amovki (INDEFI, Memi[XC_RC2(xc)+nr], nregions - nr) + call amovki (INDEFI, Memi[XC_RL1(xc)+nr], nregions - nr) + call amovki (INDEFI, Memi[XC_RL2(xc)+nr], nregions - nr) + call amovkr (INDEFR, Memr[XC_RZERO(xc)+nr], nregions - nr) + call amovkr (INDEFR, Memr[XC_RXSLOPE(xc)+nr], nregions - nr) + call amovkr (INDEFR, Memr[XC_RYSLOPE(xc)+nr], nregions - nr) + call amovkr (INDEFR, Memr[XC_XSHIFTS(xc)+nr], nregions - nr) + call amovkr (INDEFR, Memr[XC_YSHIFTS(xc)+nr], nregions - nr) +end + + +# RG_XFREE -- Free the cross-correlation fitting structure. + +procedure rg_xfree (xc) + +pointer xc #I pointer to the cross-correlation structure + +begin + # Free the region descriptors. + call rg_xrfree (xc) + + # Free the transformation descriptors. + if (XC_XREF(xc) != NULL) + call mfree (XC_XREF(xc), TY_REAL) + if (XC_YREF(xc) != NULL) + call mfree (XC_YREF(xc), TY_REAL) + if (XC_TRANSFORM(xc) != NULL) + call mfree (XC_TRANSFORM(xc), TY_REAL) + + # Free the correlation function. + if (XC_XCOR(xc) != NULL) + call mfree (XC_XCOR(xc), TY_REAL) + + call mfree (xc, TY_STRUCT) +end + + +# RG_XRFREE -- Free the regions portion of the cross-correlation structure. + +procedure rg_xrfree (xc) + +pointer xc #I pointer to the cross-correlation structure + +begin + call rg_xseti (xc, NREGIONS, 0) + if (XC_RC1(xc) != NULL) + call mfree (XC_RC1(xc), TY_INT) + XC_RC1(xc) = NULL + if (XC_RC2(xc) != NULL) + call mfree (XC_RC2(xc), TY_INT) + XC_RC2(xc) = NULL + if (XC_RL1(xc) != NULL) + call mfree (XC_RL1(xc), TY_INT) + XC_RL1(xc) = NULL + if (XC_RL2(xc) != NULL) + call mfree (XC_RL2(xc), TY_INT) + XC_RL2(xc) = NULL + if (XC_RZERO(xc) != NULL) + call mfree (XC_RZERO(xc), TY_REAL) + XC_RZERO(xc) = NULL + if (XC_RXSLOPE(xc) != NULL) + call mfree (XC_RXSLOPE(xc), TY_REAL) + XC_RXSLOPE(xc) = NULL + if (XC_RYSLOPE(xc) != NULL) + call mfree (XC_RYSLOPE(xc), TY_REAL) + XC_RYSLOPE(xc) = NULL + if (XC_XSHIFTS(xc) != NULL) + call mfree (XC_XSHIFTS(xc), TY_REAL) + XC_XSHIFTS(xc) = NULL + if (XC_YSHIFTS(xc) != NULL) + call mfree (XC_YSHIFTS(xc), TY_REAL) + XC_YSHIFTS(xc) = NULL +end + + +# RG_XSTATI -- Fetch the value of a cross-correlation fitting structure +# integer parameter. + +int procedure rg_xstati (xc, param) + +pointer xc #I pointer to the cross-correlation fitting structure +int param #I parameter to be fetched + +begin + switch (param) { + case CFUNC: + return (XC_CFUNC(xc)) + case IXLAG: + return (XC_IXLAG(xc)) + case IYLAG: + return (XC_IYLAG(xc)) + case XLAG: + return (XC_XLAG(xc)) + case YLAG: + return (XC_YLAG(xc)) + case DXLAG: + return (XC_DXLAG(xc)) + case DYLAG: + return (XC_DYLAG(xc)) + case XWINDOW: + return (XC_XWINDOW(xc)) + case YWINDOW: + return (XC_YWINDOW(xc)) + case CREGION: + return (XC_CREGION(xc)) + case NREGIONS: + return (XC_NREGIONS(xc)) + case BACKGRD: + return (XC_BACKGRD(xc)) + case BORDER: + return (XC_BORDER(xc)) + case FILTER: + return (XC_FILTER(xc)) + case XCBOX: + return (XC_XCBOX(xc)) + case YCBOX: + return (XC_YCBOX(xc)) + case PFUNC: + return (XC_PFUNC(xc)) + case NREFPTS: + return (XC_NREFPTS(xc)) + default: + call error (0, "RG_XSTATI: Undefined integer parameter.") + } +end + + +# RG_XSTATP -- Fetch the value of a pointer parameter. + +pointer procedure rg_xstatp (xc, param) + +pointer xc #I pointer to the cross-correlation structure +int param #I parameter to be fetched + +begin + switch (param) { + case RC1: + return (XC_RC1(xc)) + case RC2: + return (XC_RC2(xc)) + case RL1: + return (XC_RL1(xc)) + case RL2: + return (XC_RL2(xc)) + case RZERO: + return (XC_RZERO(xc)) + case RXSLOPE: + return (XC_RXSLOPE(xc)) + case RYSLOPE: + return (XC_RYSLOPE(xc)) + case XSHIFTS: + return (XC_XSHIFTS(xc)) + case YSHIFTS: + return (XC_YSHIFTS(xc)) + case XCOR: + return (XC_XCOR(xc)) + case XREF: + return (XC_XREF(xc)) + case YREF: + return (XC_YREF(xc)) +# case CORAPODIZE: +# return (XC_CORAPODIZE(xc)) + case TRANSFORM: + return (XC_TRANSFORM(xc)) + default: + call error (0, "RG_XSTATP: Undefined pointer parameter.") + } +end + + +# RG_XSTATR -- Fetch the value of a real parameter. + +real procedure rg_xstatr (xc, param) + +pointer xc #I pointer to the cross-correlation structure +int param #I parameter to be fetched + +begin + switch (param) { + case BVALUER: + return (XC_BVALUER(xc)) + case BVALUE: + return (XC_BVALUE(xc)) + case LOREJECT: + return (XC_LOREJECT(xc)) + case HIREJECT: + return (XC_HIREJECT(xc)) + case APODIZE: + return (XC_APODIZE(xc)) + case TXSHIFT: + return (XC_TXSHIFT(xc)) + case TYSHIFT: + return (XC_TYSHIFT(xc)) + default: + call error (0, "RG_XSTATR: Undefined real parameter.") + } +end + + +# RG_XSTATS -- Fetch the value of a string parameter. + +procedure rg_xstats (xc, param, str, maxch) + +pointer xc #I pointer to the cross-correlation structure +int param #I parameter to be fetched +char str[ARB] #O output value of string parameter +int maxch #I maximum number of characters in output string + +begin + switch (param) { + case BSTRING: + call strcpy (XC_BSTRING(xc), str, maxch) + case FSTRING: + call strcpy (XC_FSTRING(xc), str, maxch) + case CSTRING: + call strcpy (XC_CSTRING(xc), str, maxch) + case PSTRING: + call strcpy (XC_PSTRING(xc), str, maxch) + case REFIMAGE: + call strcpy (XC_REFIMAGE(xc), str, maxch) + case IMAGE: + call strcpy (XC_IMAGE(xc), str, maxch) + case OUTIMAGE: + call strcpy (XC_OUTIMAGE(xc), str, maxch) + case REGIONS: + call strcpy (XC_REGIONS(xc), str, maxch) + case DATABASE: + call strcpy (XC_DATABASE(xc), str, maxch) + case RECORD: + call strcpy (XC_RECORD(xc), str, maxch) + case REFFILE: + call strcpy (XC_REFFILE(xc), str, maxch) + default: + call error (0, "RG_XSTATS: Undefined string parameter.") + } +end + + +# RG_XSETI -- Set the value of an integer parameter. + +procedure rg_xseti (xc, param, value) + +pointer xc #I pointer to the cross-correlation structure +int param #I parameter to be set +int value #O value of the integer parameter + +begin + switch (param) { + case CFUNC: + XC_CFUNC(xc) = value + switch (value) { + case XC_DISCRETE: + call strcpy ("discrete", XC_CSTRING(xc), SZ_FNAME) + case XC_FOURIER: + call strcpy ("fourier", XC_CSTRING(xc), SZ_FNAME) + case XC_FILE: + call strcpy ("file", XC_CSTRING(xc), SZ_FNAME) + case XC_DIFFERENCE: + call strcpy ("difference", XC_CSTRING(xc), SZ_FNAME) + default: + call strcpy ("unknown", XC_CSTRING(xc), SZ_FNAME) + } + case IXLAG: + XC_IXLAG(xc) = value + case IYLAG: + XC_IYLAG(xc) = value + case XLAG: + XC_XLAG(xc) = value + case YLAG: + XC_YLAG(xc) = value + case DXLAG: + XC_DXLAG(xc) = value + case DYLAG: + XC_DYLAG(xc) = value + case XWINDOW: + XC_XWINDOW(xc) = value + case YWINDOW: + XC_YWINDOW(xc) = value + case BACKGRD: + XC_BACKGRD(xc) = value + switch (value) { + case XC_BNONE: + call strcpy ("none", XC_BSTRING(xc), SZ_FNAME) + case XC_MEAN: + call strcpy ("mean", XC_BSTRING(xc), SZ_FNAME) + case XC_MEDIAN: + call strcpy ("median", XC_BSTRING(xc), SZ_FNAME) + case XC_SLOPE: + call strcpy ("plane", XC_BSTRING(xc), SZ_FNAME) + default: + call strcpy ("none", XC_BSTRING(xc), SZ_FNAME) + } + case BORDER: + XC_BORDER(xc) = value + case FILTER: + XC_FILTER(xc) = value + switch (value) { + case XC_FNONE: + call strcpy ("none", XC_FSTRING(xc), SZ_FNAME) + case XC_LAPLACE: + call strcpy ("laplace", XC_FSTRING(xc), SZ_FNAME) + default: + call strcpy ("none", XC_FSTRING(xc), SZ_FNAME) + } + case XCBOX: + XC_XCBOX(xc) = value + case YCBOX: + XC_YCBOX(xc) = value + case PFUNC: + XC_PFUNC(xc) = value + switch (value) { + case XC_PNONE: + call strcpy ("none", XC_PSTRING(xc), SZ_FNAME) + case XC_CENTROID: + call strcpy ("centroid", XC_PSTRING(xc), SZ_FNAME) + case XC_PARABOLA: + call strcpy ("parabolic", XC_PSTRING(xc), SZ_FNAME) + case XC_SAWTOOTH: + call strcpy ("sawtooth", XC_PSTRING(xc), SZ_FNAME) +# case XC_MARK: +# call strcpy ("mark", XC_PSTRING(xc), SZ_FNAME) + default: + ; + } + case NREFPTS: + XC_NREFPTS(xc) = value + case CREGION: + XC_CREGION(xc) = value + case NREGIONS: + XC_NREGIONS(xc) = value + default: + call error (0, "RG_XSETI: Undefined integer parameter.") + } +end + + +# RG_XSETP -- Set the value of a pointer parameter. + +procedure rg_xsetp (xc, param, value) + +pointer xc #I pointer to the cross-correlation structure +int param #I parameter to be set +pointer value #O value of the pointer parameter + +begin + switch (param) { + case RC1: + XC_RC1(xc) = value + case RC2: + XC_RC2(xc) = value + case RL1: + XC_RL1(xc) = value + case RL2: + XC_RL2(xc) = value + case RZERO: + XC_RZERO(xc) = value + case RXSLOPE: + XC_RXSLOPE(xc) = value + case RYSLOPE: + XC_RYSLOPE(xc) = value + case XSHIFTS: + XC_XSHIFTS(xc) = value + case YSHIFTS: + XC_YSHIFTS(xc) = value + case XCOR: + XC_XCOR(xc) = value + case XREF: + XC_XREF(xc) = value + case YREF: + XC_YREF(xc) = value + case TRANSFORM: + XC_TRANSFORM(xc) = value +# case CORAPODIZE: +# XC_CORAPODIZE(xc) = value + default: + call error (0, "RG_XSETP: Undefined pointer parameter.") + } +end + + +# RG_XSETR -- Set the value of a real parameter. + +procedure rg_xsetr (xc, param, value) + +pointer xc #I pointer to the cross-correlation structure +int param #I parameter to be set +real value #O value of real parameter + +begin + switch (param) { + case BVALUER: + XC_BVALUER(xc) = value + case BVALUE: + XC_BVALUE(xc) = value + case LOREJECT: + XC_LOREJECT(xc) = value + case HIREJECT: + XC_HIREJECT(xc) = value + case APODIZE: + XC_APODIZE(xc) = value + case TXSHIFT: + XC_TXSHIFT(xc) = value + case TYSHIFT: + XC_TYSHIFT(xc) = value + default: + call error (0, "RG_XSETR: Undefined real parameter.") + } +end + + +# RG_XSETS -- Set the value of a string parameter. + +procedure rg_xsets (xc, param, str) + +pointer xc #I pointer to the cross-correlation structure +int param #I parameter to be set +char str[ARB] #O value of string parameter + +int index +pointer sp, temp +int strdic(), fnldir() + +begin + call smark (sp) + call salloc (temp, SZ_FNAME, TY_CHAR) + + switch (param) { + case BSTRING: + index = strdic (str, str, SZ_LINE, XC_BTYPES) + if (index > 0) { + call strcpy (str, XC_BSTRING(xc), SZ_FNAME) + call rg_xseti (xc, BACKGRD, index) + } + case FSTRING: + index = strdic (str, str, SZ_LINE, XC_FTYPES) + if (index > 0) { + call strcpy (str, XC_FSTRING(xc), SZ_FNAME) + call rg_xseti (xc, FILTER, index) + } + case CSTRING: + index = strdic (str, str, SZ_LINE, XC_CTYPES) + if (index > 0) { + call strcpy (str, XC_CSTRING(xc), SZ_FNAME) + call rg_xseti (xc, CFUNC, index) + } + case PSTRING: + call strcpy (str, XC_PSTRING(xc), SZ_FNAME) + case REFIMAGE: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], XC_REFIMAGE(xc), SZ_FNAME) + call strcpy (Memc[temp+index], XC_REFIMAGE(xc), SZ_FNAME) + case IMAGE: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], XC_IMAGE(xc), SZ_FNAME) + call strcpy (Memc[temp+index], XC_IMAGE(xc), SZ_FNAME) + case OUTIMAGE: + call strcpy (str, XC_OUTIMAGE(xc), SZ_FNAME) + case REGIONS: + call strcpy (str, XC_REGIONS(xc), SZ_FNAME) + case DATABASE: + index = fnldir (str, XC_DATABASE(xc), SZ_FNAME) + call strcpy (str[index+1], XC_DATABASE(xc), SZ_FNAME) + case RECORD: + call strcpy (str, XC_RECORD(xc), SZ_FNAME) + case REFFILE: + index = fnldir (str, XC_REFFILE(xc), SZ_FNAME) + call strcpy (str[index+1], XC_REFFILE(xc), SZ_FNAME) + default: + call error (0, "RG_XSETS: Undefined string parameter.") + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/xregister/rgxtransform.x b/pkg/images/immatch/src/xregister/rgxtransform.x new file mode 100644 index 00000000..63ee5f24 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxtransform.x @@ -0,0 +1,446 @@ +include <imhdr.h> +include <math.h> +include "xregister.h" + +# RG_GXTRANSFORM -- Open the reference points file and the read the +# coordinates of the reference points in the reference image. Return +# the reference points file name and descriptor. + +int procedure rg_gxtransform (list, xc, reffile) + +int list #I list of reference points files +pointer xc #I pointer to the cross-correlation structure +char reffile[ARB] #O the output reference points file name + +int tdf +pointer sp, line, pxref, pyref +real x1, y1, x2, y2, x3, y3 +int fntgfnb(), open(), getline(), nscan() +pointer rg_xstatp() + +begin + # Get some working memory. + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Get the points to the reference point lists. + pxref = rg_xstatp (xc, XREF) + pyref = rg_xstatp (xc, YREF) + call aclrr (Memr[rg_xstatp(xc, XREF)], MAX_NREF) + call aclrr (Memr[rg_xstatp(xc, YREF)], MAX_NREF) + + # Open the reference points file and read the coordinates. + while (fntgfnb (list, reffile, SZ_FNAME) != EOF) { + + iferr { + + # Open the reference file. + tdf = open (reffile, READ_ONLY, TEXT_FILE) + call aclrr (Memr[pxref], MAX_NREF) + call aclrr (Memr[pyref], MAX_NREF) + + # Read up to three valid reference points from the list. + while (getline (tdf, Memc[line]) != EOF) { + call sscan (Memc[line]) + call gargr (x1) + call gargr (y1) + call gargr (x2) + call gargr (y2) + call gargr (x3) + call gargr (y3) + if (nscan () >= 2) + break + } + + # Store the reference points. + if (nscan () == 2) { + Memr[pxref] = x1 + Memr[pyref] = y1 + call rg_xseti (xc, NREFPTS, 1) + } else if (nscan () == 4) { + Memr[pxref] = x1 + Memr[pyref] = y1 + Memr[pxref+1] = x2 + Memr[pyref+1] = y2 + call rg_xseti (xc, NREFPTS, 2) + } else if (nscan () == 6) { + Memr[pxref] = x1 + Memr[pyref] = y1 + Memr[pxref+1] = x2 + Memr[pyref+1] = y2 + Memr[pxref+2] = x3 + Memr[pyref+2] = y3 + call rg_xseti (xc, NREFPTS, 2) + } else + call rg_xseti (xc, NREFPTS, 0) + + } then { + call rg_xseti (xc, NREFPTS, 0) + } + } + + call sfree (sp) + + return (tdf) +end + + +# RG_ITRANSFORM -- Compute the transformation from the input image to the +# reference image interactively. + +procedure rg_itransform (xc, imr, im, id) + +pointer xc #I pointer to the cross-correlation stucture +pointer imr #I pointer to the reference image +pointer im #I pointer to the input image +pointer id #I pointer to the display device + +int nref, nstar, wcs, key +pointer sp, cmd, x, y, pxref, pyref, ptrans +real wx, wy +int clgcur() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (x, MAX_NREF, TY_REAL) + call salloc (y, MAX_NREF, TY_REAL) + call aclrr (Memr[x], MAX_NREF) + call aclrr (Memr[y], MAX_NREF) + + # Get the pointers. + pxref = rg_xstatp (xc, XREF) + pyref = rg_xstatp (xc, YREF) + ptrans = rg_xstatp (xc, TRANSFORM) + + # Mark up to three reference stars. + nref = 0 + call printf ("Mark reference star %d with the image cursor [q=quit]: ") + call pargi (nref + 1) + while ((nref < MAX_NREF) && clgcur ("icommands", wx, wy, wcs, key, + Memc[cmd], SZ_LINE) != EOF) { + if (key == 'q') { + call printf ("\n") + break + } + if (wx < 0.5 || wx > IM_LEN(imr,1) + 0.5) { + call printf ("\n") + next + } + if (wy < 0.5 || wy > IM_LEN(imr,2) + 0.5) { + call printf ("\n") + next + } + call printf ("%g %g\n") + call pargr (wx) + call pargr (wy) + Memr[pxref+nref] = wx + Memr[pyref+nref] = wy + nref = nref + 1 + call rg_xseti (xc, NREFPTS, nref) + if (nref >= MAX_NREF) + break + call printf ( + "Mark reference star %d with the image cursor [q=quit]: ") + call pargi (nref + 1) + } + + # Mark the corresponding input image stars. + if (nref > 0) { + + nstar = 0 + call printf ("Mark image star %d with the image cursor [q=quit]: ") + call pargi (nstar + 1) + while ((nstar < nref) && clgcur ("icommands", wx, wy, wcs, key, + Memc[cmd], SZ_LINE) != EOF) { + if (key == 'q') { + call printf ("\n") + break + } + if (wx < 0.5 || wx > IM_LEN(im,1) + 0.5) { + call printf ("\n") + next + } + if (wy < 0.5 || wy > IM_LEN(im,2) + 0.5) { + call printf ("\n") + next + } + call printf ("%g %g\n") + call pargr (wx) + call pargr (wy) + Memr[x+nstar] = wx + Memr[y+nstar] = wy + nstar = nstar + 1 + if (nstar >= MAX_NREF) + break + call printf ( + "Mark image star %d with the image cursor [q=quit]: ") + call pargi (nstar + 1) + } + + # Compute the transformation. + if (nstar > 0) { + switch (nstar) { + case 0: + call rg_xshift (Memr[pxref], Memr[pyref], Memr[pxref], + Memr[pyref], Memr[ptrans]) + case 1: + call rg_xshift (Memr[x], Memr[y], Memr[pxref], Memr[pyref], + Memr[ptrans]) + #case 2: + #call rg_xtwostar (Memr[x], Memr[y], Memr[pxref], + #Memr[pyref], Memr[ptrans]) + #case 3: + #call rg_xthreestar (Memr[x], Memr[y], Memr[pxref], + #Memr[pyref], Memr[ptrans]) + + default: + call rg_xshift (Memr[pxref], Memr[pyref], Memr[pxref], + Memr[pyref], Memr[ptrans]) + } + } + } + + call sfree (sp) +end + + +# RG_XTRANSFORM -- Compute the transformation from the input image to +# the reference image + +procedure rg_xtransform (tfd, xc) + +int tfd #I the reference points file descriptor +pointer xc #I the cross-correlation file descriptor + +int nref +pointer sp, line, x, y, pxref, pyref, ptrans +int getline(), rg_xstati(), nscan() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + call salloc (x, MAX_NREF, TY_REAL) + call salloc (y, MAX_NREF, TY_REAL) + call aclrr (Memr[x], MAX_NREF) + call aclrr (Memr[y], MAX_NREF) + + # Get the pointers to the reference image data. + nref = rg_xstati (xc, NREFPTS) + pxref = rg_xstatp (xc, XREF) + pyref = rg_xstatp (xc, YREF) + ptrans = rg_xstatp (xc, TRANSFORM) + + # Read the input image reference points. + while ((nref > 0) && getline (tfd, Memc[line]) != EOF) { + call sscan (Memc[line]) + call gargr (Memr[x]) + call gargr (Memr[y]) + call gargr (Memr[x+1]) + call gargr (Memr[y+1]) + call gargr (Memr[x+2]) + call gargr (Memr[y+2]) + if (nscan() >= 2 * nref) + break + } + + # Compute the transform. + if (nscan () < 2 * nref) { + call rg_xshift (Memr[pxref], Memr[pyref], Memr[pxref], Memr[pyref], + Memr[ptrans]) + } else { + switch (nref) { + case 0: + call rg_xshift (Memr[pxref], Memr[pyref], Memr[pxref], + Memr[pyref], Memr[ptrans]) + case 1: + call rg_xshift (Memr[x], Memr[y], Memr[pxref], Memr[pyref], + Memr[ptrans]) + case 2: + call rg_xtwostar (Memr[x], Memr[y], Memr[pxref], Memr[pyref], + Memr[ptrans]) + case 3: + call rg_xthreestar (Memr[x], Memr[y], Memr[pxref], Memr[pyref], + Memr[ptrans]) + } + } + + call sfree (sp) +end + + +# RG_ETRANSFORM -- Evaulate the current transform at a single point. + +procedure rg_etransform (xc, xin, yin, xout, yout) + +pointer xc #I pointer to the cross-correlation structure +real xin, yin #I the input x and y values +real xout, yout #O the output x and y values + +pointer ptrans +pointer rg_xstatp + +begin + ptrans = rg_xstatp (xc, TRANSFORM) + xout = Memr[ptrans] * xin + Memr[ptrans+1] * yin + Memr[ptrans+2] + yout = Memr[ptrans+3] * xin + Memr[ptrans+4] * yin + Memr[ptrans+5] +end + + +# RG_XSHIFT -- Compute the transformation coefficients required to define a +# simple shift using a single data point. + +procedure rg_xshift (xref, yref, xlist, ylist, coeff) + +real xref[ARB] #I x reference coordinates +real yref[ARB] #I y reference coordinates +real xlist[ARB] #I x input coordinates +real ylist[ARB] #I y input coordinates +real coeff[ARB] #O output coefficient array + +begin + # Compute the x transformation. + coeff[1] = 1.0 + coeff[2] = 0.0 + coeff[3] = xref[1] - xlist[1] + + # Compute the y transformation. + coeff[4] = 0.0 + coeff[5] = 1.0 + coeff[6] = yref[1] - ylist[1] +end + + +# RG_XTWOSTAR -- Compute the transformation coefficients required to +# define a simple shift, magnification which is the same in x and y, +# and rotation using two data points. + +procedure rg_xtwostar (xref, yref, xlist, ylist, coeff) + +real xref[ARB] #I x reference coordinates +real yref[ARB] #I y reference coordinates +real xlist[ARB] #I x input coordinates +real ylist[ARB] #I y input coordinates +real coeff[ARB] #O coefficient array + +real rot, mag, dxlis, dylis, dxref, dyref, cosrot, sinrot +real rg_xposangle() + +begin + # Compute the deltas. + dxlis = xlist[2] - xlist[1] + dylis = ylist[2] - ylist[1] + dxref = xref[2] - xref[1] + dyref = yref[2] - yref[1] + + # Compute the required rotation angle. + rot = rg_xposangle (dxref, dyref) - rg_xposangle (dxlis, dylis) + cosrot = cos (rot) + sinrot = sin (rot) + + # Compute the required magnification factor. + mag = dxlis ** 2 + dylis ** 2 + if (mag <= 0.0) + mag = 0.0 + else + mag = sqrt ((dxref ** 2 + dyref ** 2) / mag) + + # Compute the transformation coefficicents. + coeff[1] = mag * cosrot + coeff[2] = - mag * sinrot + coeff[3] = xref[1] - mag * cosrot * xlist[1] + mag * sinrot * ylist[1] + coeff[4] = mag * sinrot + coeff[5] = mag * cosrot + coeff[6] = yref[1] - mag * sinrot * xlist[1] - mag * cosrot * ylist[1] +end + + +# RG_THREESTAR -- Compute the transformation coefficients required to define +# x and y shifts, x and ymagnifications, a rotation and skew, and a possible +# axis flip using three tie points. + +procedure rg_xthreestar (xref, yref, xlist, ylist, coeff) + +real xref[ARB] #I x reference coordinates +real yref[ARB] #I y reference coordinates +real xlist[ARB] #I x input coordinates +real ylist[ARB] #I y input coordinates +real coeff[ARB] #O coefficient array + +real dx23, dx13, dx12, dy23, dy13, dy12, det +bool fp_equalr() + +begin + # Compute the deltas. + dx23 = xlist[2] - xlist[3] + dx13 = xlist[1] - xlist[3] + dx12 = xlist[1] - xlist[2] + dy23 = ylist[2] - ylist[3] + dy13 = ylist[1] - ylist[3] + dy12 = ylist[1] - ylist[2] + + # Compute the determinant. + det = xlist[1] * dy23 - xlist[2] * dy13 + xlist[3] * dy12 + if (fp_equalr (det, 0.0)) { + call rg_xtwostar (xref, yref, xlist, ylist, coeff) + return + } + + # Compute the x transformation. + coeff[1] = (xref[1] * dy23 - xref[2] * dy13 + xref[3] * dy12) / det + coeff[2] = (-xref[1] * dx23 + xref[2] * dx13 - xref[3] * dx12) / det + coeff[3] = (xref[1] * (xlist[2] * ylist[3] - xlist[3] * ylist[2]) + + xref[2] * (ylist[1] * xlist[3] - xlist[1] * ylist[3]) + + xref[3] * (xlist[1] * ylist[2] - ylist[1] * xlist[2])) / det + + # Compute the y transformation. + coeff[4] = (yref[1] * dy23 - yref[2] * dy13 + yref[3] * dy12) / det + coeff[5] = (-yref[1] * dx23 + yref[2] * dx13 - yref[3] * dx12) / det + coeff[6] = (yref[1] * (xlist[2] * ylist[3] - xlist[3] * ylist[2]) + + yref[2] * (ylist[1] * xlist[3] - xlist[1] * ylist[3]) + + yref[3] * (xlist[1] * ylist[2] - ylist[1] * xlist[2])) / det +end + + +# RG_XPOSANGLE -- Compute the position angle of a 2D vector. The angle is +# measured counter-clockwise from the positive x axis. + +real procedure rg_xposangle (x, y) + +real x #I x vector component +real y #I y vector component + +real theta +bool fp_equalr() + +begin + if (fp_equalr (y, 0.0)) { + if (x > 0.0) + theta = 0.0 + else if (x < 0.0) + theta = PI + else + theta = 0.0 + } else if (fp_equalr (x, 0.0)) { + if (y > 0.0) + theta = PI / 2.0 + else if (y < 0.0) + theta = 3.0 * PI / 2.0 + else + theta = 0.0 + } else if (x > 0.0 && y > 0.0) { # 1st quadrant + theta = atan (y / x) + } else if (x > 0.0 && y < 0.0) { # 4th quadrant + theta = 2.0 * PI + atan (y / x) + } else if (x < 0.0 && y > 0.0) { # 2nd quadrant + theta = PI + atan (y / x) + } else if (x < 0.0 && y < 0.0) { # 3rd quadrant + theta = PI + atan (y / x) + } + + return (theta) +end diff --git a/pkg/images/immatch/src/xregister/t_xregister.x b/pkg/images/immatch/src/xregister/t_xregister.x new file mode 100644 index 00000000..f9fc9b22 --- /dev/null +++ b/pkg/images/immatch/src/xregister/t_xregister.x @@ -0,0 +1,440 @@ +include <imhdr.h> +include <fset.h> +include <gset.h> +include <imset.h> +include "xregister.h" + +# T_XREGISTER -- Register a list of images using cross-correlation techniques. + +procedure t_xregister() + +pointer freglist # reference regions list +pointer database # the shifts database +int dformat # use the database format for the shifts file ? +int interactive # interactive mode ? +int verbose # verbose mode +pointer interpstr # interpolant type +int boundary # boundary extension type +real constant # constant for boundary extension + +int list1, listr, list2, reglist, reflist, reclist, tfd, stat, nregions +int c1, c2, l1, l2, ncols, nlines +pointer sp, image1, image2, imtemp, str, coords +pointer gd, id, imr, im1, im2, sdb, xc, mw +real shifts[2] +bool clgetb() +int imtopen(), imtlen(), imtgetim(), fntopnb(), clgwrd(), btoi() +int rg_xregions(), fntlenb(), rg_gxtransform(), rg_xstati() +int rg_xcorr(), rg_xicorr(), fntgfnb(), access(), open() +pointer gopen(), immap(), dtmap(), mw_openim() +real clgetr(), rg_xstatr() +errchk fntopnb(), gopen() + +begin + # Set STDOUT to flush on a newline character + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate temporary working space. + call smark (sp) + + call salloc (freglist, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (database, SZ_FNAME, TY_CHAR) + call salloc (coords, SZ_FNAME, TY_CHAR) + call salloc (interpstr, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get task parameters and open lists. + call clgstr ("input", Memc[str], SZ_LINE) + list1 = imtopen (Memc[str]) + call clgstr ("reference", Memc[str], SZ_LINE) + listr = imtopen (Memc[str]) + call clgstr ("regions", Memc[freglist], SZ_LINE) + call clgstr ("shifts", Memc[database], SZ_FNAME) + call clgstr ("output", Memc[str], SZ_LINE) + list2 = imtopen (Memc[str]) + call clgstr ("records", Memc[str], SZ_LINE) + if (Memc[str] == EOS) + reclist = NULL + else + reclist = fntopnb (Memc[str], NO) + call clgstr ("coords", Memc[coords], SZ_LINE) + + # Open the cross correlation fitting structure. + call rg_xgpars (xc) + + # Test the reference image list length. + if (rg_xstati (xc, CFUNC) != XC_FILE) { + if (imtlen (listr) <= 0) + call error (0, "The reference image list is empty.") + if (imtlen (listr) > 1 && imtlen (listr) != imtlen (list1)) + call error (0, + "The number of reference and input images is not the same.") + if (Memc[coords] == EOS) + reflist = NULL + else { + reflist = fntopnb (Memc[coords], NO) + if (imtlen (listr) != fntlenb (reflist)) + call error (0, + "The number of reference point files and images is not the same.") + } + iferr { + reglist = fntopnb (Memc[freglist], NO) + } then { + reglist = NULL + } + call rg_xsets (xc, REGIONS, Memc[freglist]) + + } else { + call imtclose (listr) + listr = NULL + reflist = NULL + reglist = NULL + call rg_xsets (xc, REGIONS, "") + } + + # Close the output image list if it is empty. + if (imtlen (list2) == 0) { + call imtclose (list2) + list2 = NULL + } + + # Check that the output image list is the same size as the input + # image list. + if (list2 != NULL) { + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + if (list2 != NULL) + call imtclose (list2) + call error (0, + "The number of input and output images is not the same.") + } + } + + # Check that the record list is the same length as the input + # image list length. + if (reclist != NULL) { + if (fntlenb (reclist) != imtlen (list1)) + call error (0, + "Input image and record lists are not the same length.") + } + + + # Open the database file. + dformat = btoi (clgetb ("databasefmt")) + if (rg_xstati (xc, CFUNC) == XC_FILE) { + if (dformat == YES) + sdb = dtmap (Memc[database], READ_ONLY) + else + sdb = open (Memc[database], READ_ONLY, TEXT_FILE) + } else if (clgetb ("append")) { + if (dformat == YES) + sdb = dtmap (Memc[database], APPEND) + else + sdb = open (Memc[database], NEW_FILE, TEXT_FILE) + } else if (access (Memc[database], 0, 0) == YES) { + call error (0, "The shifts database file already exists") + } else { + if (dformat == YES) + sdb = dtmap (Memc[database], NEW_FILE) + else + sdb = open (Memc[database], NEW_FILE, TEXT_FILE) + } + call rg_xsets (xc, DATABASE, Memc[database]) + + # Get the boundary extension parameters for the image shift. + call clgstr ("interp_type", Memc[interpstr], SZ_FNAME) + boundary = clgwrd ("boundary_type", Memc[str], SZ_LINE, + "|constant|nearest|reflect|wrap|") + constant = clgetr ("constant") + + if (rg_xstati (xc, CFUNC) == XC_FILE) + interactive = NO + else + interactive = btoi (clgetb ("interactive")) + if (interactive == YES) { + call clgstr ("graphics", Memc[str], SZ_FNAME) + iferr (gd = gopen (Memc[str], NEW_FILE, STDGRAPH)) + gd = NULL + call clgstr ("display", Memc[str], SZ_FNAME) + iferr (id = gopen (Memc[str], APPEND, STDIMAGE)) + id = NULL + verbose = YES + } else { + if (rg_xstati (xc, PFUNC) == XC_MARK) + call rg_xseti (xc, PFUNC, XC_CENTROID) + gd = NULL + id = NULL + verbose = btoi (clgetb ("verbose")) + } + + # Initialize the reference image filter descriptors + imr = NULL + tfd = NULL + + # Initialize the overlap section. + c1 = INDEFI + c2 = INDEFI + l1 = INDEFI + l2 = INDEFI + ncols = INDEFI + nlines = INDEFI + + # Do each set of input, reference, and output images. + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF)) { + + # Open the reference image, and associated regions and coordinates + # files if the correlation function is not file. + + if (rg_xstati (xc, CFUNC) != XC_FILE) { + if (imtgetim (listr, Memc[str], SZ_FNAME) != EOF) { + if (imr != NULL) + call imunmap (imr) + imr = immap (Memc[str], READ_ONLY, 0) + if (IM_NDIM(imr) > 2) + call error (0, "Reference images must be 1D or 2D") + call rg_xsets (xc, REFIMAGE, Memc[str]) + nregions = rg_xregions (reglist, imr, xc, 1) + if (nregions <= 0 && interactive == NO) + call error (0, "The regions list is empty.") + if (reflist != NULL) { + if (tfd != NULL) + call close (tfd) + tfd = rg_gxtransform (reflist, xc, Memc[str]) + call rg_xsets (xc, REFFILE, Memc[str]) + } + } + } else + call rg_xsets (xc, REFIMAGE, "reference") + + # Open the input image. + im1 = immap (Memc[image1], READ_ONLY, 0) + if (IM_NDIM(im1) > 2) { + call error (0, "Input images must be 1D or 2D") + } else if (imr != NULL) { + if (IM_NDIM(im1) != IM_NDIM(imr)) + call error (0, + "Input images must have same dimensionality as reference images") + } + call imseti (im1, IM_TYBNDRY, BT_NEAREST) + if (IM_NDIM(im1) == 1) + call imseti (im1, IM_NBNDRYPIX, IM_LEN(im1,1)) + else + call imseti (im1, IM_NBNDRYPIX, + max (IM_LEN(im1,1), IM_LEN(im1,2))) + call rg_xsets (xc, IMAGE, Memc[image1]) + + # Open the output image if any. + if (list2 == NULL) { + im2 = NULL + Memc[image2] = EOS + } else if (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF) { + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + im2 = immap (Memc[image2], NEW_COPY, im1) + } else { + im2 = NULL + Memc[image2] = EOS + } + call rg_xsets (xc, OUTIMAGE, Memc[image2]) + + # Get the image record name for the shifts database. + if (reclist == NULL) + call strcpy (Memc[image1], Memc[str], SZ_FNAME) + else if (fntgfnb (reclist, Memc[str], SZ_FNAME) == EOF) + call strcpy (Memc[image1], Memc[str], SZ_FNAME) + call rg_xsets (xc, RECORD, Memc[str]) + + # Compute the initial coordinate shift. + if (tfd != NULL) + call rg_xtransform (tfd, xc) + + # Perform the cross correlation function. + if (interactive == YES) { + stat = rg_xicorr (imr, im1, im2, sdb, dformat, reglist, tfd, + xc, gd, id) + } else { + stat = rg_xcorr (imr, im1, sdb, dformat, xc) + if (verbose == YES) { + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_LINE) + call printf ( + "Average shift from %s to %s is %g %g pixels\n") + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call pargr (rg_xstatr (xc, TXSHIFT)) + call pargr (rg_xstatr (xc, TYSHIFT)) + } + } + + # Compute the overlap region for the images. + call rg_overlap (im1, rg_xstatr (xc, TXSHIFT), + rg_xstatr (xc,TYSHIFT), c1, c2, l1, l2, ncols, nlines) + + # Shift the image and update the wcs. + if (im2 != NULL && stat == NO) { + if (verbose == YES) { + call printf ( + "\tShifting image %s to image %s ...\n") + call pargstr (Memc[image1]) + call pargstr (Memc[imtemp]) + } + + call rg_xshiftim (im1, im2, rg_xstatr (xc, TXSHIFT), + rg_xstatr (xc, TYSHIFT), Memc[interpstr], boundary, + constant) + mw = mw_openim (im1) + shifts[1] = rg_xstatr (xc, TXSHIFT) + shifts[2] = rg_xstatr (xc, TYSHIFT) + call mw_shift (mw, shifts, 03B) + call mw_saveim (mw, im2) + call mw_close (mw) + } + + # Close up the input and output images. + call imunmap (im1) + if (im2 != NULL) { + call imunmap (im2) + if (stat == YES) + call imdelete (Memc[image2]) + else + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + + if (stat == YES) + break + call rg_xindefr (xc) + } + + if (verbose == YES) + call rg_poverlap (c1, c2, l1, l2, ncols, nlines) + + call rg_xfree (xc) + + # Close up the lists. + if (imr != NULL) + call imunmap (imr) + call imtclose (list1) + if (listr != NULL) + call imtclose (listr) + if (reglist != NULL) + call fntclsb (reglist) + if (list2 != NULL) + call imtclose (list2) + if (tfd != NULL) + call close (tfd) + if (reflist != NULL) + call fntclsb (reflist) + if (reclist != NULL) + call fntclsb (reclist) + if (dformat == YES) + call dtunmap (sdb) + else + call close (sdb) + + # Close up the graphics and display devices. + if (gd != NULL) + call gclose (gd) + if (id != NULL) + call gclose (id) + + call sfree (sp) +end + + +# RG_OVERLAP -- Compute the overlap region of the list of images. + +procedure rg_overlap (im1, xshift, yshift, x1, x2, y1, y2, ncols, nlines) + +pointer im1 # pointer to the input image +real xshift # the computed x shift of the input image +real yshift # the computed y shift of the input image +int x1, x2 # the input/output column limits +int y1, y2 # the input/output line limits +int ncols, nlines # the input/output size limits + +int ixlo, ixhi, iylo, iyhi +real xlo, xhi, ylo, yhi + +begin + if (IS_INDEFR(xshift) || IS_INDEFR(yshift)) + return + + # Compute the limits of the shifted image. + xlo = 1.0 + xshift + xhi = IM_LEN(im1,1) + xshift + ylo = 1.0 + yshift + yhi = IM_LEN(im1,2) + yshift + + # Round up or down as appropriate. + ixlo = int (xlo) + if (xlo > ixlo) + ixlo = ixlo + 1 + ixhi = int (xhi) + if (xhi < ixhi) + ixhi = ixhi - 1 + iylo = int (ylo) + if (ylo > iylo) + iylo = iylo + 1 + iyhi = int (yhi) + if (yhi < iyhi) + iyhi = iyhi - 1 + + # Determine the new limits. + if (IS_INDEFI(x1)) + x1 = ixlo + else + x1 = max (ixlo, x1) + if (IS_INDEFI(x2)) + x2 = ixhi + else + x2 = min (ixhi, x2) + if (IS_INDEFI(y1)) + y1 = iylo + else + y1 = max (iylo, y1) + if (IS_INDEFI(y2)) + y2 = iyhi + else + y2 = min (iyhi, y2) + if (IS_INDEFI(ncols)) + ncols = IM_LEN(im1,1) + else + ncols = min (ncols, IM_LEN(im1,1)) + if (IS_INDEFI(nlines)) + nlines = IM_LEN(im1,2) + else + nlines = min (nlines, IM_LEN(im1,2)) +end + + +# RG_POVERLAP -- Procedure to print the overlap and/or vignetted region. + +procedure rg_poverlap (x1, x2, y1, y2, ncols, nlines) + +int x1, x2 # the input column limits +int y1, y2 # the input line limits +int ncols, nlines # the number of lines and columns + +int vx1, vx2, vy1, vy2 + +begin + vx1 = max (1, min (x1, ncols)) + vx2 = max (1, min (x2, ncols)) + vy1 = max (1, min (y1, nlines)) + vy2 = max (1, min (y2, nlines)) + + call printf ("Overlap region: [%d:%d,%d:%d]\n") + call pargi (x1) + call pargi (x2) + call pargi (y1) + call pargi (y2) + if (vx1 != x1 || vx2 != x2 || vy1 != y1 || vy2 != y2) { + call printf ("Vignetted overlap region: [%d:%d,%d:%d]\n") + call pargi (vx1) + call pargi (vx2) + call pargi (vy1) + call pargi (vy2) + } +end diff --git a/pkg/images/immatch/src/xregister/xregister.h b/pkg/images/immatch/src/xregister/xregister.h new file mode 100644 index 00000000..16c88b1e --- /dev/null +++ b/pkg/images/immatch/src/xregister/xregister.h @@ -0,0 +1,250 @@ +# Header file for XREGISTER + +# Define the cross correlation structure + +define LEN_XCSTRUCT (50 + 12 * SZ_FNAME + 12) + +define XC_RC1 Memi[$1] # pointers to 1st column of ref regions +define XC_RC2 Memi[$1+1] # pointers to 2nd column of ref regions +define XC_RL1 Memi[$1+2] # pointers to 1st line of ref regions +define XC_RL2 Memi[$1+3] # pointers to 2nd line of ref regions +define XC_RZERO Memi[$1+4] # pointers to zero pts of ref regions +define XC_RXSLOPE Memi[$1+5] # pointers to x slopes of ref regions +define XC_RYSLOPE Memi[$1+6] # pointers to y slopes of ref regions +define XC_XSHIFTS Memi[$1+7] # pointers to x shifts of ref regions +define XC_YSHIFTS Memi[$1+8] # pointers to y shifts of ref regions +define XC_NREGIONS Memi[$1+9] # total number of regions +define XC_CREGION Memi[$1+10] # the current region + +define XC_NREFPTS Memi[$1+11] # number of reference points +define XC_XREF Memi[$1+12] # pointer to x reference points +define XC_YREF Memi[$1+13] # pointer to y reference points +define XC_TRANSFORM Memi[$1+14] # pointer to the transform +define XC_IXLAG Memi[$1+15] # initial shift in x +define XC_IYLAG Memi[$1+16] # initial shift in y +define XC_XLAG Memi[$1+17] # current shift in x +define XC_YLAG Memi[$1+18] # current shift in y +define XC_DXLAG Memi[$1+19] # incremental shift in x +define XC_DYLAG Memi[$1+20] # incremental shift in y + +define XC_BACKGRD Memi[$1+21] # type of background subtraction +define XC_BORDER Memi[$1+22] # width of background border +define XC_BVALUER Memr[P2R($1+23)] # reference background value +define XC_BVALUE Memr[P2R($1+24)] # image bacground value +define XC_LOREJECT Memr[P2R($1+25)] # low side rejection +define XC_HIREJECT Memr[P2R($1+26)] # high side rejection +define XC_APODIZE Memr[P2R($1+27)] # fraction of apodized region +define XC_FILTER Memi[$1+28] # filter type + +define XC_CFUNC Memi[$1+30] # crosscor function +define XC_XWINDOW Memi[$1+31] # width of correlation window in x +define XC_YWINDOW Memi[$1+32] # width of correlation window in y +define XC_XCOR Memi[$1+33] # pointer to cross-correlation function + +define XC_PFUNC Memi[$1+34] # correlation peak fitting function +define XC_XCBOX Memi[$1+35] # x width of cor fitting box +define XC_YCBOX Memi[$1+36] # y width of cor fitting box + +define XC_TXSHIFT Memr[P2R($1+37)] # total x shift +define XC_TYSHIFT Memr[P2R($1+38)] # total y shift + +define XC_BSTRING Memc[P2C($1+50)] # background type +define XC_FSTRING Memc[P2C($1+50+SZ_FNAME+1)] # filter string +define XC_CSTRING Memc[P2C($1+50+2*SZ_FNAME+2)] # cross-correlation type +define XC_PSTRING Memc[P2C($1+50+3*SZ_FNAME+3)] # peak centering + +define XC_IMAGE Memc[P2C($1+50+4*SZ_FNAME+4)] # input image +define XC_REFIMAGE Memc[P2C($1+50+5*SZ_FNAME+5)] # reference image +define XC_REGIONS Memc[P2C($1+50+6*SZ_FNAME+6)] # regions list +define XC_DATABASE Memc[P2C($1+50+7*SZ_FNAME+7)] # shifts database +define XC_OUTIMAGE Memc[P2C($1+50+8*SZ_FNAME+8)] # output image +define XC_REFFILE Memc[P2C($1+50+9*SZ_FNAME+9)] # coordinates file +define XC_RECORD Memc[P2C($1+50+10*SZ_FNAME+10)] # record + +# Define the id strings + +define RC1 1 +define RC2 2 +define RL1 3 +define RL2 4 +define RZERO 5 +define RXSLOPE 6 +define RYSLOPE 7 +define XSHIFTS 8 +define YSHIFTS 9 +define NREGIONS 10 +define CREGION 11 + +define NREFPTS 12 +define XREF 13 +define YREF 14 +define TRANSFORM 15 +define IXLAG 16 +define IYLAG 17 +define XLAG 18 +define YLAG 19 +define DXLAG 20 +define DYLAG 21 + +define BACKGRD 22 +define BVALUER 23 +define BVALUE 24 +define BORDER 25 +define LOREJECT 26 +define HIREJECT 27 +define APODIZE 28 +define FILTER 29 + +define CFUNC 30 +define XWINDOW 31 +define YWINDOW 32 +define XCOR 33 + +define PFUNC 34 +define XCBOX 35 +define YCBOX 36 + +define TXSHIFT 37 +define TYSHIFT 38 + +define CSTRING 39 +define BSTRING 40 +define PSTRING 41 +define FSTRING 42 + +define IMAGE 43 +define REFIMAGE 44 +define REGIONS 45 +define OUTIMAGE 46 +define REFFILE 47 +define DATABASE 48 +define RECORD 49 + +# Define the default parameter values + +define DEF_IXLAG 0 +define DEF_IYLAG 0 +define DEF_DXLAG 0 +define DEF_DYLAG 0 +define DEF_XWINDOW 5 +define DEF_YWINDOW 5 + +define DEF_BACKGRD XC_BNONE +define DEF_BORDER INDEFI +define DEF_LOREJECT INDEFR +define DEF_HIREJECT INDEFR + +define DEF_XCBOX 5 +define DEF_YCBOX 5 +define DEF_PFUNC XC_CENTROID + +# Define the background fitting techniques + +define XC_BNONE 1 +define XC_MEAN 2 +define XC_MEDIAN 3 +define XC_SLOPE 4 + +define XC_BTYPES "|none|mean|median|plane|" + +# Define the filtering options + +define XC_FNONE 1 +define XC_LAPLACE 2 + +define XC_FTYPES "|none|laplace|" + +# Define the cross correlation techniques + +define XC_DISCRETE 1 +define XC_FOURIER 2 +define XC_DIFFERENCE 3 +define XC_FILE 4 + +define XC_CTYPES "|discrete|fourier|difference|file|" + +# Define the peak fitting functions + +define XC_PNONE 1 +define XC_CENTROID 2 +define XC_SAWTOOTH 3 +define XC_PARABOLA 4 +define XC_MARK 5 + +define XC_PTYPES "|none|centroid|sawtooth|parabola|mark|" + +# Miscellaneous + +define MAX_NREGIONS 100 +define MAX_NREF 3 +define MAX_NTRANSFORM 6 + +# Commands + +define XCMDS "|reference|input|regions|shifts|output|records|transform|\ +cregion|xlag|ylag|dxlag|dylag|background|border|loreject|hireject|apodize|\ +filter|correlation|xwindow|ywindow|function|xcbox|ycbox|show|mark|" + +define XSHOW "|data|background|correlation|center|" + +define XSHOW_DATA 1 +define XSHOW_BACKGROUND 2 +define XSHOW_CORRELATION 3 +define XSHOW_PEAKCENTER 4 + +define XCMD_REFIMAGE 1 +define XCMD_IMAGE 2 +define XCMD_REGIONS 3 +define XCMD_DATABASE 4 +define XCMD_OUTIMAGE 5 +define XCMD_RECORD 6 +define XCMD_REFFILE 7 +define XCMD_CREGION 8 +define XCMD_XLAG 9 +define XCMD_YLAG 10 +define XCMD_DXLAG 11 +define XCMD_DYLAG 12 +define XCMD_BACKGROUND 13 +define XCMD_BORDER 14 +define XCMD_LOREJECT 15 +define XCMD_HIREJECT 16 +define XCMD_APODIZE 17 +define XCMD_FILTER 18 +define XCMD_CORRELATION 19 +define XCMD_XWINDOW 20 +define XCMD_YWINDOW 21 +define XCMD_PEAKCENTER 22 +define XCMD_XCBOX 23 +define XCMD_YCBOX 24 +define XCMD_SHOW 25 +define XCMD_MARK 26 + +# Keywords + +define KY_REFIMAGE "reference" +define KY_IMAGE "input" +define KY_REGIONS "regions" +define KY_DATABASE "shifts" +define KY_OUTIMAGE "output" +define KY_RECORD "record" +define KY_REFFILE "coords" +define KY_NREGIONS "nregions" +define KY_CREGION "region" +define KY_XLAG "xlag" +define KY_YLAG "ylag" +define KY_DXLAG "dxlag" +define KY_DYLAG "dylag" +define KY_BACKGROUND "background" +define KY_BORDER "border" +define KY_LOREJECT "loreject" +define KY_HIREJECT "hireject" +define KY_APODIZE "apodize" +define KY_FILTER "filter" +define KY_CORRELATION "correlation" +define KY_XWINDOW "xwindow" +define KY_YWINDOW "ywindow" +define KY_PEAKCENTER "function" +define KY_XCBOX "xcbox" +define KY_YCBOX "ycbox" +define KY_TXSHIFT "xshift" +define KY_TYSHIFT "yshift" diff --git a/pkg/images/immatch/src/xregister/xregister.key b/pkg/images/immatch/src/xregister/xregister.key new file mode 100644 index 00000000..1956c88f --- /dev/null +++ b/pkg/images/immatch/src/xregister/xregister.key @@ -0,0 +1,47 @@ + Interactive Keystroke Commands + +? Print help +: Colon commands +t Define the offset between the reference and input images +c Draw a contour plot of the cross-correlation function +x Draw a column plot of the cross-correlation function +y Draw a line plot of the cross-correlation function +r Redraw the current plot +f Recompute the cross-correlation function +o Enter the image overlay plot submenu +w Update the task parameters +q Exit + + + Colon Commands + +:mark Mark regions on the display +:show Show current values of all the parameters + + + Show/set Parameters + +:reference [string] Show/set the current reference image name +:input [string] Show/set the current input image name +:regions [string] Show/set the regions to be cross-correlated +:shifts {string] Show/set the shifts database file name +:coords [string] Show/set the current coordinates file name +:output [string] Show/set the current output image name +:records [string] Show/set the current database record name +:xlag [value] Show/set the initial lag in x +:ylag [value] Show/set the initial lag in y +:dxlag [value] Show/set the incremental lag in x +:dylag [value] Show/set the incremental lag in y +:cregion [value] Show/set the current region +:background [string] Show/set the background fitting function +:border [value] Show/set border region for background fitting +:loreject [value] Show/set low side k-sigma rejection parameter +:hireject [value] Show/set high side k-sigma rejection parameter +:apodize [value] Show/set percent of end points to apodize +:filter [string] Show/set the default spatial filter +:correlation [string] Show/set the cross-correlation function +:xwindow [value] Show/set width of cross-correlation window in x +:ywindow [value] Show/set width of cross-correlation window in y +:function [string] Show/set correlation peak centering function +:xcbox [value] Show/set the centering box width in x +:ycbox [value] Show/set the centering box width in y |