diff options
| author | Joe Hunkeler <jhunkeler@gmail.com> | 2015-08-11 16:51:37 -0400 |
|---|---|---|
| committer | Joe Hunkeler <jhunkeler@gmail.com> | 2015-08-11 16:51:37 -0400 |
| commit | 40e5a5811c6ffce9b0974e93cdd927cbcf60c157 (patch) | |
| tree | 4464880c571602d54f6ae114729bf62a89518057 /pkg/images/imcoords/src | |
| download | iraf-osx-40e5a5811c6ffce9b0974e93cdd927cbcf60c157.tar.gz | |
Repatch (from linux) of OSX IRAF
Diffstat (limited to 'pkg/images/imcoords/src')
32 files changed, 15426 insertions, 0 deletions
diff --git a/pkg/images/imcoords/src/ccfunc.x b/pkg/images/imcoords/src/ccfunc.x new file mode 100644 index 00000000..9f60498a --- /dev/null +++ b/pkg/images/imcoords/src/ccfunc.x @@ -0,0 +1,639 @@ +include <imhdr.h> +include <math.h> +include <math/gsurfit.h> +include <mwset.h> +include <pkg/skywcs.h> + + +# CC_RPROJ -- Read the projection parameters from a file into an IRAF string +# containing the projection type followed by an MWCS WAT string, e.g +# "zpn projp1=value projp2=value" . + +int procedure cc_rdproj (fd, projstr, maxch) + +int fd #I the input file containing the projection parameters +char projstr[ARB] #O the output projection parameters string +int maxch #I the maximum size of the output projection string + +int projection, op +pointer sp, keyword, value, param +int fscan(), nscan(), strdic(), gstrcpy() + +begin + projstr[1] = EOS + if (fscan (fd) == EOF) + return (0) + + call smark (sp) + call salloc (keyword, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (param, SZ_FNAME, TY_CHAR) + + call gargwrd (Memc[keyword], SZ_FNAME) + projection = strdic (Memc[keyword], Memc[keyword], SZ_FNAME, + WTYPE_LIST) + if (projection <= 0 || projection == WTYPE_LIN || nscan() == 0) { + call sfree (sp) + return (0) + } + + # Copy the projection function into the projection string. + op = 1 + op = op + gstrcpy (Memc[keyword], projstr[op], maxch) + + # Copy the keyword value pairs into the projection string. + while (fscan(fd) != EOF) { + call gargwrd (Memc[keyword], SZ_FNAME) + call gargwrd (Memc[value], SZ_FNAME) + if (nscan() != 2) + next + call sprintf (Memc[param], SZ_FNAME, " %s = %s") + call pargstr (Memc[keyword]) + call pargstr (Memc[value]) + op = op + gstrcpy (Memc[param], projstr[op], maxch - op + 1) + } + + call sfree (sp) + + return (projection) +end + + +define NEWCD Memd[ncd+(($2)-1)*ndim+($1)-1] + +# CC_WCSIM -- Update the image world coordinate system. + +procedure cc_wcsim (im, coo, projection, lngref, latref, sx1, sy1, transpose) + +pointer im #I the pointer to the input image +pointer coo #I the pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the position of the reference point. +pointer sx1, sy1 #I pointer to linear surfaces +bool transpose #I transpose the wcs + +int ndim, naxes, ax1, ax2, axmap, wtype +double xshift, yshift, a, b, c, d, denom, xpix, ypix, tlngref, tlatref +pointer mw, sp, str, r, w, cd, ltm, ltv, iltm, nr, ncd, axes, axno, axval +int mw_stati(), sk_stati(), strdic() +pointer mw_openim() + +begin + mw = mw_openim (im) + ndim = mw_stati (mw, MW_NPHYSDIM) + + # Allocate working memory for the vectors and matrices. + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (axno, IM_MAXDIM, TY_INT) + call salloc (axval, IM_MAXDIM, TY_INT) + call salloc (axes, IM_MAXDIM, TY_INT) + call salloc (r, ndim, TY_DOUBLE) + call salloc (w, ndim, TY_DOUBLE) + call salloc (cd, ndim * ndim, TY_DOUBLE) + call salloc (ltm, ndim * ndim, TY_DOUBLE) + call salloc (ltv, ndim, TY_DOUBLE) + call salloc (iltm, ndim * ndim, TY_DOUBLE) + call salloc (nr, ndim, TY_DOUBLE) + call salloc (ncd, ndim * ndim, TY_DOUBLE) + + # Compute the original logical to world transformation. + call mw_gaxmap (mw, Memi[axno], Memi[axval], ndim) + call mw_gltermd (mw, Memd[ltm], Memd[ltv], ndim) + + # Get the axis map. + call mw_gaxlist (mw, 03B, Memi[axes], naxes) + axmap = mw_stati (mw, MW_USEAXMAP) + ax1 = Memi[axes] + ax2 = Memi[axes+1] + + # Set the system. + iferr (call mw_newsystem (mw, "image", ndim)) + ; + + # Set the axes and projection type. + if (projection[1] == EOS) { + call mw_swtype (mw, Memi[axes], ndim, "linear", "") + } else { + call mw_swtype (mw, Memi[axes], ndim, projection, + "axis 1: axtype=ra axis 2: axtype=dec") + } + + # Compute the new referemce point. + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_DEGREES: + tlngref = lngref + case SKY_RADIANS: + tlngref = RADTODEG(lngref) + case SKY_HOURS: + tlngref = 15.0d0 * lngref + default: + tlngref = lngref + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_DEGREES: + tlatref = latref + case SKY_RADIANS: + tlatref = RADTODEG(latref) + case SKY_HOURS: + tlatref = 15.0d0 * latref + default: + tlatref = latref + } + if (! transpose) { + Memd[w+ax1-1] = tlngref + Memd[w+ax2-1] = tlatref + } else { + Memd[w+ax1-1] = tlatref + Memd[w+ax2-1] = tlngref + } + + + # Fetch the linear coefficients of the fit. + call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) + + # Compute the new reference pixel. + denom = a * d - c * b + if (denom == 0.0d0) + xpix = INDEFD + else + xpix = (b * yshift - d * xshift) / denom + if (denom == 0.0d0) + ypix = INDEFD + else + ypix = (c * xshift - a * yshift) / denom + Memd[nr+ax1-1] = xpix + Memd[nr+ax2-1] = ypix + + # Compute the new CD matrix. + if (! transpose) { + NEWCD(ax1,ax1) = a / 3600.0d0 + NEWCD(ax1,ax2) = c / 3600.0d0 + NEWCD(ax2,ax1) = b / 3600.0d0 + NEWCD(ax2,ax2) = d / 3600.0d0 + } else { + NEWCD(ax1,ax1) = c / 3600.0d0 + NEWCD(ax1,ax2) = a / 3600.0d0 + NEWCD(ax2,ax1) = d / 3600.0d0 + NEWCD(ax2,ax2) = b / 3600.0d0 + } + + # Reset the axis map. + call mw_seti (mw, MW_USEAXMAP, axmap) + + # Recompute and store the new wcs if update is enabled. + call mw_saxmap (mw, Memi[axno], Memi[axval], ndim) + if (sk_stati (coo, S_PIXTYPE) == PIXTYPE_PHYSICAL) { + call mw_swtermd (mw, Memd[nr], Memd[w], Memd[ncd], ndim) + } else { + call mwmmuld (Memd[ncd], Memd[ltm], Memd[cd], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call asubd (Memd[nr], Memd[ltv], Memd[r], ndim) + call mwvmuld (Memd[iltm], Memd[r], Memd[nr], ndim) + call mw_swtermd (mw, Memd[nr], Memd[w], Memd[cd], ndim) + } + + # Save the fit. + if (! transpose) { + call sk_seti (coo, S_PLNGAX, ax1) + call sk_seti (coo, S_PLATAX, ax2) + } else { + call sk_seti (coo, S_PLNGAX, ax2) + call sk_seti (coo, S_PLATAX, ax1) + } + call sk_saveim (coo, mw, im) + call mw_saveim (mw, im) + call mw_close (mw) + + # Force the CDELT keywords to update. This will be unecessary when + # mwcs is updated to deal with non-quoted and / or non left-justified + # CTYPE keywords.. + wtype = strdic (projection, Memc[str], SZ_FNAME, WTYPE_LIST) + if (wtype > 0) + call sk_seti (coo, S_WTYPE, wtype) + call sk_ctypeim (coo, im) + + # Reset the fit. This will be unecessary when wcs is updated to deal + # with non-quoted and / or non left-justified CTYPE keywords. + call sk_seti (coo, S_WTYPE, 0) + call sk_seti (coo, S_PLNGAX, 0) + call sk_seti (coo, S_PLATAX, 0) + + call sfree (sp) +end + + +# CC_NWCSIM -- Update the image world coordinate system. + +procedure cc_nwcsim (im, coo, projection, lngref, latref, sx1, sy1, sx2, sy2, + transpose) + +pointer im #I the pointer to the input image +pointer coo #I the pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the position of the reference point. +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to distortion surfaces +bool transpose #I transpose the wcs + +int l, i, ndim, naxes, ax1, ax2, axmap, wtype, szatstr +double xshift, yshift, a, b, c, d, denom, xpix, ypix, tlngref, tlatref +pointer mw, sp, r, w, cd, ltm, ltv, iltm, nr, ncd, axes, axno, axval +pointer projstr, projpars, wpars, mwnew, atstr +bool streq() +int mw_stati(), sk_stati(), strdic(), strlen(), itoc() +pointer mw_openim(), mw_open() +errchk mw_gwattrs(), mw_newsystem() + +begin + # Open the image wcs and determine its size. + mw = mw_openim (im) + ndim = mw_stati (mw, MW_NPHYSDIM) + + # Allocate working memory for the wcs attributes, vectors, and + # matrices. + call smark (sp) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (projpars, SZ_LINE, TY_CHAR) + call salloc (wpars, SZ_LINE, TY_CHAR) + call salloc (axno, IM_MAXDIM, TY_INT) + call salloc (axval, IM_MAXDIM, TY_INT) + call salloc (axes, IM_MAXDIM, TY_INT) + call salloc (r, ndim, TY_DOUBLE) + call salloc (w, ndim, TY_DOUBLE) + call salloc (cd, ndim * ndim, TY_DOUBLE) + call salloc (ltm, ndim * ndim, TY_DOUBLE) + call salloc (ltv, ndim, TY_DOUBLE) + call salloc (iltm, ndim * ndim, TY_DOUBLE) + call salloc (nr, ndim, TY_DOUBLE) + call salloc (ncd, ndim * ndim, TY_DOUBLE) + + # Open the new wcs and set the system type. + mwnew = mw_open (NULL, ndim) + call mw_gsystem (mw, Memc[projstr], SZ_FNAME) + iferr { + call mw_newsystem (mw, "image", ndim) + } then { + call mw_newsystem (mwnew, Memc[projstr], ndim) + } else { + call mw_newsystem (mwnew, "image", ndim) + } + + # Set the LTERM. + call mw_gltermd (mw, Memd[ltm], Memd[ltv], ndim) + call mw_sltermd (mwnew, Memd[ltm], Memd[ltv], ndim) + + # Store the old axis map for later use. + call mw_gaxmap (mw, Memi[axno], Memi[axval], ndim) + + # Get the celestial coordinate axes list. + call mw_gaxlist (mw, 03B, Memi[axes], naxes) + axmap = mw_stati (mw, MW_USEAXMAP) + ax1 = Memi[axes] + ax2 = Memi[axes+1] + + # Set the axes and projection type for the celestial coordinate + # axes. Don't worry about the fact that the axes may in fact be + # glon and glat, elon and elat, or slon and slat, instead of + # ra and dec. This will be fixed up later. + if (projection[1] == EOS) { + call mw_swtype (mwnew, Memi[axes], ndim, "linear", "") + } else { + call sscan (projection) + call gargwrd (Memc[projstr], SZ_FNAME) + call gargstr (Memc[projpars], SZ_LINE) + call sprintf (Memc[wpars], SZ_LINE, + "axis 1: axtype = ra %s axis 2: axtype = dec %s") + call pargstr (Memc[projpars]) + call pargstr (Memc[projpars]) + if (streq (Memc[projstr], "tnx") && sx2 == NULL && sy2 == NULL) + call strcpy ("tan", Memc[projstr], SZ_FNAME) + call mw_swtype (mwnew, Memi[axes], ndim, Memc[projstr], Memc[wpars]) + } + + # Copy the attributes of the remaining axes to the new wcs. + szatstr = SZ_LINE + call malloc (atstr, szatstr, TY_CHAR) + do l = 1, ndim { + if (l == ax1 || l == ax2) + next + iferr { + call mw_gwattrs (mw, l, "wtype", Memc[projpars], SZ_LINE) + } then { + call mw_swtype (mwnew, l, 1, "linear", "") + } else { + call mw_swtype (mwnew, l, 1, Memc[projpars], "") + } + for (i = 1; ; i = i + 1) { + if (itoc (i, Memc[projpars], SZ_LINE) <= 0) + Memc[projpars] = EOS + repeat { + iferr (call mw_gwattrs (mw, l, Memc[projpars], + Memc[atstr], szatstr)) + Memc[atstr] = EOS + if (strlen(Memc[atstr]) < szatstr) + break + szatstr = szatstr + SZ_LINE + call realloc (atstr, szatstr, TY_CHAR) + } + if (Memc[atstr] == EOS) + break + call mw_swattrs (mwnew, l, Memc[projpars], Memc[atstr]) + } + } + call mfree (atstr, TY_CHAR) + + # Compute the new referemce point. + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_DEGREES: + tlngref = lngref + case SKY_RADIANS: + tlngref = RADTODEG(lngref) + case SKY_HOURS: + tlngref = 15.0d0 * lngref + default: + tlngref = lngref + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_DEGREES: + tlatref = latref + case SKY_RADIANS: + tlatref = RADTODEG(latref) + case SKY_HOURS: + tlatref = 15.0d0 * latref + default: + tlatref = latref + } + if (! transpose) { + Memd[w+ax1-1] = tlngref + Memd[w+ax2-1] = tlatref + } else { + Memd[w+ax1-1] = tlatref + Memd[w+ax2-1] = tlngref + } + # Fetch the linear coefficients of the fit. + call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) + + # Compute the new reference pixel. + denom = a * d - c * b + if (denom == 0.0d0) + xpix = INDEFD + else + xpix = (b * yshift - d * xshift) / denom + if (denom == 0.0d0) + ypix = INDEFD + else + ypix = (c * xshift - a * yshift) / denom + Memd[nr+ax1-1] = xpix + Memd[nr+ax2-1] = ypix + + # Compute the new CD matrix. + if (! transpose) { + NEWCD(ax1,ax1) = a / 3600.0d0 + NEWCD(ax1,ax2) = c / 3600.0d0 + NEWCD(ax2,ax1) = b / 3600.0d0 + NEWCD(ax2,ax2) = d / 3600.0d0 + } else { + NEWCD(ax1,ax1) = c / 3600.0d0 + NEWCD(ax1,ax2) = a / 3600.0d0 + NEWCD(ax2,ax1) = d / 3600.0d0 + NEWCD(ax2,ax2) = b / 3600.0d0 + } + + # Recompute and store the new wcs. + call mw_saxmap (mwnew, Memi[axno], Memi[axval], ndim) + if (sk_stati (coo, S_PIXTYPE) == PIXTYPE_PHYSICAL) { + call mw_swtermd (mwnew, Memd[nr], Memd[w], Memd[ncd], ndim) + } else { + call mwmmuld (Memd[ncd], Memd[ltm], Memd[cd], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call asubd (Memd[nr], Memd[ltv], Memd[r], ndim) + call mwvmuld (Memd[iltm], Memd[r], Memd[nr], ndim) + call mw_swtermd (mwnew, Memd[nr], Memd[w], Memd[cd], ndim) + } + + # Add the second order terms in the form of the wcs attributes + # lngcor and latcor. These are not FITS standard and can currently + # be understood only by IRAF. + if ((streq(Memc[projstr], "zpx") || streq (Memc[projstr], "tnx")) && + (sx2 != NULL || sy2 != NULL)) { + if (! transpose) + call cc_wcscor (im, mwnew, sx1, sx2, sy1, sy2, "lngcor", + "latcor", ax1, ax2) + else + call cc_wcscor (im, mwnew, sx1, sx2, sy1, sy2, "lngcor", + "latcor", ax2, ax1) + } + + # Save the fit. + if (! transpose) { + call sk_seti (coo, S_PLNGAX, ax1) + call sk_seti (coo, S_PLATAX, ax2) + } else { + call sk_seti (coo, S_PLNGAX, ax2) + call sk_seti (coo, S_PLATAX, ax1) + } + call sk_saveim (coo, mwnew, im) + call mw_saveim (mwnew, im) + call mw_close (mwnew) + call mw_close (mw) + + # Force the CTYPE keywords to update. This will be unecessary when + # mwcs is updated to deal with non-quoted and / or non left-justified + # CTYPE keywords.. + wtype = strdic (Memc[projstr], Memc[projstr], SZ_FNAME, WTYPE_LIST) + if (wtype > 0) + call sk_seti (coo, S_WTYPE, wtype) + call sk_ctypeim (coo, im) + + # Reset the fit. + call sk_seti (coo, S_WTYPE, 0) + call sk_seti (coo, S_PLNGAX, 0) + call sk_seti (coo, S_PLATAX, 0) + + call sfree (sp) +end + + +# CC_WCSCOR -- Reformulate the higher order surface fit into a correction +# term in degrees that can be written into the header as a wcs attribute. +# This attribute will be written as string containing the surface definition. + +procedure cc_wcscor (im, mw, sx1, sx2, sy1, sy2, xiname, etaname, xiaxis, + etaaxis) + +pointer im #I pointer to the input image +pointer mw #I pointer to the wcs structure +pointer sx1, sx2 #I pointer to the linear and distortion xi surfaces +pointer sy1, sy2 #I pointer to the linear and distortion eta surfaces +char xiname[ARB] #I the wcs xi correction attribute name +char etaname[ARB] #I the wcs eta correction attribute name +int xiaxis #I the xi axis number +int etaaxis #I the eta axis number + +int i, j, function, xxorder, xyorder, xxterms, yxorder, yyorder, yxterms +int nx, ny, npix, ier +double sxmin, sxmax, symin, symax, ratio, x, y, xstep, ystep, ximin, ximax +double etamin, etamax +pointer sp, xpix, ypix, xilin, etalin, dxi, deta, wgt, nsx2, nsy2 +int dgsgeti() +double dgsgetd() +begin + if (sx2 == NULL && sy2 == NULL) + return + if (dgsgeti (sx1, GSTYPE) != dgsgeti (sy1, GSTYPE)) + return + + # Get the function, xmin, xmax, ymin, and ymax parameters for the + # surfaces. + function = min (dgsgeti (sx1, GSTYPE), dgsgeti (sy1, GSTYPE)) + sxmin = max (dgsgetd (sx1, GSXMIN), dgsgetd (sy1, GSXMIN)) + sxmax = min (dgsgetd (sx1, GSXMAX), dgsgetd (sy1, GSXMAX)) + symin = max (dgsgetd (sx1, GSYMIN), dgsgetd (sy1, GSYMIN)) + symax = min (dgsgetd (sx1, GSYMAX), dgsgetd (sy1, GSYMAX)) + + # Get the order and cross-terms parameters from the higher order + # functions. + if (sx2 != NULL) { + xxorder = dgsgeti (sx2, GSXORDER) + xyorder = dgsgeti (sx2, GSYORDER) + xxterms = dgsgeti (sx2, GSXTERMS) + } else { + xxorder = dgsgeti (sx1, GSXORDER) + xyorder = dgsgeti (sx1, GSYORDER) + xxterms = dgsgeti (sx1, GSXTERMS) + } + if (sy2 != NULL) { + yxorder = dgsgeti (sy2, GSXORDER) + yyorder = dgsgeti (sy2, GSYORDER) + yxterms = dgsgeti (sy2, GSXTERMS) + } else { + yxorder = dgsgeti (sy1, GSXORDER) + yyorder = dgsgeti (sy1, GSYORDER) + yxterms = dgsgeti (sy1, GSXTERMS) + } + + # Choose a reasonable coordinate grid size based on the x and y order + # of the fit and the number of rows and columns in the image. + ratio = double (IM_LEN(im,2)) / double (IM_LEN(im,1)) + nx = max (xxorder + 3, yxorder + 3, 10) + ny = max (yyorder + 3, xyorder + 3, nint (ratio * 10)) + npix = nx * ny + + # Allocate some working space. + call smark (sp) + call salloc (xpix, npix, TY_DOUBLE) + call salloc (ypix, npix, TY_DOUBLE) + call salloc (xilin, npix, TY_DOUBLE) + call salloc (etalin, npix, TY_DOUBLE) + call salloc (dxi, npix, TY_DOUBLE) + call salloc (deta, npix, TY_DOUBLE) + call salloc (wgt, npix, TY_DOUBLE) + + # Compute the grid of x and y points. + xstep = (sxmax - sxmin) / (nx - 1) + ystep = (symax - symin) / (ny - 1) + y = symin + npix = 0 + do j = 1, ny { + x = sxmin + do i = 1, nx { + Memd[xpix+npix] = x + Memd[ypix+npix] = y + x = x + xstep + npix = npix + 1 + } + y = y + ystep + } + + + # Compute the weights + call amovkd (1.0d0, Memd[wgt], npix) + + # Evalute the linear surfaces and convert the results from arcseconds + # to degrees. + call dgsvector (sx1, Memd[xpix], Memd[ypix], Memd[xilin], npix) + call adivkd (Memd[xilin], 3600.0d0, Memd[xilin], npix) + call alimd (Memd[xilin], npix, ximin, ximax) + call dgsvector (sy1, Memd[xpix], Memd[ypix], Memd[etalin], npix) + call adivkd (Memd[etalin], 3600.0d0, Memd[etalin], npix) + call alimd (Memd[etalin], npix, etamin, etamax) + + # Evalute the distortion surfaces, convert the results from arcseconds + # to degrees, and compute new distortion surfaces. + if (sx2 != NULL) { + call dgsvector (sx2, Memd[xpix], Memd[ypix], Memd[dxi], npix) + call adivkd (Memd[dxi], 3600.0d0, Memd[dxi], npix) + call dgsinit (nsx2, function, xxorder, xyorder, xxterms, + ximin, ximax, etamin, etamax) + call dgsfit (nsx2, Memd[xilin], Memd[etalin], Memd[dxi], + Memd[wgt], npix, WTS_UNIFORM, ier) + call cc_gsencode (mw, nsx2, xiname, xiaxis) + } else + nsx2 = NULL + if (sy2 != NULL) { + call dgsvector (sy2, Memd[xpix], Memd[ypix], Memd[deta], npix) + call adivkd (Memd[deta], 3600.0d0, Memd[deta], npix) + call dgsinit (nsy2, function, yxorder, yyorder, yxterms, + ximin, ximax, etamin, etamax) + call dgsfit (nsy2, Memd[xilin], Memd[etalin], Memd[deta], + Memd[wgt], npix, WTS_UNIFORM, ier) + call cc_gsencode (mw, nsy2, etaname, etaaxis) + } else + nsy2 = NULL + + # Store the string in the mcs structure in the format of a wcs + # attribute. + + # Free the new surfaces. + if (nsx2 != NULL) + call dgsfree (nsx2) + if (nsy2 != NULL) + call dgsfree (nsy2) + + call sfree (sp) +end + + +# CC_GSENCODE -- Encode the surface in an mwcs attribute. + +procedure cc_gsencode (mw, gs, atname, axis) + +pointer mw #I pointer to the mwcs structure +pointer gs #I pointer to the surface to be encoded +char atname[ARB] #I attribute name for the encoded surface +int axis #I axis for which the encode surface is encoded + +int i, op, nsave, szatstr, szpar +pointer sp, coeff, par, atstr +int dgsgeti(), strlen(), gstrcpy() + +begin + nsave = dgsgeti (gs, GSNSAVE) + call smark (sp) + call salloc (coeff, nsave, TY_DOUBLE) + call salloc (par, SZ_LINE, TY_CHAR) + call dgssave (gs, Memd[coeff]) + + szatstr = SZ_LINE + call malloc (atstr, szatstr, TY_CHAR) + op = 0 + do i = 1, nsave { + call sprintf (Memc[par], SZ_LINE, "%g ") + call pargd (Memd[coeff+i-1]) + szpar = strlen (Memc[par]) + if (szpar > (szatstr - op)) { + szatstr = szatstr + SZ_LINE + call realloc (atstr, szatstr, TY_CHAR) + } + op = op + gstrcpy (Memc[par], Memc[atstr+op], SZ_LINE) + + } + + call mw_swattrs (mw, axis, atname, Memc[atstr]) + call mfree (atstr, TY_CHAR) + call sfree (sp) +end + + + diff --git a/pkg/images/imcoords/src/ccstd.x b/pkg/images/imcoords/src/ccstd.x new file mode 100644 index 00000000..319d18ba --- /dev/null +++ b/pkg/images/imcoords/src/ccstd.x @@ -0,0 +1,252 @@ +include <mach.h> +include <math.h> +include <math/gsurfit.h> +include <pkg/skywcs.h> + +# CC_INIT_STD -- Get the parameter values relevant to the transformation from +# the cl or the database file. +# +procedure cc_init_std (dt, record, geometry, lngunits, latunits, sx1, + sy1, sx2, sy2, mw, coo) + +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 +int lngunits #I the input ra / longitude units +int latunits #I the input dec / latitude units +pointer sx1, sy1 #O pointers to the linear x and y surfaces +pointer sx2, sy2 #O pointers to the x and y distortion surfaces +pointer mw #O pointer to the mwcs structure +pointer coo #O pointer to the coordinate structure + +double lngref, latref +int recstat, proj +pointer sp, projstr, projpars +int cc_dtrecord(), strdic() +pointer cc_celwcs() + +begin + call smark (sp) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (projpars, SZ_LINE, TY_CHAR) + + if (dt == NULL) { + + call cc_rinit (lngunits, latunits, sx1, sy1, mw, coo) + sx2 = NULL + sy2 = NULL + + } else { + + recstat = cc_dtrecord (dt, record, geometry, coo, Memc[projpars], + lngref, latref, sx1, sy1, sx2, sy2) + if (recstat == ERR) { + coo = NULL + sx1 = NULL + sy1 = NULL + sx2 = NULL + sy2 = NULL + mw = NULL + } else { + call sscan (Memc[projpars]) + call gargwrd (Memc[projstr], SZ_FNAME) + proj = strdic (Memc[projstr], Memc[projstr], SZ_FNAME, + WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projpars] = EOS + mw = cc_celwcs (coo, Memc[projpars], lngref, latref) + } + } + + call sfree (sp) +end + + +# CC_FREE_STD -- Free the previously defined transformation. + +procedure cc_free_std (sx1, sy1, sx2, sy2, mw, coo) + +pointer sx1, sy1 #U pointers to the linear x and y surfaces +pointer sx2, sy2 #U pointers to the x and y distortion surfaces +pointer mw #U pointer to the mwcs structure +pointer coo #U pointer to the celestial coordinate structure + +begin + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) + if (sx2 != NULL) + call dgsfree (sx2) + if (sy2 != NULL) + call dgsfree (sy2) + if (mw != NULL) + call mw_close (mw) + if (coo != NULL) + call sk_close (coo) +end + + +# CC_RINIT -- Compute the required wcs structure from the input parameters. + +procedure cc_rinit (lngunits, latunits, sx1, sy1, mw, coo) + +int lngunits #I the input ra / longitude units +int latunits #I the input dec / latitude units +pointer sx1 #O pointer to the linear x coordinate surface +pointer sy1 #O pointer to the linear y coordinate surface +pointer mw #O pointer to the mwcs structure +pointer coo #O pointer to the celestial coordinate structure + +double xref, yref, xscale, yscale, xrot, yrot, lngref, latref +int coostat, proj, tlngunits, tlatunits, pfd +pointer sp, projstr +double clgetd() +double dgseval() +int sk_decwcs(), sk_stati(), strdic(), open() +pointer cc_celwcs(), cc_rdproj() +errchk open() + +begin + # Allocate some workin space. + call smark (sp) + call salloc (projstr, SZ_LINE, TY_CHAR) + + # Get the reference point pixel coordinates. + xref = clgetd ("xref") + if (IS_INDEFD(xref)) + xref = 0.0d0 + yref = clgetd ("yref") + if (IS_INDEFD(yref)) + yref = 0.0d0 + + # Get the scale factors. + xscale = clgetd ("xmag") + if (IS_INDEFD(xscale)) + xscale = 1.0d0 + yscale = clgetd ("ymag") + if (IS_INDEFD(yscale)) + yscale = 1.0d0 + + # Get the rotation angles. + xrot = clgetd ("xrotation") + if (IS_INDEFD(xrot)) + xrot = 0.0d0 + xrot = -DEGTORAD(xrot) + yrot = clgetd ("yrotation") + if (IS_INDEFD(yrot)) + yrot = 0.0d0 + yrot = -DEGTORAD(yrot) + + # Initialize the linear part of the solution. + call dgsinit (sx1, GS_POLYNOMIAL, 2, 2, NO, double (-MAX_REAL), + double (MAX_REAL), double (-MAX_REAL), double (MAX_REAL)) + call dgsinit (sy1, GS_POLYNOMIAL, 2, 2, NO, double (-MAX_REAL), + double (MAX_REAL), double (-MAX_REAL), double (MAX_REAL)) + call geo_rotmagd (sx1, sy1, xscale, yscale, xrot, yrot) + call geo_xyshiftd (sx1, sy1, -dgseval (sx1, xref, yref), + -dgseval (sy1, xref, yref)) + + lngref = clgetd ("lngref") + if (IS_INDEFD(lngref)) + lngref = 0.0d0 + latref = clgetd ("latref") + if (IS_INDEFD(latref)) + latref = 0.0d0 + + coostat = sk_decwcs ("j2000", mw, coo, NULL) + if (coostat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + } + if (lngunits <= 0) + tlngunits = sk_stati (coo, S_NLNGUNITS) + else + tlngunits = lngunits + call sk_seti (coo, S_NLNGUNITS, tlngunits) + if (latunits <= 0) + tlatunits = sk_stati (coo, S_NLATUNITS) + else + tlatunits = latunits + call sk_seti (coo, S_NLATUNITS, tlatunits) + + call clgstr ("projection", Memc[projstr], SZ_LINE) + iferr { + pfd = open (Memc[projstr], READ_ONLY, TEXT_FILE) + } then { + proj = strdic (Memc[projstr], Memc[projstr], SZ_LINE, WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projstr] = EOS + } else { + proj = cc_rdproj (pfd, Memc[projstr], SZ_LINE) + call close (pfd) + } + mw = cc_celwcs (coo, Memc[projstr], lngref, latref) + + call sfree (sp) +end + + +define MAX_NITER 20 + +# CC_DO_STD -- Transform the coordinates using the full transformation +# computed by CCMAP. + +procedure cc_do_std (x, y, xt, yt, sx1, sy1, sx2, sy2, forward) + +double x, y #I initial positions +double xt, yt #O transformed positions +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to distortion surfaces +bool forward #I forward transform + +double f, fx, fy, g, gx, gy, denom, dx, dy +int niter +pointer newsx, newsy +double dgseval() + +begin + + if (forward) { + + 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) + + } else { + + xt = x / 1.0 + yt = y / 1.0 + + call dgsadd (sx1, sx2, newsx) + call dgsadd (sy1, sy2, newsy) + niter = 0 + repeat { + + f = dgseval (newsx, xt, yt) - x + call dgsder (newsx, xt, yt, fx, 1, 1, 0) + call dgsder (newsx, xt, yt, fy, 1, 0, 1) + + g = dgseval (newsy, xt, yt) - y + call dgsder (newsy, xt, yt, gx, 1, 1, 0) + call dgsder (newsy, xt, yt, gy, 1, 0, 1) + + denom = fx * gy - fy * gx + dx = (-f * gy + g * fy) / denom + dy = (-g * fx + f * gx) / denom + xt = xt + dx + yt = yt + dy + if (max (abs (dx), abs (dy), abs(f), abs(g)) < 1.0e-5) + break + + niter = niter + 1 + + } until (niter >= MAX_NITER) + + call dgsfree (newsx) + call dgsfree (newsy) + } +end diff --git a/pkg/images/imcoords/src/ccxytran.x b/pkg/images/imcoords/src/ccxytran.x new file mode 100644 index 00000000..537c28f6 --- /dev/null +++ b/pkg/images/imcoords/src/ccxytran.x @@ -0,0 +1,740 @@ +include <math.h> +include <pkg/skywcs.h> + +# Define the transform geometries +define GEO_LINEAR 1 +define GEO_DISTORTION 2 +define GEO_GEOMETRIC 3 + +# CC_INIT_TRANSFORM -- Get the parameter values relevant to the +# transformation from the cl. + +procedure cc_init_transform (dt, record, geometry, lngunits, latunits, sx1, + sy1, sx2, sy2, mw, coo) + +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 +int lngunits #I the input ra / longitude units +int latunits #I the input dec / latitude units +pointer sx1, sy1 #O pointers to the linear x and y surfaces +pointer sx2, sy2 #O pointers to the x and y distortion surfaces +pointer mw #O pointer to the mwcs structure +pointer coo #O pointer to the coordinate structure + +double lngref, latref +int recstat, proj +pointer sp, projstr, projpars +int cc_dtrecord(), strdic() +pointer cc_geowcs(), cc_celwcs() + +begin + call smark (sp) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (projpars, SZ_LINE, TY_CHAR) + + if (dt == NULL) { + + sx1 = NULL + sy1 = NULL + sx2 = NULL + sy2 = NULL + call cc_linit (lngunits, latunits, mw, coo) + + } else { + + recstat = cc_dtrecord (dt, record, geometry, coo, Memc[projpars], + lngref, latref, sx1, sy1, sx2, sy2) + if (recstat == ERR) { + coo = NULL + sx1 = NULL + sy1 = NULL + sx2 = NULL + sy2 = NULL + mw = NULL + } else { + call sscan (Memc[projpars]) + call gargwrd (Memc[projstr], SZ_FNAME) + proj = strdic (Memc[projstr], Memc[projstr], SZ_FNAME, + WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projpars] = EOS + if (sx2 == NULL && sy2 == NULL) + mw = cc_geowcs (coo, Memc[projpars], lngref, latref, + sx1, sy1, false) + else + mw = cc_celwcs (coo, Memc[projpars], lngref, latref) + } + } + + call sfree (sp) +end + + +# CC_FREE_TRANSFORM -- Free the previously defined transformation. + +procedure cc_free_transform (sx1, sy1, sx2, sy2, mw, coo) + +pointer sx1, sy1 #U pointers to the linear x and y surfaces +pointer sx2, sy2 #U pointers to the x and y distortion surfaces +pointer mw #U pointer to the mwcs structure +pointer coo #U pointer to the celestial coordinate structure + +begin + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) + if (sx2 != NULL) + call dgsfree (sx2) + if (sy2 != NULL) + call dgsfree (sy2) + if (mw != NULL) + call mw_close (mw) + if (coo != NULL) + call sk_close (coo) +end + + +# CC_LINIT -- Compute the required wcs structure from the input parameters. + +procedure cc_linit (lngunits, latunits, mw, coo) + +int lngunits #I the input ra / longitude units +int latunits #I the input dec / latitude units +pointer mw #O pointer to the mwcs structure +pointer coo #O pointer to the celestial coordinate structure + +double xref, yref, xscale, yscale, xrot, yrot, lngref, latref +int coostat, proj, tlngunits, tlatunits, pfd +pointer sp, projstr +double clgetd() +int sk_decwcs(), sk_stati(), open(), strdic(), cc_rdproj() +pointer cc_mkwcs() +errchk open() + +begin + # Allocate some workin space. + call smark (sp) + call salloc (projstr, SZ_LINE, TY_CHAR) + + # Get the reference point pixel coordinates. + xref = clgetd ("xref") + if (IS_INDEFD(xref)) + xref = 0.0d0 + yref = clgetd ("yref") + if (IS_INDEFD(yref)) + yref = 0.0d0 + + xscale = clgetd ("xmag") + if (IS_INDEFD(xscale)) + xscale = 1.0d0 + yscale = clgetd ("ymag") + if (IS_INDEFD(yscale)) + yscale = 1.0d0 + + xrot = clgetd ("xrotation") + if (IS_INDEFD(xrot)) + xrot = 0.0d0 + yrot = clgetd ("yrotation") + if (IS_INDEFD(yrot)) + yrot = 0.0d0 + + lngref = clgetd ("lngref") + if (IS_INDEFD(lngref)) + lngref = 0.0d0 + latref = clgetd ("latref") + if (IS_INDEFD(latref)) + latref = 0.0d0 + + coostat = sk_decwcs ("j2000", mw, coo, NULL) + if (coostat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + } + if (lngunits <= 0) + tlngunits = sk_stati (coo, S_NLNGUNITS) + else + tlngunits = lngunits + call sk_seti (coo, S_NLNGUNITS, tlngunits) + if (latunits <= 0) + tlatunits = sk_stati (coo, S_NLATUNITS) + else + tlatunits = latunits + call sk_seti (coo, S_NLATUNITS, tlatunits) + + call clgstr ("projection", Memc[projstr], SZ_LINE) + iferr { + pfd = open (Memc[projstr], READ_ONLY, TEXT_FILE) + } then { + proj = strdic (Memc[projstr], Memc[projstr], SZ_LINE, WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projstr] = EOS + } else { + proj = cc_rdproj (pfd, Memc[projstr], SZ_LINE) + call close (pfd) + } + + + mw = cc_mkwcs (coo, Memc[projstr], lngref, latref, xref, yref, + xscale, yscale, xrot, yrot, false) + + call sfree (sp) +end + + +# CC_DTRECORD -- Read the transform from the database records written by +# CCMAP. + +int procedure cc_dtrecord (dt, record, geometry, coo, projection, + lngref, latref, sx1, sy1, sx2, sy2) + +pointer dt #I pointer to the database +char record[ARB] #I the database records to be read +int geometry #I the transform geometry +pointer coo #O pointer to the coordinate structure +char projection[ARB] #O the sky projection geometry +double lngref, latref #O the reference point world coordinates +pointer sx1, sy1 #O pointer to the linear x and y fits +pointer sx2, sy2 #O pointer to the distortion x and y fits + +int i, op, ncoeff, junk, rec, coostat, lngunits, latunits +pointer mw, xcoeff, ycoeff, sp, projpar, projvalue +double dtgetd() +int dtlocate(), dtgeti(), dtscan(), sk_decwcs(), strdic(), strlen() +int gstrcpy() +errchk dgsrestore(), dtgstr(), dtdgetd(), dtgeti() + +begin + # Locate the appropriate records. + iferr (rec = dtlocate (dt, record)) + return (ERR) + + # Open the coordinate structure. + iferr (call dtgstr (dt, rec, "coosystem", projection, SZ_FNAME)) + return (ERR) + coostat = sk_decwcs (projection, mw, coo, NULL) + if (coostat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + projection[1] = EOS + return (ERR) + } + + # Get the reference point units. + iferr (call dtgstr (dt, rec, "lngunits", projection, SZ_FNAME)) + return (ERR) + lngunits = strdic (projection, projection, SZ_FNAME, SKY_LNG_UNITLIST) + if (lngunits > 0) + call sk_seti (coo, S_NLNGUNITS, lngunits) + iferr (call dtgstr (dt, rec, "latunits", projection, SZ_FNAME)) + return (ERR) + latunits = strdic (projection, projection, SZ_FNAME, SKY_LAT_UNITLIST) + if (latunits > 0) + call sk_seti (coo, S_NLATUNITS, latunits) + + # Get the reference point. + iferr (call dtgstr (dt, rec, "projection", projection, SZ_FNAME)) + return (ERR) + iferr (lngref = dtgetd (dt, rec, "lngref")) + return (ERR) + iferr (latref = dtgetd (dt, rec, "latref")) + return (ERR) + + # Read in the coefficients. + iferr (ncoeff = dtgeti (dt, rec, "surface1")) + return (ERR) + 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 the fit. + call dgsrestore (sx1, Memd[xcoeff]) + call dgsrestore (sy1, 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 + } + + # Get the projection parameters if any. + call smark (sp) + call salloc (projpar, SZ_FNAME, TY_CHAR) + call salloc (projvalue, SZ_FNAME, TY_CHAR) + op = strlen (projection) + 1 + do i = 0, 9 { + call sprintf (Memc[projpar], SZ_FNAME, "projp%d") + call pargi (i) + iferr (call dtgstr (dt, rec, Memc[projpar], Memc[projvalue], + SZ_FNAME)) + next + op = op + gstrcpy (" ", projection[op], SZ_LINE - op + 1) + op = op + gstrcpy (Memc[projpar], projection[op], + SZ_LINE - op + 1) + op = op + gstrcpy (" = ", projection[op], SZ_LINE - op + 1) + op = op + gstrcpy (Memc[projvalue], projection[op], + SZ_LINE - op + 1) + } + call sfree (sp) + + + call mfree (xcoeff, TY_DOUBLE) + call mfree (ycoeff, TY_DOUBLE) + + return (OK) +end + + +define MAX_NITER 20 + +# CC_DO_TRANSFORM -- Transform the coordinates using the full transformation +# computed by CCMAP and the MWCS celestial coordinate wcs. + +procedure cc_do_transform (x, y, xt, yt, ct, sx1, sy1, sx2, sy2, forward) + +double x, y #I initial positions +double xt, yt #O transformed positions +pointer ct #I pointer to the mwcs transform +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to distortion surfaces +bool forward #I forward transform + +double xm, ym, f, fx, fy, g, gx, gy, denom, dx, dy +int niter +pointer sumsx, sumsy, newsx, newsy +double dgseval() + +begin + + if (forward) { + + xm = dgseval (sx1, x, y) + if (sx2 != NULL) + xm = xm + dgseval (sx2, x, y) + ym = dgseval (sy1, x, y) + if (sy2 != NULL) + ym = ym + dgseval (sy2, x, y) + xm = xm / 3600.0d0 + ym = ym / 3600.0d0 + + call mw_c2trand (ct, xm, ym, xt, yt) + + } else { + + # Use a value of 1.0 for an initial guess at the plate scale. + call mw_c2trand (ct, x, y, xm, ym) + xm = xm * 3600.0d0 + ym = ym * 3600.0d0 + + call dgsadd (sx1, sx2, sumsx) + call dgsadd (sy1, sy2, sumsy) + + niter = 0 + xt = xm + yt = ym + repeat { + + if (niter == 0) { + newsx = sx1 + newsy = sy1 + } else if (niter == 1) { + newsx = sumsx + newsy = sumsy + } + + f = dgseval (newsx, xt, yt) - xm + call dgsder (newsx, xt, yt, fx, 1, 1, 0) + call dgsder (newsx, xt, yt, fy, 1, 0, 1) + + g = dgseval (newsy, xt, yt) - ym + call dgsder (newsy, xt, yt, gx, 1, 1, 0) + call dgsder (newsy, xt, yt, gy, 1, 0, 1) + + denom = fx * gy - fy * gx + if (denom == 0.0d0) + break + dx = (-f * gy + g * fy) / denom + dy = (-g * fx + f * gx) / denom + xt = xt + dx + yt = yt + dy + if (max (abs (dx), abs (dy), abs(f), abs(g)) < 1.0e-5) + break + + niter = niter + 1 + + } until (niter >= MAX_NITER) + + call dgsfree (sumsx) + call dgsfree (sumsy) + } +end + +define NEWCD Memd[cd+(($2)-1)*ndim+($1)-1] + +# CC_MKWCS -- Compute the wcs from the user parameters. + +pointer procedure cc_mkwcs (coo, projection, lngref, latref, xref, yref, + xscale, yscale, xrot, yrot, transpose) + +pointer coo #I pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the world coordinates of the reference point +double xref, yref #I the reference point in pixels +double xscale, yscale #I the x and y scale in arcsec / pixel +double xrot, yrot #I the x and y axis rotation angles in degrees +bool transpose #I transpose the wcs + +int ndim +double tlngref, tlatref +pointer sp, axes, ltm, ltv, r, w, cd, mw, projstr, projpars, wpars +int sk_stati() +pointer mw_open() + +begin + # Open the wcs. + ndim = 2 + mw = mw_open (NULL, ndim) + + # Allocate working space. + call smark (sp) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (projpars, SZ_LINE, TY_CHAR) + call salloc (wpars, SZ_LINE, TY_CHAR) + call salloc (axes, ndim, TY_INT) + call salloc (ltm, ndim * ndim, TY_DOUBLE) + call salloc (ltv, ndim, TY_DOUBLE) + call salloc (r, ndim, TY_DOUBLE) + call salloc (w, ndim, TY_DOUBLE) + call salloc (cd, ndim * ndim, TY_DOUBLE) + + # Set the wcs. + iferr (call mw_newsystem (mw, "image", ndim)) + ; + + # Set the axes. + Memi[axes] = 1 + Memi[axes+1] = 2 + + # Set the axes and projection type. + if (projection[1] == EOS) { + call mw_swtype (mw, Memi[axes], ndim, "linear", "") + } else { + call sscan (projection) + call gargwrd (Memc[projstr], SZ_FNAME) + call gargstr (Memc[projpars], SZ_LINE) + call sprintf (Memc[wpars], SZ_LINE, + "axis 1: axtype = ra %s axis 2: axtype = dec %s") + call pargstr (Memc[projpars]) + call pargstr (Memc[projpars]) + call mw_swtype (mw, Memi[axes], ndim, Memc[projstr], Memc[wpars]) + } + + # Compute the referemce point world coordinates. + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_DEGREES: + tlngref = lngref + case SKY_RADIANS: + tlngref = RADTODEG(lngref) + case SKY_HOURS: + tlngref = 15.0d0 * lngref + default: + tlngref = lngref + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_DEGREES: + tlatref = latref + case SKY_RADIANS: + tlatref = RADTODEG(latref) + case SKY_HOURS: + tlatref = 15.0d0 * latref + default: + tlatref = latref + } + + if (! transpose) { + Memd[w] = tlngref + Memd[w+1] = tlatref + } else { + Memd[w+1] = tlngref + Memd[w] = tlatref + } + + # Compute the reference point pixel coordinates. + Memd[r] = xref + Memd[r+1] = yref + + # Compute the new CD matrix. + if (! transpose) { + NEWCD(1,1) = xscale * cos (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(2,1) = -yscale * sin (DEGTORAD(yrot)) / 3600.0d0 + NEWCD(1,2) = xscale * sin (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(2,2) = yscale * cos (DEGTORAD(yrot)) / 3600.0d0 + } else { + NEWCD(1,1) = xscale * sin (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(2,1) = yscale * cos (DEGTORAD(yrot)) / 3600.0d0 + NEWCD(1,2) = xscale * cos (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(2,2) = -yscale * sin (DEGTORAD(yrot)) / 3600.0d0 + } + + # Compute the Lterm. + call aclrd (Memd[ltv], ndim) + call mw_mkidmd (Memd[ltm], ndim) + + # Store the wcs. + call mw_sltermd (mw, Memd[ltm], Memd[ltv], ndim) + call mw_swtermd (mw, Memd[r], Memd[w], Memd[cd], ndim) + + call sfree (sp) + + return (mw) +end + +# CC_GEOWCS -- Create the wcs from the geometric transformation computed +# by CCMAP + +pointer procedure cc_geowcs (coo, projection, lngref, latref, sx1, sy1, + transpose) + +pointer coo #I the pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the coordinates of the reference point +pointer sx1, sy1 #I pointer to linear surfaces +bool transpose #I transpose the wcs + +int ndim +double xshift, yshift, a, b, c, d, denom, xpix, ypix, tlngref, tlatref +pointer mw, sp, projstr, projpars, wpars, r, w, cd, ltm, ltv, axes +int sk_stati() +pointer mw_open() + +begin + ndim = 2 + mw = mw_open (NULL, ndim) + + # Allocate working memory for the vectors and matrices. + call smark (sp) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (projpars, SZ_LINE, TY_CHAR) + call salloc (wpars, SZ_LINE, TY_CHAR) + call salloc (axes, 2, TY_INT) + call salloc (r, ndim, TY_DOUBLE) + call salloc (w, ndim, TY_DOUBLE) + call salloc (cd, ndim * ndim, TY_DOUBLE) + call salloc (ltm, ndim * ndim, TY_DOUBLE) + call salloc (ltv, ndim, TY_DOUBLE) + + # Set the wcs. + iferr (call mw_newsystem (mw, "image", ndim)) + ; + + # Set the axes. + Memi[axes] = 1 + Memi[axes+1] = 2 + + # Set the axes and projection type. + if (projection[1] == EOS) { + call mw_swtype (mw, Memi[axes], ndim, "linear", "") + } else { + call sscan (projection) + call gargwrd (Memc[projstr], SZ_FNAME) + call gargstr (Memc[projpars], SZ_LINE) + call sprintf (Memc[wpars], SZ_LINE, + "axis 1: axtype = ra %s axis 2: axtype = dec %s") + call pargstr (Memc[projpars]) + call pargstr (Memc[projpars]) + call mw_swtype (mw, Memi[axes], ndim, Memc[projstr], Memc[wpars]) + } + + # Compute the new referemce point. + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_DEGREES: + tlngref = lngref + case SKY_RADIANS: + tlngref = RADTODEG(lngref) + case SKY_HOURS: + tlngref = 15.0d0 * lngref + default: + tlngref = lngref + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_DEGREES: + tlatref = latref + case SKY_RADIANS: + tlatref = RADTODEG(latref) + case SKY_HOURS: + tlatref = 15.0d0 * latref + default: + tlatref = latref + } + if (! transpose) { + Memd[w] = tlngref + Memd[w+1] = tlatref + } else { + Memd[w] = tlatref + Memd[w+1] = tlngref + } + + + # Fetch the linear coefficients of the fit. + call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) + + # Compute the new reference pixel. + denom = a * d - c * b + if (denom == 0.0d0) + xpix = INDEFD + else + xpix = (b * yshift - d * xshift) / denom + if (denom == 0.0d0) + ypix = INDEFD + else + ypix = (c * xshift - a * yshift) / denom + Memd[r] = xpix + Memd[r+1] = ypix + + # Compute the new CD matrix. + if (! transpose) { + NEWCD(1,1) = a / 3600.0d0 + NEWCD(1,2) = c / 3600.0d0 + NEWCD(2,1) = b / 3600.0d0 + NEWCD(2,2) = d / 3600.0d0 + } else { + NEWCD(1,1) = c / 3600.0d0 + NEWCD(1,2) = a / 3600.0d0 + NEWCD(2,1) = d / 3600.0d0 + NEWCD(2,2) = b / 3600.0d0 + } + + # Compute the Lterm. + call aclrd (Memd[ltv], ndim) + call mw_mkidmd (Memd[ltm], ndim) + + # Recompute and store the new wcs if update is enabled. + call mw_sltermd (mw, Memd[ltm], Memd[ltv], ndim) + call mw_swtermd (mw, Memd[r], Memd[w], Memd[cd], ndim) + + call sfree (sp) + + return (mw) +end + + + + +# CC_CELWCS -- Create a wcs which compute the projection part of the +# transformation only + +pointer procedure cc_celwcs (coo, projection, lngref, latref) + +pointer coo #I the pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the position of the reference point. + +int ndim +pointer sp, projstr, projpars, wpars, ltm, ltv, cd, r, w, axes, mw +int sk_stati() +pointer mw_open() + +begin + # Open the wcs. + ndim = 2 + mw = mw_open (NULL, ndim) + + # Allocate working space. + call smark (sp) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (projpars, SZ_LINE, TY_CHAR) + call salloc (wpars, SZ_LINE, TY_CHAR) + call salloc (ltm, ndim * ndim, TY_DOUBLE) + call salloc (ltv, ndim, TY_DOUBLE) + call salloc (cd, ndim * ndim, TY_DOUBLE) + call salloc (r, ndim, TY_DOUBLE) + call salloc (w, ndim, TY_DOUBLE) + call salloc (axes, 2, TY_INT) + + + # Set the wcs. + iferr (call mw_newsystem (mw, "image", ndim)) + ; + + # Set the axes and projection type. + Memi[axes] = 1 + Memi[axes+1] = 2 + if (projection[1] == EOS) { + call mw_swtype (mw, Memi[axes], ndim, "linear", "") + } else { + call sscan (projection) + call gargwrd (Memc[projstr], SZ_FNAME) + call gargstr (Memc[projpars], SZ_LINE) + call sprintf (Memc[wpars], SZ_LINE, + "axis 1: axtype = ra %s axis 2: axtype = dec %s") + call pargstr (Memc[projpars]) + call pargstr (Memc[projpars]) + call mw_swtype (mw, Memi[axes], ndim, Memc[projstr], Memc[wpars]) + } + + # Set the lterm. + call mw_mkidmd (Memd[ltm], ndim) + call aclrd (Memd[ltv], ndim) + call mw_sltermd (mw, Memd[ltm], Memd[ltv], ndim) + + # Set the wterm. + call mw_mkidmd (Memd[cd], ndim) + call aclrd (Memd[r], ndim) + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_DEGREES: + Memd[w] = lngref + case SKY_RADIANS: + Memd[w] = RADTODEG(lngref) + case SKY_HOURS: + Memd[w] = 15.0d0 * lngref + default: + Memd[w] = lngref + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_DEGREES: + Memd[w+1] = latref + case SKY_RADIANS: + Memd[w+1] = RADTODEG(latref) + case SKY_HOURS: + Memd[w+1] = 15.0d0 * latref + default: + Memd[w+1] = latref + } + call mw_swtermd (mw, Memd[r], Memd[w], Memd[cd], ndim) + + call sfree (sp) + + return (mw) +end + + diff --git a/pkg/images/imcoords/src/healpix.x b/pkg/images/imcoords/src/healpix.x new file mode 100644 index 00000000..1156607c --- /dev/null +++ b/pkg/images/imcoords/src/healpix.x @@ -0,0 +1,492 @@ +include <math.h> + +define MTYPES "|nest|ring|" +define NEST 1 +define RING 2 + +define NS_MAX 8192 +define TWOTHIRDS 0.66666666667 + + +# ANG2PIX -- Compute the HEALPix map row from a spherical coordinate. +# +# It is up to the caller to know the coordinate type, map type, and +# resolution for the map. +# +# The returned row is 1 indexed. + +procedure ang2row (row, lng, lat, mtype, nside) + +int row #O Table row +double lng #I Longitude (deg) +double lat #I Latitude (deg) +int mtype #I HEALPix map type +int nside #I Resolution parameter + +int ipix +double phi, theta +errchk ang2pix_nest, ang2pix_ring + +begin + # Check parameters and call appropriate procedure. + + if (nside < 1 || nside > NS_MAX) + call error (1, "nside out of range") + + if (lat < -90D0 || lat > 90D0) + call error (2, "latitude out of range") + + phi = DEGTORAD (lng) + theta = DEGTORAD (90D0 - lat) + + switch (mtype) { + case NEST: + call ang2pix_nest (nside, theta, phi, ipix) + case RING: + call ang2pix_ring (nside, theta, phi, ipix) + default: + call error (3, "unknown HEALPix map type") + } + + row = ipix + 1 +end + + +# PIX2ANG -- Compute spherical coordinate from HEALPix map row. +# +# It is up to the caller to know the coordinate type, map type, and +# resolution for the map. + +procedure row2ang (row, lng, lat, mtype, nside) + +int row #I Table row (1 indexed) +double lng #O Longitude (deg) +double lat #O Latitude (deg) +int mtype #I HEALPix map type +int nside #I Resolution parameter + +int ipix +double phi, theta +errchk pix2ang_nest, pix2ang_ring + +begin + # Check input parameters and call appropriate procedure. + + if (nside < 1 || nside > NS_MAX) + call error (1, "nside out of range") + + if (row < 1 || row > 12*nside*nside) + call error (1, "row out of range") + + ipix = row - 1 + + switch (mtype) { + case NEST: + call pix2ang_nest (nside, ipix, theta, phi) + case RING: + call pix2ang_ring (nside, ipix, theta, phi) + default: + call error (3, "unknown HEALPix map type") + } + + lng = RADTODEG (phi) + lat = 90D0 - RADTODEG (theta) +end + + +# The following routines are SPP translations of the HEALPix software from +# the authors identified below. If it matters, the C version was used +# though the translation is not necessarily exact. Comments were +# largely removed. +# +# I'm not sure if the arguments to the floor function in the original +# can be negative. Assuming not I just do an integer truncation. + +# ----------------------------------------------------------------------------- +# +# Copyright (C) 1997-2008 Krzysztof M. Gorski, Eric Hivon, +# Benjamin D. Wandelt, Anthony J. Banday, +# Matthias Bartelmann, +# Reza Ansari & Kenneth M. Ganga +# +# +# This file is part of HEALPix. +# +# HEALPix is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published +# by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# HEALPix is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with HEALPix; if not, write to the Free Software +# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA +# 02110-1301 USA +# +# For more information about HEALPix see http://healpix.jpl.nasa.gov +# +#----------------------------------------------------------------------------- + + +# ANG2PIX_NEST -- Compute HEALPix index for a nested map. + +procedure ang2pix_nest (nside, theta, phi, ipix) + +int nside #I Resolution parameter +double theta #I Latitude (rad from pole) +double phi #I Longitude (rad) +int ipix #O HEALPix index + +double z, za, tt, tp, tmp +int face_num, jp, jm +long ifp, ifm +int ix, iy, ix_low, ix_hi, iy_low, iy_hi, ipf, ntt +int x2pix[128], y2pix[128] +int setup_done + +errchk mk_xy2pix + +data setup_done/NO/ + +begin + if (setup_done == NO) { + call mk_xy2pix (x2pix, y2pix) + setup_done = YES + } + + z = cos (theta) + za = abs (z) + if (phi >= TWOPI) + phi = phi - TWOPI + if (phi < 0.) + phi = phi + TWOPI + tt = phi / HALFPI + + if (za <= TWOTHIRDS) { + jp = int (NS_MAX * (0.5 + tt - z * 0.75)) + jm = int (NS_MAX * (0.5 + tt + z * 0.75)) + + ifp = jp / NS_MAX + ifm = jm / NS_MAX + + if (ifp==ifm) + face_num = mod (ifp, 4) + 4 + else if (ifp<ifm) + face_num = mod (ifp, 4) + else + face_num = mod (ifm, 4) + 8 + + ix = mod (jm, NS_MAX) + iy = NS_MAX - mod (jp, NS_MAX) - 1 + } else { + ntt = int (tt) + if (ntt >= 4) + ntt = 3 + tp = tt - ntt + tmp = sqrt (3. * (1. - za)) + + jp = int (NS_MAX * tp * tmp) + jm = int (NS_MAX * (1. - tp) * tmp) + jp = min (jp, NS_MAX-1) + jm = min (jm, NS_MAX-1) + + if (z >= 0) { + face_num = ntt + ix = NS_MAX - jm - 1 + iy = NS_MAX - jp - 1 + } else { + face_num = ntt + 8 + ix = jp + iy = jm + } + } + + ix_low = mod (ix, 128) + 1 + ix_hi = ix / 128 + 1 + iy_low = mod (iy, 128) + 1 + iy_hi = iy / 128 + 1 + + ipf = (x2pix[ix_hi] + y2pix[iy_hi]) * (128 * 128) + + (x2pix[ix_low] + y2pix[iy_low]) + ipf = ipf / (NS_MAX/nside)**2 + ipix = ipf + face_num * nside**2 +end + + +# ANG2PIX_RING -- Compute HEALPix index for a ring map. + +procedure ang2pix_ring (nside, theta, phi, ipix) + +int nside #I Resolution parameter +double theta #I Latitude (rad from pole) +double phi #I Longitude (rad) +int ipix #O HEALPix index + +int nl2, nl4, ncap, npix, jp, jm, ipix1 +double z, za, tt, tp, tmp +int ir, ip, kshift + +begin + z = cos (theta) + za = abs (z) + if ( phi >= TWOPI) + phi = phi - TWOPI + if (phi < 0.) + phi = phi + TWOPI + tt = phi / HALFPI + + nl2 = 2 * nside + nl4 = 4 * nside + ncap = nl2 * (nside - 1) + npix = 12 * nside * nside + + if (za <= TWOTHIRDS) { + + jp = int (nside * (0.5 + tt - z * 0.75)) + jm = int (nside * (0.5 + tt + z * 0.75)) + + ir = nside + 1 + jp - jm + kshift = 0 + if (mod (ir,2) == 0) + kshift = 1 + + ip = int ((jp + jm - nside + kshift + 1) / 2) + 1 + if (ip > nl4) + ip = ip - nl4 + + ipix1 = ncap + nl4 * (ir - 1) + ip + } else { + + tp = tt - int (tt) + tmp = sqrt (3. * (1. - za)) + + jp = int (nside * tp * tmp) + jm = int (nside * (1. - tp) * tmp) + + ir = jp + jm + 1 + ip = int (tt * ir) + 1 + if (ip > 4*ir) + ip = ip - 4 * ir + + ipix1 = 2 * ir * (ir - 1) + ip + if (z<=0.) { + ipix1 = npix - 2 * ir * (ir + 1) + ip + } + } + ipix = ipix1 - 1 +end + + +# PIX2ANG_NEST -- Translate HEALpix nested row to spherical coordinates. + +procedure pix2ang_nest (nside, ipix, theta, phi) + +int nside #I Resolution parameter +int ipix #I HEALPix index +double theta #O Latitude (rad from pole) +double phi #O Longitude (rad) + +int npface, face_num +int ipf, ip_low, ip_trunc, ip_med, ip_hi +int ix, iy, jrt, jr, nr, jpt, jp, kshift, nl4 +double z, fn, fact1, fact2 + +int pix2x[1024], pix2y[1024] + +int jrll[12], jpll[12], setup_done +data jrll/2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4/ +data jpll/1, 3, 5, 7, 0, 2, 4, 6, 1, 3, 5, 7/ +data setup_done/NO/ + +begin + if (setup_done == NO) { + call mk_pix2xy (pix2x,pix2y) + setup_done = YES + } + + fn = 1. * nside + fact1 = 1. / (3. * fn * fn) + fact2 = 2. / (3. * fn) + nl4 = 4 * nside + + npface = nside * nside + + face_num = ipix / npface + 1 + ipf = mod (ipix, npface) + + ip_low = mod (ipf, 1024) + 1 + ip_trunc = ipf / 1024 + ip_med = mod (ip_trunc, 1024) + 1 + ip_hi = ip_trunc / 1024 + 1 + + ix = 1024*pix2x[ip_hi] + 32*pix2x[ip_med] + pix2x[ip_low] + iy = 1024*pix2y[ip_hi] + 32*pix2y[ip_med] + pix2y[ip_low] + + jrt = ix + iy + jpt = ix - iy + + jr = jrll[face_num] * nside - jrt - 1 + nr = nside + z = (2 * nside - jr) * fact2 + kshift = mod (jr - nside, 2) + if( jr < nside) { + nr = jr + z = 1. - nr * nr * fact1 + kshift = 0 + } else if (jr > 3*nside) { + nr = nl4 - jr + z = - 1. + nr * nr * fact1 + kshift = 0 + } + + jp = (jpll[face_num] * nr + jpt + 1 + kshift)/2 + if (jp > nl4) + jp = jp - nl4 + if (jp < 1) + jp = jp + nl4 + + theta = acos(z) + phi = (jp - (kshift+1)*0.5) * (HALFPI / nr) +end + + +# PIX2ANG_RING -- Convert HEALpix pixel to spherical coordinates. + +procedure pix2ang_ring (nside, ipix, theta, phi) + +int nside #I Resolution parameter +int ipix #I HEALPix index +double theta #O Latitude (rad from pole) +double phi #O Longitude (rad) + +int nl2, nl4, npix, ncap, iring, iphi, ip, ipix1 +double fact1, fact2, fodd, hip, fihip + +begin + npix = 12 * nside * nside + ipix1 = ipix + 1 + nl2 = 2 * nside + nl4 = 4 * nside + ncap = 2 * nside * (nside - 1) + fact1 = 1.5 * nside + fact2 = 3.0 * nside * nside + + if (ipix1 <= ncap) { + + hip = ipix1 / 2. + fihip = int (hip) + iring = int (sqrt (hip - sqrt (fihip))) + 1 + iphi = ipix1 - 2 * iring * (iring - 1) + + theta = acos (1. - iring * iring / fact2) + phi = (iphi - 0.5) * PI / (2. * iring) + + } else if (ipix1 <= nl2 * (5 * nside + 1)) { + + ip = ipix1 - ncap - 1 + iring = (ip / nl4) + nside + iphi = mod (ip, nl4) + 1 + + fodd = 0.5 * (1 + mod (iring + nside, 2)) + theta = acos ((nl2 - iring) / fact1) + phi = (iphi - fodd) * PI / (2. * nside) + + } else { + + ip = npix - ipix1 + 1 + hip = ip/2. + + fihip = int (hip) + iring = int (sqrt (hip - sqrt (fihip))) + 1 + iphi = 4. * iring + 1 - (ip - 2. * iring * (iring-1)) + + theta = acos (-1. + iring * iring / fact2) + phi = (iphi - 0.5) * PI / (2. * iring) + + } +end + + +# MK_XY2PIX +# +# Sets the array giving the number of the pixel lying in (x,y) +# x and y are in {1,128} +# the pixel number is in {0,128**2-1} +# +# if i-1 = sum_p=0 b_p * 2^p +# then ix = sum_p=0 b_p * 4^p +# iy = 2*ix +# ix + iy in {0, 128**2 -1} + +procedure mk_xy2pix (x2pix, y2pix) + +int x2pix[128], y2pix[128] + +int i, j, k, ip, id + +begin + do i = 1, 128 + x2pix[i] = 0 + + do i = 1, 128 { + j = i - 1 + k = 0 + ip = 1 + while (j != 0) { + id = mod (j, 2) + j = j / 2 + k = ip * id + k + ip = ip * 4 + } + x2pix[i] = k + y2pix[i] = 2 * k + } +end + + +# MK_PIX2XY +# +# Constructs the array giving x and y in the face from pixel number +# for the nested (quad-cube like) ordering of pixels. +# +# The bits corresponding to x and y are interleaved in the pixel number. +# One breaks up the pixel number by even and odd bits. + +procedure mk_pix2xy (pix2x, pix2y) + +int pix2x[1024], pix2y[1024] + +int kpix, jpix, ix, iy, ip, id + +begin + + do kpix = 1, 1024 + pix2x[kpix] = 0 + + do kpix = 1, 1024 { + jpix = kpix - 1 + ix = 0 + iy = 0 + ip = 1 + while (jpix != 0) { + id = mod (jpix, 2) + jpix = jpix / 2 + ix = id * ip + ix + + id = mod (jpix, 2) + jpix = jpix / 2 + iy = id * ip + iy + + ip = 2 * ip + } + + pix2x[kpix] = ix + pix2y[kpix] = iy + } + +end diff --git a/pkg/images/imcoords/src/mkcwcs.cl b/pkg/images/imcoords/src/mkcwcs.cl new file mode 100644 index 00000000..fde777cd --- /dev/null +++ b/pkg/images/imcoords/src/mkcwcs.cl @@ -0,0 +1,94 @@ +# MKCWCS -- Make celestial WCS. + +procedure mkcwcs (wcsname) + +file wcsname {prompt="WCS to create"} +file wcsref = "" {prompt="WCS reference\n"} + +real equinox = INDEF {prompt="Equinox (years)"} +real ra = INDEF {prompt="RA (hours)"} +real dec = INDEF {prompt="DEC (degrees)"} +real scale = INDEF {prompt="Celestial pixel scale (arcsec/pix)"} +real pa = 0. {prompt="Position angle (deg)"} +bool lefthanded = yes {prompt="Left-handed system?"} +string projection = "tan" {prompt="Celestial projection\n", + enum="linear|tan|sin"} + +real rapix = INDEF {prompt="RA reference pixel"} +real decpix = INDEF {prompt="DEC reference pixel"} + +begin + int wcsdim = 2 + real c, s, lh + file name, ref, wcs + + # Determine the input and reference images. + name = wcsname + if (fscan (wcsref, ref) > 0) + wcscopy (name, ref) + + # Set the axes. + if (imaccess (name)) { + hedit (name, "ctype1", "RA---TAN", + add+, addonly-, verify-, show-, update+) + hedit (name, "ctype2", "DEC---TAN", + add+, addonly-, verify-, show-, update+) + } + wcsedit (name, "axtype", "ra", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "axtype", "dec", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "wtype", projection, "1,2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + + # Set the celestial equinox if desired. Note this is not WCS. + if (equinox != INDEF) + hedit (name, "equinox", equinox, + add+, addonly-, verify-, show-, update+) + + # Set the reference point if desired. + if (ra != INDEF) + wcsedit (name, "crval", ra*15, "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + if (dec != INDEF) + wcsedit (name, "crval", dec, "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + + # Set the scales and celestial position angle. + if (scale != INDEF) { + if (pa != INDEF) { + c = cos (pa * 3.14159 / 180.) / 3600. + s = sin (pa * 3.14159 / 180.) / 3600. + } else { + c = 1. + s = 0. + } + if (lefthanded) { + wcsedit (name, "cd", -scale*c, "1", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", -scale*s, "1", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", -scale*s, "2", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", scale*c, "2", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + } else { + wcsedit (name, "cd", scale*c, "1", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", -scale*s, "1", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", scale*s, "2", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", scale*c, "2", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + } + } + + # Set reference pixel if desired. + if (rapix != INDEF) + wcsedit (name, "crpix", rapix, "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + if (decpix != INDEF) + wcsedit (name, "crpix", decpix, "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) +end diff --git a/pkg/images/imcoords/src/mkcwwcs.cl b/pkg/images/imcoords/src/mkcwwcs.cl new file mode 100644 index 00000000..30e26814 --- /dev/null +++ b/pkg/images/imcoords/src/mkcwwcs.cl @@ -0,0 +1,102 @@ +# MKCWWCS -- MaKe Celestial, Wavelength 3D World Coordinate System + +procedure mkcwwcs (wcsname) + +file wcsname {prompt="WCS to create"} +file wcsref = "" {prompt="WCS reference\n"} + +real equinox = INDEF {prompt="Equinox (years)"} +real ra = INDEF {prompt="RA (hours)"} +real dec = INDEF {prompt="DEC (degrees)"} +real scale = INDEF {prompt="Celestial pixel scale (arcsec/pix)"} +real pa = 0. {prompt="Position angle (deg)"} +bool lefthanded = yes {prompt="Left-handed system?"} +string projection = "tan" {prompt="Celestial projection\n", + enum="linear|tan|sin"} + +real wave = INDEF {prompt="Wavelength"} +real wscale = INDEF {prompt="Wavelength scale\n"} + +real rapix = INDEF {prompt="RA reference pixel"} +real decpix = INDEF {prompt="DEC reference pixel"} +real wpix = INDEF {prompt="Wavelength reference pixel"} + +begin + int wcsdim = 3 + real c, s, lh + file name, ref, wcs + + # Determine the input and reference images. + name = wcsname + if (fscan (wcsref, ref) > 0) + wcscopy (name, ref) + + # Set the axes. + wcsedit (name, "axtype", "ra", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "axtype", "dec", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "wtype", projection, "1,2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + + # Set the celestial equinox if desired. Note this is not WCS. + if (equinox != INDEF) + hedit (name, "equinox", equinox, + add+, addonly-, verify-, show-, update+) + + # Set the reference point if desired. + if (ra != INDEF) + wcsedit (name, "crval", ra*15, "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + if (dec != INDEF) + wcsedit (name, "crval", dec, "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + if (wave != INDEF) + wcsedit (name, "crval", wave, "3", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + + # Set the scales and celestial position angle. + if (scale != INDEF) { + if (pa != INDEF) { + c = cos (pa * 3.14159 / 180.) / 3600. + s = sin (pa * 3.14159 / 180.) / 3600. + } else { + c = 1. + s = 0. + } + if (lefthanded) { + wcsedit (name, "cd", -scale*c, "1", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", -scale*s, "1", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", -scale*s, "2", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", scale*c, "2", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + } else { + wcsedit (name, "cd", scale*c, "1", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", -scale*s, "1", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", scale*s, "2", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", scale*c, "2", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + } + } + if (wscale != INDEF) + wcsedit (name, "cd", wscale, "3", "3", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + + # Set reference pixel if desired. + if (rapix != INDEF) + wcsedit (name, "crpix", rapix, "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + if (decpix != INDEF) + wcsedit (name, "crpix", decpix, "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + if (wpix != INDEF) + wcsedit (name, "crpix", wpix, "3", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + +end diff --git a/pkg/images/imcoords/src/mkpkg b/pkg/images/imcoords/src/mkpkg new file mode 100644 index 00000000..6b1632ab --- /dev/null +++ b/pkg/images/imcoords/src/mkpkg @@ -0,0 +1,47 @@ +# Library for the IMAGES IMCOORDS Subpackage Tasks + +$checkout libpkg.a ../../ +$update libpkg.a +$checkin libpkg.a ../../ +$exit + +generic: + $set GEN = "$$generic -k" + + $ifolder (rgstr.x, rgstr.gx) + $(GEN) rgstr.gx -o rgstr.x $endif + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + ccfunc.x <imhdr.h> <math.h> <mwset.h> <pkg/skywcs.h> \ + <math/gsurfit.h> + ccstd.x <mach.h> <math.h> <math/gsurfit.h> <pkg/skywcs.h> + ccxytran.x <math.h> <pkg/skywcs.h> + healpix.x <math.h> + rgstr.x <ctype.h> + sfconvolve.x <imset.h> <math.h> starfind.h + sffind.x <error.h> <mach.h> <imhdr.h> <imset.h> <fset.h> \ + <math.h> starfind.h + sftools.x <mach.h> starfind.h + skyctran.x <fset.h> <ctype.h> <math.h> <pkg/skywcs.h> + t_ccfind.x <fset.h> <ctype.h> <imhdr.h> <pkg/skywcs.h> + t_ccget.x <fset.h> <evvexpr.h> <math.h> <ctotok.h> <lexnum.h> \ + <ctype.h> <pkg/skywcs.h> + t_ccmap.x <fset.h> <math/gsurfit.h> <ctype.h> <math.h> \ + <imhdr.h> "../../lib/geomap.h" <pkg/skywcs.h> + t_ccsetwcs.x <imhdr.h> <math.h> <mwset.h> <pkg/skywcs.h> + t_ccstd.x <fset.h> <ctype.h> <math.h> <pkg/skywcs.h> + t_cctran.x <fset.h> <ctype.h> <math.h> <pkg/skywcs.h> + t_ccxymatch.x <fset.h> <pkg/skywcs.h> "../../lib/xyxymatch.h" + t_hpctran.x <math.h> + t_imcctran.x <fset.h> <imhdr.h> <mwset.h> <math.h> <math/gsurfit.h> \ + <pkg/skywcs.h> + t_skyctran.x <fset.h> <pkg/skywcs.h> + t_starfind.x <fset.h> + t_wcsctran.x <imio.h> <fset.h> <ctype.h> <imhdr.h> <ctotok.h> \ + <mwset.h> + t_wcsedit.x <fset.h> <imhdr.h> <mwset.h> + t_wcsreset.x <error.h> <imhdr.h> <mwset.h> + ; diff --git a/pkg/images/imcoords/src/rgstr.gx b/pkg/images/imcoords/src/rgstr.gx new file mode 100644 index 00000000..3647f80b --- /dev/null +++ b/pkg/images/imcoords/src/rgstr.gx @@ -0,0 +1,109 @@ +include <ctype.h> + +$for (rd) + +# RG_APACK_LINE -- Fields are packed into the output buffer. Transformed +# fields are converted to strings; other fields are copied from the input +# line to the output buffer. + +procedure rg_apack_line$t (inbuf, outbuf, maxch, field_pos, nfields, + cinfields, ncin, coords, laxno, formats, nsdig, ncout, min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int field_pos[ARB] #I starting positions for the fields +int nfields #I the number of fields +int cinfields[ARB] #I fields to be replaced +int ncin #I the number of input fields +PIXEL coords[ARB] #I the transformed coordinates +int laxno[ARB] #I the logical axis mapping +pointer formats[ARB] #I array of format pointers +int nsdig[ARB] #I array of numbers of significant digits +int ncout #I the number of coordinates +int min_sigdigits #I the minimum number of signficant digits + +int op, num_field, width, cf, cfptr +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + # Copy the file replacing fields as one goes. + do num_field = 1, nfields { + + # Find the width of the field. + width = field_pos[num_field + 1] - field_pos[num_field] + + # Find the field to be replaced. + cfptr = 0 + do cf = 1, ncin { + if (cinfields[cf] != num_field) + next + cfptr = cf + break + } + + # Replace the field. + if (cfptr != 0) { + if (laxno[cfptr] == 0) { + Memc[field] = EOS + next + #call li_format_field$t ($INDEF$T, Memc[field], maxch, + #Memc[formats[cfptr]], nsdig[cfptr], width, + #min_sigdigits) + } else + call li_format_field$t (coords[laxno[cfptr]], Memc[field], + maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]], + width, min_sigdigits) + } else { + # Put "width" characters from inbuf into field + call strcpy (inbuf[field_pos[num_field]], Memc[field], width) + } + + # Fields must be delimited by at least one blank. + if (num_field > 1 && !IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + do cfptr = ncin + 1, ncout { + + # Copy out the extra fields if any. + if (laxno[cfptr] == 0) { + Memc[field] = EOS + next + #call li_format_field$t ($INDEF$T, Memc[field], maxch, "%g", + #min_sigdigits, width, min_sigdigits) + } else + call li_format_field$t (coords[laxno[cfptr]], Memc[field], + maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]], + width, min_sigdigits) + + # Fields must be delimited by at least one blank. + if (!IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + +$endfor diff --git a/pkg/images/imcoords/src/rgstr.x b/pkg/images/imcoords/src/rgstr.x new file mode 100644 index 00000000..4e3d0836 --- /dev/null +++ b/pkg/images/imcoords/src/rgstr.x @@ -0,0 +1,215 @@ +include <ctype.h> + + + +# RG_APACK_LINE -- Fields are packed into the output buffer. Transformed +# fields are converted to strings; other fields are copied from the input +# line to the output buffer. + +procedure rg_apack_liner (inbuf, outbuf, maxch, field_pos, nfields, + cinfields, ncin, coords, laxno, formats, nsdig, ncout, min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int field_pos[ARB] #I starting positions for the fields +int nfields #I the number of fields +int cinfields[ARB] #I fields to be replaced +int ncin #I the number of input fields +real coords[ARB] #I the transformed coordinates +int laxno[ARB] #I the logical axis mapping +pointer formats[ARB] #I array of format pointers +int nsdig[ARB] #I array of numbers of significant digits +int ncout #I the number of coordinates +int min_sigdigits #I the minimum number of signficant digits + +int op, num_field, width, cf, cfptr +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + # Copy the file replacing fields as one goes. + do num_field = 1, nfields { + + # Find the width of the field. + width = field_pos[num_field + 1] - field_pos[num_field] + + # Find the field to be replaced. + cfptr = 0 + do cf = 1, ncin { + if (cinfields[cf] != num_field) + next + cfptr = cf + break + } + + # Replace the field. + if (cfptr != 0) { + if (laxno[cfptr] == 0) { + Memc[field] = EOS + next + #call li_format_field$t ($INDEF$T, Memc[field], maxch, + #Memc[formats[cfptr]], nsdig[cfptr], width, + #min_sigdigits) + } else + call li_format_fieldr (coords[laxno[cfptr]], Memc[field], + maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]], + width, min_sigdigits) + } else { + # Put "width" characters from inbuf into field + call strcpy (inbuf[field_pos[num_field]], Memc[field], width) + } + + # Fields must be delimited by at least one blank. + if (num_field > 1 && !IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + do cfptr = ncin + 1, ncout { + + # Copy out the extra fields if any. + if (laxno[cfptr] == 0) { + Memc[field] = EOS + next + #call li_format_field$t ($INDEF$T, Memc[field], maxch, "%g", + #min_sigdigits, width, min_sigdigits) + } else + call li_format_fieldr (coords[laxno[cfptr]], Memc[field], + maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]], + width, min_sigdigits) + + # Fields must be delimited by at least one blank. + if (!IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + + + +# RG_APACK_LINE -- Fields are packed into the output buffer. Transformed +# fields are converted to strings; other fields are copied from the input +# line to the output buffer. + +procedure rg_apack_lined (inbuf, outbuf, maxch, field_pos, nfields, + cinfields, ncin, coords, laxno, formats, nsdig, ncout, min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int field_pos[ARB] #I starting positions for the fields +int nfields #I the number of fields +int cinfields[ARB] #I fields to be replaced +int ncin #I the number of input fields +double coords[ARB] #I the transformed coordinates +int laxno[ARB] #I the logical axis mapping +pointer formats[ARB] #I array of format pointers +int nsdig[ARB] #I array of numbers of significant digits +int ncout #I the number of coordinates +int min_sigdigits #I the minimum number of signficant digits + +int op, num_field, width, cf, cfptr +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + # Copy the file replacing fields as one goes. + do num_field = 1, nfields { + + # Find the width of the field. + width = field_pos[num_field + 1] - field_pos[num_field] + + # Find the field to be replaced. + cfptr = 0 + do cf = 1, ncin { + if (cinfields[cf] != num_field) + next + cfptr = cf + break + } + + # Replace the field. + if (cfptr != 0) { + if (laxno[cfptr] == 0) { + Memc[field] = EOS + next + #call li_format_field$t ($INDEF$T, Memc[field], maxch, + #Memc[formats[cfptr]], nsdig[cfptr], width, + #min_sigdigits) + } else + call li_format_fieldd (coords[laxno[cfptr]], Memc[field], + maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]], + width, min_sigdigits) + } else { + # Put "width" characters from inbuf into field + call strcpy (inbuf[field_pos[num_field]], Memc[field], width) + } + + # Fields must be delimited by at least one blank. + if (num_field > 1 && !IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + do cfptr = ncin + 1, ncout { + + # Copy out the extra fields if any. + if (laxno[cfptr] == 0) { + Memc[field] = EOS + next + #call li_format_field$t ($INDEF$T, Memc[field], maxch, "%g", + #min_sigdigits, width, min_sigdigits) + } else + call li_format_fieldd (coords[laxno[cfptr]], Memc[field], + maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]], + width, min_sigdigits) + + # Fields must be delimited by at least one blank. + if (!IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + + diff --git a/pkg/images/imcoords/src/sfconvolve.x b/pkg/images/imcoords/src/sfconvolve.x new file mode 100644 index 00000000..39411c2d --- /dev/null +++ b/pkg/images/imcoords/src/sfconvolve.x @@ -0,0 +1,398 @@ +include <imset.h> +include <math.h> +include "starfind.h" + + +# SF_EGPARAMS -- Calculate the parameters of the elliptical Gaussian needed +# to compute the Gaussian convolution kernel. + +procedure sf_egparams (sigma, ratio, theta, nsigma, a, b, c, f, nx, ny) + +real sigma #I sigma of Gaussian in x +real ratio #I ratio of half-width in y to x +real theta #I position angle of Gaussian +real nsigma #I limit of convolution +real a, b, c, f #O ellipse parameters +int nx, ny #O dimensions of the kernel + +real sx2, sy2, cost, sint, discrim +bool fp_equalr () + +begin + # Define some temporary variables. + sx2 = sigma ** 2 + sy2 = (ratio * sigma) ** 2 + cost = cos (DEGTORAD (theta)) + sint = sin (DEGTORAD (theta)) + + # Compute the ellipse parameters. + if (fp_equalr (ratio, 0.0)) { + if (fp_equalr (theta, 0.0) || fp_equalr (theta, 180.)) { + a = 1. / sx2 + b = 0.0 + c = 0.0 + } else if (fp_equalr (theta, 90.0)) { + a = 0.0 + b = 0.0 + c = 1. / sx2 + } else + call error (0, "SF_EGPARAMS: Cannot make 1D Gaussian.") + f = nsigma ** 2 / 2. + nx = 2 * int (max (sigma * nsigma * abs (cost), RMIN)) + 1 + ny = 2 * int (max (sigma * nsigma * abs (sint), RMIN)) + 1 + } else { + a = cost ** 2 / sx2 + sint ** 2 / sy2 + b = 2. * (1.0 / sx2 - 1.0 / sy2) * cost * sint + c = sint ** 2 / sx2 + cost ** 2 / sy2 + discrim = b ** 2 - 4. * a * c + f = nsigma ** 2 / 2. + nx = 2 * int (max (sqrt (-8. * c * f / discrim), RMIN)) + 1 + ny = 2 * int (max (sqrt (-8. * a * f / discrim), RMIN)) + 1 + } +end + + +# SF_EGKERNEL -- Compute the non-normalized and normalized elliptical +# Gaussian kernel and the skip array. + +real procedure sf_egkernel (gkernel, ngkernel, skip, nx, ny, gsums, a, b, c, f) + +real gkernel[nx,ny] #O output Gaussian amplitude kernel +real ngkernel[nx,ny] #O output normalized Gaussian amplitude kernel +int skip[nx,ny] #O output skip subraster +int nx, ny #I input dimensions of the kernel +real gsums[ARB] #O output array of gsums +real a, b, c, f #I ellipse parameters + +int i, j, x0, y0, x, y +real rjsq, rsq, relerr, ef + +begin + # Initialize. + x0 = nx / 2 + 1 + y0 = ny / 2 + 1 + gsums[GAUSS_PIXELS] = 0.0 + gsums[GAUSS_SUMG] = 0.0 + gsums[GAUSS_SUMGSQ] = 0.0 + + # Compute the kernel and principal sums. + do j = 1, ny { + y = j - y0 + rjsq = y ** 2 + do i = 1, nx { + x = i - x0 + rsq = sqrt (x ** 2 + rjsq) + ef = 0.5 * (a * x ** 2 + c * y ** 2 + b * x * y) + gkernel[i,j] = exp (-1.0 * ef) + if (ef <= f || rsq <= RMIN) { + ngkernel[i,j] = gkernel[i,j] + gsums[GAUSS_SUMG] = gsums[GAUSS_SUMG] + gkernel[i,j] + gsums[GAUSS_SUMGSQ] = gsums[GAUSS_SUMGSQ] + + gkernel[i,j] ** 2 + skip[i,j] = NO + gsums[GAUSS_PIXELS] = gsums[GAUSS_PIXELS] + 1.0 + } else { + ngkernel[i,j] = 0.0 + skip[i,j] = YES + } + } + } + + # Store the remaining sums. + gsums[GAUSS_DENOM] = gsums[GAUSS_SUMGSQ] - gsums[GAUSS_SUMG] ** 2 / + gsums[GAUSS_PIXELS] + gsums[GAUSS_SGOP] = gsums[GAUSS_SUMG] / gsums[GAUSS_PIXELS] + + # Normalize the kernel. + do j = 1, ny { + do i = 1, nx { + if (skip[i,j] == NO) + ngkernel[i,j] = (gkernel[i,j] - gsums[GAUSS_SGOP]) / + gsums[GAUSS_DENOM] + } + } + + + relerr = 1.0 / gsums[GAUSS_DENOM] + + return (sqrt (relerr)) +end + + +# SF_FCONVOLVE -- Solve for the density enhancements in the case where +# datamin and datamax are not defined. + +procedure sf_fconvolve (im, c1, c2, l1, l2, bwidth, imbuf, denbuf, ncols, + nlines, kernel, skip, nxk, nyk) + +pointer im #I pointer to the input image +int c1, c2 #I column limits in the input image +int l1, l2 #I line limits in the input image +int bwidth #I width of pixel buffer +real imbuf[ncols,nlines] #O the output data buffer +real denbuf[ncols,nlines] #O the output density enhancement buffer +int ncols, nlines #I dimensions of the output buffers +real kernel[nxk,nyk] #I the convolution kernel +int skip[nxk,nyk] #I the skip array +int nxk, nyk #I dimensions of the kernel + +int i, col1, col2, inline, index, outline +pointer sp, lineptrs +pointer imgs2r() +errchk imgs2r + +begin + # Set up an array of linepointers. + call smark (sp) + call salloc (lineptrs, nyk, TY_POINTER) + + # Set the number of image buffers. + call imseti (im, IM_NBUFS, nyk) + + # Set input image column limits. + col1 = c1 - nxk / 2 - bwidth + col2 = c2 + nxk / 2 + bwidth + + # Initialise the line buffers at the same time copying the image + # input the data buffer. + inline = l1 - bwidth - nyk / 2 + do index = 1 , nyk - 1 { + Memi[lineptrs+index] = imgs2r (im, col1, col2, inline, inline) + call amovr (Memr[Memi[lineptrs+index]], imbuf[1,index], ncols) + inline = inline + 1 + } + + # Zero the initial density enhancement buffers. + do i = 1, nyk / 2 + call amovkr (0.0, denbuf[1,i], ncols) + + # Generate the output image line by line. + do outline = 1, l2 - l1 + 2 * bwidth + 1 { + + # Scroll the input buffers. + do i = 1, nyk - 1 + Memi[lineptrs+i-1] = Memi[lineptrs+i] + + # Read in new image line and copy it into the image buffer. + Memi[lineptrs+nyk-1] = imgs2r (im, col1, col2, inline, + inline) + + # Compute the input image line into the data buffer. + call amovr (Memr[Memi[lineptrs+nyk-1]], imbuf[1,index], ncols) + + # Generate first output image line. + call aclrr (denbuf[1,outline+nyk/2], ncols) + do i = 1, nyk + call sf_skcnvr (Memr[Memi[lineptrs+i-1]], + denbuf[1+nxk/2,outline+nyk/2], c2 - c1 + 2 * bwidth + 1, + kernel[1,i], skip[1,i], nxk) + + inline = inline + 1 + index = index + 1 + } + + # Zero the final density enhancement buffer lines. + do i = nlines - nyk / 2 + 1, nlines + call amovkr (0.0, denbuf[1,i], ncols) + + # Free the image buffer pointers. + call sfree (sp) +end + + +# SF_GCONVOLVE -- Solve for the density enhancement image in the case where +# datamin and datamax are defined. + +procedure sf_gconvolve (im, c1, c2, l1, l2, bwidth, imbuf, denbuf, ncols, + nlines, kernel, skip, nxk, nyk, gsums, datamin, datamax) + +pointer im # pointer to the input image +int c1, c2 #I column limits in the input image +int l1, l2 #I line limits in the input image +int bwidth #I width of pixel buffer +real imbuf[ncols,nlines] #O the output data buffer +real denbuf[ncols,nlines] #O the output density enhancement buffer +int ncols, nlines #I dimensions of the output buffers +real kernel[nxk,nyk] #I the first convolution kernel +int skip[nxk,nyk] #I the sky array +int nxk, nyk #I dimensions of the kernel +real gsums[ARB] #U array of kernel sums +real datamin, datamax #I the good data minimum and maximum + +int i, nc, col1, col2, inline, index, outline +pointer sp, lineptrs, sd, sgsq, sg, p +pointer imgs2r() +errchk imgs2r() + +begin + # Set up an array of linepointers. + call smark (sp) + call salloc (lineptrs, nyk, TY_POINTER) + + # Set the number of image buffers. + call imseti (im, IM_NBUFS, nyk) + + # Allocate some working space. + nc = c2 - c1 + 2 * bwidth + 1 + call salloc (sd, nc, TY_REAL) + call salloc (sgsq, nc, TY_REAL) + call salloc (sg, nc, TY_REAL) + call salloc (p, nc, TY_REAL) + + # Set input image column limits. + col1 = c1 - nxk / 2 - bwidth + col2 = c2 + nxk / 2 + bwidth + + # Initialise the line buffers. + inline = l1 - bwidth - nyk / 2 + do index = 1 , nyk - 1 { + Memi[lineptrs+index] = imgs2r (im, col1, col2, inline, inline) + call amovr (Memr[Memi[lineptrs+index]], imbuf[1,index], ncols) + inline = inline + 1 + } + + # Zero the initial density enhancement buffers. + do i = 1, nyk / 2 + call amovkr (0.0, denbuf[1,i], ncols) + + # Generate the output image line by line. + do outline = 1, l2 - l1 + 2 * bwidth + 1 { + + # 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 (im, col1, col2, inline, + inline) + + # Compute the input image line into the data buffer. + call amovr (Memr[Memi[lineptrs+nyk-1]], imbuf[1,index], ncols) + + # Generate first output image line. + call aclrr (denbuf[1,outline+nyk/2], ncols) + call aclrr (Memr[sd], nc) + call amovkr (gsums[GAUSS_SUMG], Memr[sg], nc) + call amovkr (gsums[GAUSS_SUMGSQ], Memr[sgsq], nc) + call amovkr (gsums[GAUSS_PIXELS], Memr[p], nc) + + do i = 1, nyk + call sf_gdsum (Memr[Memi[lineptrs+i-1]], + denbuf[1+nxk/2,outline+nyk/2], Memr[sd], + Memr[sg], Memr[sgsq], Memr[p], nc, kernel[1,i], + skip[1,i], nxk, datamin, datamax) + call sf_gdavg (denbuf[1+nxk/2,outline+nyk/2], Memr[sd], Memr[sg], + Memr[sgsq], Memr[p], nc, gsums[GAUSS_PIXELS], + gsums[GAUSS_DENOM], gsums[GAUSS_SGOP]) + + inline = inline + 1 + index = index + 1 + } + + # Zero the final density enhancement buffer lines. + do i = nlines - nyk / 2 + 1, nlines + call amovkr (0.0, denbuf[1,i], ncols) + + # Free the image buffer pointers. + call sfree (sp) +end + + +# SF_SKCNVR -- Compute the convolution kernel using a skip array. + +procedure sf_skcnvr (in, out, npix, kernel, skip, nk) + +real in[npix+nk-1] #I the input vector +real out[npix] #O the output vector +int npix #I the size of the vector +real kernel[ARB] #I the convolution kernel +int skip[ARB] #I the skip array +int nk #I the size of the convolution kernel + +int i, j +real sum + +begin + do i = 1, npix { + sum = out[i] + do j = 1, nk { + if (skip[j] == YES) + next + sum = sum + in[i+j-1] * kernel[j] + } + out[i] = sum + } +end + + +# SF_GDSUM -- Compute the vector sums required to do the convolution. + +procedure sf_gdsum (in, sgd, sd, sg, sgsq, p, npix, kernel, skip, nk, + datamin, datamax) + +real in[npix+nk-1] #I the input vector +real sgd[ARB] #U the computed input/output convolution vector +real sd[ARB] #U the computed input/output sum vector +real sg[ARB] #U the input/ouput first normalization factor +real sgsq[ARB] #U the input/ouput second normalization factor +real p[ARB] #U the number of points vector +int npix #I the size of the vector +real kernel[ARB] #I the convolution kernel +int skip[ARB] #I the skip array +int nk #I the size of the convolution kernel +real datamin, datamax #I the good data limits. + +int i, j +real data + +begin + do i = 1, npix { + do j = 1, nk { + if (skip[j] == YES) + next + data = in[i+j-1] + if (data < datamin || data > datamax) { + sgsq[i] = sgsq[i] - kernel[j] ** 2 + sg[i] = sg[i] - kernel[j] + p[i] = p[i] - 1.0 + } else { + sgd[i] = sgd[i] + kernel[j] * data + sd[i] = sd[i] + data + } + } + } +end + + +# SF_GDAVG -- Compute the vector averages required to do the convolution. + +procedure sf_gdavg (sgd, sd, sg, sgsq, p, npix, pixels, denom, sgop) + +real sgd[ARB] #U the computed input/output convolution vector +real sd[ARB] #I the computed input/output sum vector +real sg[ARB] #I the input/ouput first normalization factor +real sgsq[ARB] #U the input/ouput second normalization factor +real p[ARB] #I the number of points vector +int npix #I the size of the vector +real pixels #I number of pixels +real denom #I kernel normalization factor +real sgop #I kernel normalization factor + +int i + +begin + do i = 1, npix { + if (p[i] > 1.5) { + if (p[i] < pixels) { + sgsq[i] = sgsq[i] - (sg[i] ** 2) / p[i] + if (sgsq[i] != 0.0) + sgd[i] = (sgd[i] - sg[i] * sd[i] / p[i]) / sgsq[i] + else + sgd[i] = 0.0 + } else + sgd[i] = (sgd[i] - sgop * sd[i]) / denom + } else + sgd[i] = 0.0 + } +end + diff --git a/pkg/images/imcoords/src/sffind.x b/pkg/images/imcoords/src/sffind.x new file mode 100644 index 00000000..367893e5 --- /dev/null +++ b/pkg/images/imcoords/src/sffind.x @@ -0,0 +1,739 @@ +include <error.h> +include <mach.h> +include <imhdr.h> +include <imset.h> +include <fset.h> +include <math.h> +include "starfind.h" + + +# SF_FIND -- Find stars in an image using a pattern matching technique and +# a circularly symmetric Gaussian pattern. + +procedure sf_find (im, out, sf, nxblock, nyblock, wcs, wxformat, wyformat, + boundary, constant, verbose) + +pointer im #I pointer to the input image +int out #I the output file descriptor +pointer sf #I pointer to the apphot structure +int nxblock #I the x dimension blocking factor +int nyblock #I the y dimension blocking factor +char wcs[ARB] #I the world coordinate system +char wxformat[ARB] #I the x axis world coordinate format +char wyformat[ARB] #I the y axis world coordinate format +int boundary #I type of boundary extension +real constant #I constant for constant boundary extension +int verbose #I verbose switch + +int i, j, fwidth, swidth, norm +int l1, l2, c1, c2, ncols, nlines, nxb, nyb, nstars, stid +pointer sp, gker2d, ngker2d, skip, fmtstr, twxformat, twyformat +pointer imbuf, denbuf, str, mw, ct +real sigma, nsigma, a, b, c, f, gsums[LEN_GAUSS], relerr, dmin, dmax +real maglo, maghi + +bool streq() +int sf_stfind() +pointer mw_openim(), mw_sctran() +real sf_egkernel() +errchk mw_openim(), mw_sctran(), mw_gattrs() + +begin + # Allocate working space. + call smark (sp) + call salloc (twxformat, SZ_FNAME, TY_CHAR) + call salloc (twyformat, SZ_FNAME, TY_CHAR) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Compute the parameters of the Gaussian kernel. + sigma = HWHM_TO_SIGMA * SF_HWHMPSF(sf) + nsigma = SF_FRADIUS(sf) / HWHM_TO_SIGMA + call sf_egparams (sigma, 1.0, 0.0, nsigma, a, b, c, f, fwidth, fwidth) + + # Compute the separation parameter + swidth = max (2, int (SF_SEPMIN(sf) * SF_HWHMPSF(sf) + 0.5)) + + # Compute the minimum and maximum pixel values. + if (IS_INDEFR(SF_DATAMIN(sf)) && IS_INDEFR(SF_DATAMAX(sf))) { + norm = YES + dmin = -MAX_REAL + dmax = MAX_REAL + } else { + norm = NO + if (IS_INDEFR(SF_DATAMIN(sf))) + dmin = -MAX_REAL + else + dmin = SF_DATAMIN(sf) + if (IS_INDEFR(SF_DATAMAX(sf))) + dmax = MAX_REAL + else + dmax = SF_DATAMAX(sf) + } + + # Compute the magnitude limits + if (IS_INDEFR(SF_MAGLO(sf))) + maglo = -MAX_REAL + else + maglo = SF_MAGLO(sf) + if (IS_INDEFR(SF_MAGHI(sf))) + maghi = MAX_REAL + else + maghi = SF_MAGHI(sf) + + # Open the image WCS. + if (wcs[1] == EOS) { + mw = NULL + ct = NULL + } else { + iferr { + mw = mw_openim (im) + } then { + call erract (EA_WARN) + mw = NULL + ct = NULL + } else { + iferr { + ct = mw_sctran (mw, "logical", wcs, 03B) + } then { + call erract (EA_WARN) + ct = NULL + call mw_close (mw) + mw = NULL + } + } + } + + # Set the WCS formats. + if (ct == NULL) + call strcpy (wxformat, Memc[twxformat], SZ_FNAME) + else if (wxformat[1] == EOS) { + if (mw != NULL) { + iferr (call mw_gwattrs (mw, 1, "format", Memc[twxformat], + SZ_FNAME)) { + if (streq (wcs, "world")) + call strcpy ("%11.8g", Memc[twxformat], SZ_FNAME) + else + call strcpy ("%9.3f", Memc[twxformat], SZ_FNAME) + } + } else + call strcpy ("%9.3f", Memc[twxformat], SZ_FNAME) + } else + call strcpy (wxformat, Memc[twxformat], SZ_FNAME) + if (ct == NULL) + call strcpy (wyformat, Memc[twyformat], SZ_FNAME) + else if (wyformat[1] == EOS) { + if (mw != NULL) { + iferr (call mw_gwattrs (mw, 2, "format", Memc[twyformat], + SZ_FNAME)) { + if (streq (wcs, "world")) + call strcpy ("%11.8g", Memc[twyformat], SZ_FNAME) + else + call strcpy ("%9.3f", Memc[twyformat], SZ_FNAME) + } + } else + call strcpy ("%9.3f", Memc[twyformat], SZ_FNAME) + } else + call strcpy (wyformat, Memc[twyformat], SZ_FNAME) + + # Create the output format string. + call sprintf (Memc[fmtstr], + SZ_LINE, " %s %s %s %s %s %s %s %s %s %s %s\n") + call pargstr ("%9.3f") + call pargstr ("%9.3f") + call pargstr (Memc[twxformat]) + call pargstr (Memc[twyformat]) + call pargstr ("%7.2f") + call pargstr ("%6d") + call pargstr ("%6.2f") + call pargstr ("%6.3f") + call pargstr ("%6.1f") + call pargstr ("%7.3f") + call pargstr ("%6d") + + # Set up the image boundary extension characteristics. + call imseti (im, IM_TYBNDRY, boundary) + call imseti (im, IM_NBNDRYPIX, 1 + fwidth / 2 + swidth) + if (boundary == BT_CONSTANT) + call imsetr (im, IM_BNDRYPIXVAL, constant) + + # Set up the blocking factor. + # Compute the magnitude limits + if (IS_INDEFI(nxblock)) + nxb = IM_LEN(im,1) + else + nxb = nxblock + if (IS_INDEFI(nyblock)) + nyb = IM_LEN(im,2) + else + nyb = nyblock + + # Print the detection criteria on the standard output. + if (verbose == YES) { + call fstats (out, F_FILENAME, Memc[str], SZ_LINE) + call printf ("\nImage: %s Output: %s\n") + call pargstr (IM_HDRFILE(im)) + call pargstr (Memc[str]) + call printf ("Detection Parameters\n") + call printf ( + " Hwhmpsf: %0.3f (pixels) Threshold: %g (ADU) Npixmin: %d\n") + call pargr (SF_HWHMPSF(sf)) + call pargr (SF_THRESHOLD(sf)) + call pargi (SF_NPIXMIN(sf)) + call printf (" Datamin: %g (ADU) Datamax: %g (ADU)\n") + call pargr (SF_DATAMIN(sf)) + call pargr (SF_DATAMAX(sf)) + call printf (" Fradius: %0.3f (HWHM) Sepmin: %0.3f (HWHM)\n\n") + call pargr (SF_FRADIUS(sf)) + call pargr (SF_SEPMIN(sf)) + } + + if (out != NULL) { + call fstats (out, F_FILENAME, Memc[str], SZ_LINE) + call fprintf (out, "\n# Image: %s Output: %s\n") + call pargstr (IM_HDRFILE(im)) + call pargstr (Memc[str]) + call fprintf (out, "# Detection Parameters\n") + call fprintf (out, + "# Hwhmpsf: %0.3f (pixels) Threshold: %g (ADU) Npixmin: %d\n") + call pargr (SF_HWHMPSF(sf)) + call pargr (SF_THRESHOLD(sf)) + call pargi (SF_NPIXMIN(sf)) + call fprintf (out, "# Datamin: %g (ADU) Datamax: %g (ADU)\n") + call pargr (SF_DATAMIN(sf)) + call pargr (SF_DATAMAX(sf)) + call fprintf (out, "# Fradius: %g (HWHM) Sepmin: %g (HWHM)\n") + call pargr (SF_FRADIUS(sf)) + call pargr (SF_SEPMIN(sf)) + call fprintf (out, "# Selection Parameters\n") + call pargi (SF_NPIXMIN(sf)) + call fprintf (out, "# Maglo: %0.3f Maghi: %0.3f\n") + call pargr (SF_MAGLO(sf)) + call pargr (SF_MAGHI(sf)) + call fprintf (out, "# Roundlo: %0.3f Roundhi: %0.3f\n") + call pargr (SF_ROUNDLO(sf)) + call pargr (SF_ROUNDHI(sf)) + call fprintf (out, "# Sharplo: %0.3f Sharphi: %0.3f\n") + call pargr (SF_SHARPLO(sf)) + call pargr (SF_SHARPHI(sf)) + call fprintf (out, "# Columns\n") + call fprintf (out, "# 1: X 2: Y \n") + if (ct == NULL) { + call fprintf (out, "# 3: Mag 4: Area\n") + call fprintf (out, "# 5: Hwhm 6: Roundness\n") + call fprintf (out, "# 7: Pa 8: Sharpness\n\n") + } else { + call fprintf (out, "# 3: Wx 4: Wy \n") + call fprintf (out, "# 5: Mag 6: Area\n") + call fprintf (out, "# 7: Hwhm 8: Roundness\n") + call fprintf (out, "# 9: Pa 10: Sharpness\n\n") + } + } + + # Process the image block by block. + stid = 1 + nstars = 0 + do j = 1, IM_LEN(im,2), nyb { + + l1 = j + l2 = min (IM_LEN(im,2), j + nyb - 1) + nlines = l2 - l1 + 1 + 2 * (fwidth / 2 + swidth) + + do i = 1, IM_LEN(im,1), nxb { + + # Allocate space for the convolution kernel. + call malloc (gker2d, fwidth * fwidth, TY_REAL) + call malloc (ngker2d, fwidth * fwidth, TY_REAL) + call malloc (skip, fwidth * fwidth, TY_INT) + + # Allocate space for the data and the convolution. + c1 = i + c2 = min (IM_LEN(im,1), i + nxb - 1) + ncols = c2 - c1 + 1 + 2 * (fwidth / 2 + swidth) + call malloc (imbuf, ncols * nlines, TY_REAL) + call malloc (denbuf, ncols * nlines, TY_REAL) + + # Compute the convolution kernels. + relerr = sf_egkernel (Memr[gker2d], Memr[ngker2d], Memi[skip], + fwidth, fwidth, gsums, a, b, c, f) + + # Do the convolution. + if (norm == YES) + call sf_fconvolve (im, c1, c2, l1, l2, swidth, Memr[imbuf], + Memr[denbuf], ncols, nlines, Memr[ngker2d], Memi[skip], + fwidth, fwidth) + else + call sf_gconvolve (im, c1, c2, l1, l2, swidth, Memr[imbuf], + Memr[denbuf], ncols, nlines, Memr[gker2d], Memi[skip], + fwidth, fwidth, gsums, dmin, dmax) + + # Find the stars. + nstars = sf_stfind (out, Memr[imbuf], Memr[denbuf], ncols, + nlines, c1, c2, l1, l2, swidth, Memi[skip], fwidth, + fwidth, SF_HWHMPSF(sf), SF_THRESHOLD(sf), dmin, dmax, + ct, SF_NPIXMIN(sf), maglo, maghi, SF_ROUNDLO(sf), + SF_ROUNDHI(sf), SF_SHARPLO(sf), SF_SHARPHI(sf), + Memc[fmtstr], stid, verbose) + + # Increment the sequence number. + stid = stid + nstars + + # Free the memory. + call mfree (imbuf, TY_REAL) + call mfree (denbuf, TY_REAL) + call mfree (gker2d, TY_REAL) + call mfree (ngker2d, TY_REAL) + call mfree (skip, TY_INT) + } + } + + # Print out the selection parameters. + if (verbose == YES) { + call printf ("\nSelection Parameters\n") + call printf ( " Maglo: %0.3f Maghi: %0.3f\n") + call pargr (SF_MAGLO(sf)) + call pargr (SF_MAGHI(sf)) + call printf ( " Roundlo: %0.3f Roundhi: %0.3f\n") + call pargr (SF_ROUNDLO(sf)) + call pargr (SF_ROUNDHI(sf)) + call printf ( " Sharplo: %0.3f Sharphi: %0.3f\n") + call pargr (SF_SHARPLO(sf)) + call pargr (SF_SHARPHI(sf)) + } + + if (mw != NULL) { + call mw_ctfree (ct) + call mw_close (mw) + } + call sfree (sp) +end + + +# SF_STFIND -- Detect images in the convolved image and then compute image +# characteristics using the original image. + +int procedure sf_stfind (out, imbuf, denbuf, ncols, nlines, c1, c2, l1, l2, + sepmin, skip, nxk, nyk, hwhmpsf, threshold, datamin, datamax, + ct, nmin, maglo, maghi, roundlo, roundhi, sharplo, sharphi, + fmtstr, stid, verbose) + +int out #I the output file descriptor +real imbuf[ncols,nlines] #I the input data buffer +real denbuf[ncols,nlines] #I the input density enhancements buffer +int ncols, nlines #I the dimensions of the input buffers +int c1, c2 #I the image columns limits +int l1, l2 #I the image lines limits +int sepmin #I the minimum object separation +int skip[nxk,ARB] #I the pixel fitting array +int nxk, nyk #I the dimensions of the fitting array +real hwhmpsf #I the HWHM of the PSF in pixels +real threshold #I the threshold for object detection +real datamin, datamax #I the minimum and maximum good data values +pointer ct #I the coordinate transformation pointer +int nmin #I the minimum number of good object pixels +real maglo,maghi #I the magnitude estimate limits +real roundlo,roundhi #I the ellipticity estimate limits +real sharplo, sharphi #I the sharpness estimate limits +char fmtstr[ARB] #I the format string +int stid #U the object sequence number +int verbose #I verbose mode + +int line1, line2, inline, xmiddle, ymiddle, ntotal, nobjs, nstars +pointer sp, cols, sharp, x, y, ellip, theta, npix, mag, size +int sf_detect(), sf_test() + +begin + # Set up useful line and column limits. + line1 = 1 + sepmin + nyk / 2 + line2 = nlines - sepmin - nyk / 2 + xmiddle = 1 + nxk / 2 + ymiddle = 1 + nyk / 2 + + # Set up a cylindrical buffers and some working space for + # the detected images. + call smark (sp) + call salloc (cols, ncols, TY_INT) + call salloc (x, ncols, TY_REAL) + call salloc (y, ncols, TY_REAL) + call salloc (mag, ncols, TY_REAL) + call salloc (npix, ncols, TY_INT) + call salloc (size, ncols, TY_REAL) + call salloc (ellip, ncols, TY_REAL) + call salloc (theta, ncols, TY_REAL) + call salloc (sharp, ncols, TY_REAL) + + # Generate the starlist line by line. + ntotal = 0 + do inline = line1, line2 { + + # Detect local maximum in the density enhancement buffer. + nobjs = sf_detect (denbuf[1,inline-nyk/2-sepmin], ncols, sepmin, + nxk, nyk, threshold, Memi[cols]) + if (nobjs <= 0) + next + + # Do not skip the middle pixel in the moments computation. + call sf_moments (imbuf[1,inline-nyk/2], denbuf[1,inline-nyk/2], + ncols, skip, nxk, nyk, Memi[cols], Memr[x], Memr[y], + Memi[npix], Memr[mag], Memr[size], Memr[ellip], Memr[theta], + Memr[sharp], nobjs, datamin, datamax, threshold, hwhmpsf, + real (-sepmin - nxk / 2 + c1 - 1), real (inline - sepmin - + nyk + l1 - 1)) + + # Test the image characeteristics of detected objects. + nstars = sf_test (Memi[cols], Memr[x], Memr[y], Memi[npix], + Memr[mag], Memr[size], Memr[ellip], Memr[theta], Memr[sharp], + nobjs, real (c1 - 0.5), real (c2 + 0.5), real (l1 - 0.5), + real (l2 + 0.5), nmin, maglo, maghi, roundlo, roundhi, + sharplo, sharphi) + + # Print results on the standard output. + if (verbose == YES) + call sf_write (STDOUT, Memi[cols], Memr[x], Memr[y], + Memr[mag], Memi[npix], Memr[size], Memr[ellip], + Memr[theta], Memr[sharp], nstars, ct, fmtstr, + ntotal + stid) + + # Save the results in the file. + call sf_write (out, Memi[cols], Memr[x], Memr[y], Memr[mag], + Memi[npix], Memr[size], Memr[ellip], Memr[theta], + Memr[sharp], nstars, ct, fmtstr, ntotal + stid) + + ntotal = ntotal + nstars + + } + + # Free space + call sfree (sp) + + return (ntotal) +end + + +# SF_DETECT -- Detect stellar objects in an image line. In order to be +# detected as a star the candidate object must be above threshold and have +# a maximum pixel value greater than any pixels within sepmin pixels. + +int procedure sf_detect (density, ncols, sepmin, nxk, nyk, threshold, cols) + +real density[ncols, ARB] #I the input density enhancements array +int ncols #I the x dimension of the input array +int sepmin #I the minimum separation in pixels +int nxk, nyk #I size of the fitting area +real threshold #I density threshold +int cols[ARB] #O column numbers of detected stars + +int i, j, k, ymiddle, nxhalf, nyhalf, ny, b2, nobjs, rj2, r2 +define nextpix_ 11 + +begin + ymiddle = 1 + nyk / 2 + sepmin + nxhalf = nxk / 2 + nyhalf = nyk / 2 + ny = 2 * sepmin + 1 + b2 = sepmin ** 2 + + # Loop over all the columns in an image line. + nobjs = 0 + for (i = 1 + nxhalf + sepmin; i <= ncols - nxhalf - sepmin; ) { + + # Test whether the density enhancement is above threshold. + if (density[i,ymiddle] < threshold) + goto nextpix_ + + # Test whether a given density enhancement satisfies the + # separation criterion. + do j = 1, ny { + rj2 = (j - sepmin - 1) ** 2 + do k = i - sepmin, i + sepmin { + r2 = (i - k) ** 2 + rj2 + if (r2 <= b2) { + if (density[i,ymiddle] < density[k,j+nyhalf]) + goto nextpix_ + } + } + } + + # Add the detected object to the list. + nobjs = nobjs + 1 + cols[nobjs] = i + + # If a local maximum is detected there can be no need to + # check pixels in this row between i and i + sepmin. + i = i + sepmin +nextpix_ + # Work on the next pixel. + i = i + 1 + } + + return (nobjs) +end + + +# SF_MOMENTS -- Perform a moments analysis on the dectected objects. + +procedure sf_moments (data, den, ncols, skip, nxk, nyk, cols, x, y, + npix, mag, size, ellip, theta, sharp, nobjs, datamin, datamax, + threshold, hwhmpsf, xoff, yoff) + +real data[ncols,ARB] #I the input data array +real den[ncols,ARB] #I the input density enhancements array +int ncols #I the x dimension of the input buffer +int skip[nxk,ARB] #I the input fitting array +int nxk, nyk #I the dimensions of the fitting array +int cols[ARB] #I the input initial positions +real x[ARB] #O the output x coordinates +real y[ARB] #O the output y coordinates +int npix[ARB] #O the output area in number of pixels +real mag[ARB] #O the output magnitude estimates +real size[ARB] #O the output size estimates +real ellip[ARB] #O the output ellipticity estimates +real theta[ARB] #O the output position angle estimates +real sharp[ARB] #O the output sharpness estimates +int nobjs #I the number of objects +real datamin, datamax #I the minium and maximum good data values +real threshold #I threshold for moments computation +real hwhmpsf #I the HWHM of the PSF +real xoff, yoff #I the x and y coordinate offsets + +int i, j, k, xmiddle, ymiddle, sumn +double pixval, sumix, sumiy, sumi, sumixx, sumixy, sumiyy, r2, dx, dy, diff +double mean + +begin + # Initialize + xmiddle = 1 + nxk / 2 + ymiddle = 1 + nyk / 2 + + # Compute the pixel sum, number of pixels, and the x and y centers. + do i = 1, nobjs { + + # Estimate the background using the input data and the + # best fitting Gaussian amplitude + sumn = 0 + sumi = 0.0 + do j = 1, nyk { + do k = 1, nxk { + if (skip[k,j] == NO) + next + pixval = data[cols[i]-xmiddle+k,j] + if (pixval < datamin || pixval > datamax) + next + sumi = sumi + pixval + sumn = sumn + 1 + } + } + if (sumn <= 0) + mean = data[cols[i],ymiddle] - den[cols[i],ymiddle] + else + mean = sumi / sumn + + # Compute the first order moments. + sumi = 0.0 + sumn = 0 + sumix = 0.0d0 + sumiy = 0.0d0 + do j = 1, nyk { + do k = 1, nxk { + if (skip[k,j] == YES) + next + pixval = data[cols[i]-xmiddle+k,j] + if (pixval < datamin || pixval > datamax) + next + pixval = pixval - mean + if (pixval <= 0.0) + next + sumi = sumi + pixval + sumix = sumix + (cols[i] - xmiddle + k) * pixval + sumiy = sumiy + j * pixval + sumn = sumn + 1 + } + + } + + # Use the first order moments to estimate the positions + # magnitude, area, and amplitude of the object. + if (sumi <= 0.0) { + x[i] = cols[i] + y[i] = (1.0 + nyk) / 2.0 + mag[i] = INDEFR + npix[i] = 0 + } else { + x[i] = sumix / sumi + y[i] = sumiy / sumi + mag[i] = -2.5 * log10 (sumi) + npix[i] = sumn + } + + # Compute the second order central moments using the results of + # the first order moment analysis. + sumixx = 0.0d0 + sumiyy = 0.0d0 + sumixy = 0.0d0 + do j = 1, nyk { + dy = j - y[i] + do k = 1, nxk { + if (skip[k,j] == YES) + next + pixval = data[cols[i]-xmiddle+k,j] + if (pixval < datamin || pixval > datamax) + next + pixval = pixval - mean + if (pixval <= 0.0) + next + dx = cols[i] - xmiddle + k - x[i] + sumixx = sumixx + pixval * dx ** 2 + sumixy = sumixy + pixval * dx * dy + sumiyy = sumiyy + pixval * dy ** 2 + } + } + + # Use the second order central moments to estimate the size, + # ellipticity, position angle, and sharpness of the objects. + if (sumi <= 0.0) { + size[i] = 0.0 + ellip[i] = 0.0 + theta[i] = 0.0 + sharp[i] = INDEFR + } else { + sumixx = sumixx / sumi + sumixy = sumixy / sumi + sumiyy = sumiyy / sumi + r2 = sumixx + sumiyy + if (r2 <= 0.0) { + size[i] = 0.0 + ellip[i] = 0.0 + theta[i] = 0.0 + sharp[i] = INDEFR + } else { + size[i] = sqrt (LN_2 * r2) + sharp[i] = size[i] / hwhmpsf + diff = sumixx - sumiyy + ellip[i] = sqrt (diff ** 2 + 4.0d0 * sumixy ** 2) / r2 + if (diff == 0.0d0 && sumixy == 0.0d0) + theta[i] = 0.0 + else + theta[i] = RADTODEG (0.5d0 * atan2 (2.0d0 * sumixy, + diff)) + if (theta[i] < 0.0) + theta[i] = theta[i] + 180.0 + } + } + + # Convert the computed coordinates to the image system. + x[i] = x[i] + xoff + y[i] = y[i] + yoff + } +end + + +# SF_TEST -- Check that the detected objects are in the image, contain +# enough pixels above background to be measurable objects, and are within +# the specified magnitude, roundness and sharpness range. + +int procedure sf_test (cols, x, y, npix, mag, size, ellip, theta, sharps, + nobjs, c1, c2, l1, l2, nmin, maglo, maghi, roundlo, roundhi, + sharplo, sharphi) + +int cols[ARB] #U the column ids of detected object +real x[ARB] #U the x position estimates +real y[ARB] #U the y positions estimates +int npix[ARB] #U the area estimates +real mag[ARB] #U the magnitude estimates +real size[ARB] #U the size estimates +real ellip[ARB] #U the ellipticity estimates +real theta[ARB] #U the position angle estimates +real sharps[ARB] #U sharpness estimates +int nobjs #I the number of detected objects +real c1, c2 #I the image column limits +real l1, l2 #I the image line limits +int nmin #I the minimum area +real maglo, maghi #I the magnitude limits +real roundlo, roundhi #I the roundness limits +real sharplo, sharphi #I the sharpness limits + +int i, nstars + +begin + # Loop over the detected objects. + nstars = 0 + do i = 1, nobjs { + + if (x[i] < c1 || x[i] > c2) + next + if (y[i] < l1 || y[i] > l2) + next + if (npix[i] < nmin) + next + if (mag[i] < maglo || mag[i] > maghi) + next + if (ellip[i] < roundlo || ellip[i] > roundhi) + next + if (! IS_INDEFR(sharps[i]) && (sharps[i] < sharplo || + sharps[i] > sharphi)) + next + + # Add object to the list. + nstars = nstars + 1 + cols[nstars] = cols[i] + x[nstars] = x[i] + y[nstars] = y[i] + mag[nstars] = mag[i] + npix[nstars] = npix[i] + size[nstars] = size[i] + ellip[nstars] = ellip[i] + theta[nstars] = theta[i] + sharps[nstars] = sharps[i] + } + + return (nstars) +end + + +# SF_WRITE -- Write the results to the output file. + +procedure sf_write (fd, cols, x, y, mag, npix, size, ellip, theta, sharp, + nstars, ct, fmtstr, stid) + +int fd #I the output file descriptor +int cols[ARB] #I column numbers +real x[ARB] #I xcoords +real y[ARB] #I y coords +real mag[ARB] #I magnitudes +int npix[ARB] #I number of pixels +real size[ARB] #I object sizes +real ellip[ARB] #I ellipticities +real theta[ARB] #I position angles +real sharp[ARB] #I sharpnesses +int nstars #I number of detected stars in the line +pointer ct #I coordinate transformation +char fmtstr[ARB] #I the output format string +int stid #I output file sequence number + +double lx, ly, wx, wy +int i + +begin + if (fd == NULL) + return + + do i = 1, nstars { + call fprintf (fd, fmtstr) + call pargr (x[i]) + call pargr (y[i]) + if (ct != NULL) { + lx = x[i] + ly = y[i] + call mw_c2trand (ct, lx, ly, wx, wy) + call pargd (wx) + call pargd (wy) + } + call pargr (mag[i]) + call pargi (npix[i]) + call pargr (size[i]) + call pargr (ellip[i]) + call pargr (theta[i]) + call pargr (sharp[i]) + call pargi (stid + i - 1) + } +end diff --git a/pkg/images/imcoords/src/sftools.x b/pkg/images/imcoords/src/sftools.x new file mode 100644 index 00000000..02bec379 --- /dev/null +++ b/pkg/images/imcoords/src/sftools.x @@ -0,0 +1,68 @@ +include <mach.h> +include "starfind.h" + +# SF_GPARS-- Read in the star finding parameters from the datapars file. + +procedure sf_gpars (sf) + +pointer sf #I pointer to the star finding structure + +int clgeti() +real clgetr() + +begin + # Initialize the data structure. + call sf_init (sf) + + # Fetch the star finding parameters. + SF_HWHMPSF(sf) = clgetr ("hwhmpsf") + SF_FRADIUS(sf) = clgetr ("fradius") + SF_THRESHOLD(sf) = clgetr ("threshold") + SF_DATAMIN(sf) = clgetr ("datamin") + SF_DATAMAX(sf) = clgetr ("datamax") + SF_SEPMIN(sf) = clgetr ("sepmin") + SF_NPIXMIN(sf) = clgeti ("npixmin") + SF_MAGLO(sf) = clgetr ("maglo") + SF_MAGHI(sf) = clgetr ("maghi") + SF_ROUNDLO(sf) = clgetr ("roundlo") + SF_ROUNDHI(sf) = clgetr ("roundhi") + SF_SHARPLO(sf) = clgetr ("sharplo") + SF_SHARPHI(sf) = clgetr ("sharphi") +end + + +# SF_INIT -- Initialize the STARFIND task data structure and set the +# star finding parameters to their default values. + +procedure sf_init (sf) + +pointer sf #U pointer to the star finding structure + +begin + call calloc (sf, LEN_STARFIND, TY_STRUCT) + + SF_HWHMPSF(sf) = DEF_HWHMPSF + SF_FRADIUS(sf) = DEF_FRADIUS + SF_THRESHOLD(sf) = DEF_THRESHOLD + SF_DATAMIN(sf) = DEF_DATAMIN + SF_DATAMAX(sf) = DEF_DATAMAX + SF_SHARPLO(sf) = DEF_SHARPLO + SF_SHARPHI(sf) = DEF_SHARPHI + SF_ROUNDLO(sf) = DEF_ROUNDLO + SF_ROUNDHI(sf) = DEF_ROUNDHI + SF_MAGLO(sf) = DEF_MAGLO + SF_MAGHI(sf) = DEF_MAGHI + SF_SEPMIN(sf) = DEF_SEPMIN + SF_NPIXMIN(sf) = DEF_NPIXMIN +end + + +# SF_FREE -- Free the STARFIND task data structure. + +procedure sf_free (sf) + +pointer sf #U pointer to the star finding structure + +begin + call mfree (sf, TY_STRUCT) +end diff --git a/pkg/images/imcoords/src/skyctran.x b/pkg/images/imcoords/src/skyctran.x new file mode 100644 index 00000000..22d182e6 --- /dev/null +++ b/pkg/images/imcoords/src/skyctran.x @@ -0,0 +1,2057 @@ +include <fset.h> +include <ctype.h> +include <math.h> +include <pkg/skywcs.h> + +define HELPFILE1 "imcoords$src/skycur.key" +define HELPFILE2 "imcoords$src/ttycur.key" + +define CURCMDS "|show|isystem|osystem||ounits|oformats|" +define TYPECMDS "|show|isystem|osystem|iunits|ounits|oformats|" + +define CCMD_SHOW 1 +define CCMD_ISYSTEM 2 +define CCMD_OSYSTEM 3 +define CCMD_IUNITS 4 +define CCMD_OUNITS 5 +define CCMD_OFORMATS 6 + + +# SK_TTYTRAN -- Transform the typed coordinate list. + +procedure sk_ttytran (infd, outfd, mwin, mwout, cooin, cooout, ilngunits, + ilatunits, olngunits, olatunits, olngformat, olatformat) + +int infd #I the input file descriptor +int outfd #I the input file descriptor +pointer mwin #I the input image wcs +pointer mwout #I the output image wcs +pointer cooin #I the input coordinate descriptor +pointer cooout #I the output coordinate descriptor +int ilngunits #I the input ra/longitude units +int ilatunits #I the input dec/latitude units +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +char olngformat[ARB] #I the output ra/longitude format +char olatformat[ARB] #I the output dec/latitude format + +double ilng, ilat, pilng, pilat, px, rv, tlng, tlat, olng, olat +int newsystem, newformat, newobject, tilngunits, tilatunits, tolngunits +int tolatunits, ip, key +pointer ctin, ctout, sp, cmd, fmtstr, tolngformat, tolatformat, str1, str2 +double sl_da1p() +int scan(), nscan(), sk_stati(), ctod() +pointer sk_ictran(), sk_octran() +errchk sk_ictran(), sk_octran() + +begin + # Initialize. + newsystem = YES + newformat = YES + newobject = NO + ctin = NULL + ctout = NULL + + # Get some working space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (tolngformat, SZ_FNAME, TY_CHAR) + call salloc (tolatformat, SZ_FNAME, TY_CHAR) + call salloc (str1, SZ_FNAME, TY_CHAR) + call salloc (str2, SZ_FNAME, TY_CHAR) + + # Loop over the input. + while (scan() != EOF) { + call gargstr (Memc[cmd], SZ_LINE) + key = Memc[cmd] + switch (key) { + + case '?': + call pagefile (HELPFILE2, "[space=cmhelp,q=quit,?=help]") + + case 'q': + break + + case ':': + call sk_ccolon (infd, outfd, cooin, cooout, mwin, mwout, + ilngunits, ilatunits, olngunits, olatunits, olngformat, + olatformat, Memc[cmd+1], TYPECMDS, newsystem, newformat) + + default: + newobject = YES + } + + if (newobject == NO) + next + + # Decode the input coordinates. + call sscan (Memc[cmd]) + call gargwrd (Memc[str1], SZ_FNAME) + call gargwrd (Memc[str2], SZ_FNAME) + if (nscan() < 2) + next + ip = 1 + if (ctod (Memc[str1], ip, ilng) <= 0) + next + ip = 1 + if (ctod (Memc[str2], ip, ilat) <= 0) + next + call gargwrd (Memc[str1], SZ_FNAME) + call gargwrd (Memc[str2], SZ_FNAME) + + + # Decode the proper motions. + if (nscan() < 4) { + pilng = INDEFD + pilat = INDEFD + } else { + ip = 1 + if (ctod (Memc[str1], ip, pilng) <= 0) + next + ip = 1 + if (ctod (Memc[str2], ip, pilat) <= 0) + next + if (IS_INDEFD(pilng) || IS_INDEFD(pilat)) { + pilng = INDEFD + pilat = INDEFD + } + } + + # Decode the parallax and radial velocity + call gargwrd (Memc[str1], SZ_FNAME) + call gargwrd (Memc[str2], SZ_FNAME) + if (nscan() < 6) { + px = 0.0d0 + rv = 0.0d0 + } else { + ip = 1 + if (ctod (Memc[str1], ip, px) <= 0) + next + ip = 1 + if (ctod (Memc[str2], ip, rv) <= 0) + next + if (IS_INDEFD(px)) + px = 0.0d0 + if (IS_INDEFD(rv)) + rv = 0.0d0 + } + + # Compile the mwcs transformation. + if (newsystem == YES) { + if (ctin != NULL) + call mw_ctfree (cooin) + if (ctout != NULL) + call mw_ctfree (cooout) + iferr { + ctin = sk_ictran (cooin, mwin) + ctout = sk_octran (cooout, mwout) + } then { + ctin = NULL + ctout = NULL + } + newsystem = NO + } + + # Set the input and output coordinate units and the output format. + if (newformat == YES) { + if (ilngunits <= 0) + tilngunits = sk_stati (cooin, S_NLNGUNITS) + else + tilngunits = ilngunits + if (ilatunits <= 0) + tilatunits = sk_stati (cooin, S_NLATUNITS) + else + tilatunits = ilatunits + if (olngunits <= 0) + tolngunits = sk_stati (cooout, S_NLNGUNITS) + else + tolngunits = olngunits + if (olatunits <= 0) + tolatunits = sk_stati (cooout, S_NLATUNITS) + else + tolatunits = olatunits + call sk_oformats (cooin, cooout, olngformat, olatformat, + tolngunits, tolatunits, Memc[tolngformat], + Memc[tolatformat], SZ_FNAME) + call sk_iunits (cooin, mwin, tilngunits, tilatunits, + tilngunits, tilatunits) + call sk_ounits (cooout, mwout, tolngunits, tolatunits, + tolngunits, tolatunits) + call sprintf (Memc[fmtstr], SZ_LINE, "%%s %s %s\n") + call pargstr (Memc[tolngformat]) + call pargstr (Memc[tolatformat]) + newformat = NO + } + + # Perform the coordinate transformation. + if (sk_stati(cooin, S_STATUS) == ERR || sk_stati (cooout, + S_STATUS) == ERR) { + + olng = ilng + olat = ilat + + } else { + + # Compute the input coordinate to world coordinates in radians. + call sk_incc (cooin, mwin, ctin, tilngunits, tilatunits, ilng, + ilat, olng, olat) + + # Convert the proper motions to the correct units. + if (!IS_INDEFD(pilng) && !IS_INDEFD(pilat)) { + pilng = DEGTORAD(pilng * 15.0d0 / 3600.0d0) + pilat = DEGTORAD(pilat / 3600.0d0) + call sl_dtps (pilng / 15.0d0, pilat, 0.0d0, olat, pilng, + pilat) + pilng = sl_da1p (pilng) + pilat = pilat - olat + } else { + pilng = INDEFD + pilat = INDEFD + } + + # Perform the transformation. + call sk_lltran (cooin, cooout, olng, olat, pilng, pilat, px, + rv, tlng, tlat) + + # Convert the celestial coordinates in radians to the output + # coordinates. + call sk_outcc (cooout, mwout, ctout, tolngunits, tolatunits, + tlng, tlat, olng, olat) + } + + # Write the results. + call fprintf (outfd, Memc[fmtstr]) + call pargstr (Memc[cmd]) + call pargd (olng) + call pargd (olat) + if (outfd != STDOUT) { + call printf (Memc[fmtstr]) + call pargstr (Memc[cmd]) + call pargd (olng) + call pargd (olat) + } + + newobject = NO + } + + call sfree (sp) +end + + +define MAX_FIELDS 100 # Maximum number of fields in list +define TABSIZE 8 # Spacing of tab stops + +# SK_LISTRAN -- Transform the coordinate list. + +procedure sk_listran (infd, outfd, mwin, mwout, cooin, cooout, lngcolumn, + latcolumn, plngcolumn, platcolumn, pxcolumn, rvcolumn, ilngunits, + ilatunits, olngunits, olatunits, olngformat, olatformat, + min_sigdigits, transform) + +int infd #I the input file descriptor +int outfd #I the input file descriptor +pointer mwin #I the input image wcs +pointer mwout #I the output image wcs +pointer cooin #I the input coordinate descriptor +pointer cooout #I the output coordinate descriptor +int lngcolumn #I the input ra/longitude column +int latcolumn #I the input dec/latitude column +int plngcolumn #I the input ra/longitude pm column +int platcolumn #I the input dec/latitude pm column +int pxcolumn #I the input parallax column +int rvcolumn #I the input radial column +int ilngunits #I the input ra/longitude units +int ilatunits #I the input dec/latitude units +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +char olngformat[ARB] #I the output ra/longitude format +char olatformat[ARB] #I the output dec/latitude format +int min_sigdigits #I the minimum number of significant digits +bool transform #I transform the input file + +double ilng, ilat, tlng, tlat, olng, olat, pilng, pilat, px, rv +int nline, ip, max_fields, nfields, offset, nchars, nsdig_lng, nsdig_lat +int tilngunits, tilatunits, tolngunits, tolatunits +pointer sp, inbuf, linebuf, field_pos, outbuf, ctin, ctout +pointer tolngformat, tolatformat +double sl_da1p() +int sk_stati(), li_get_numd(), getline() +pointer sk_ictran(), sk_octran() +errchk sk_ictran(), sk_octran() + +begin + # Compile the input abd output transformations. + # coordinate units. + iferr { + ctin = sk_ictran (cooin, mwin) + ctout = sk_octran (cooout, mwout) + } then + return + + # Allocate some memory. + 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) + call salloc (tolngformat, SZ_FNAME, TY_CHAR) + call salloc (tolatformat, SZ_FNAME, TY_CHAR) + + # Set the default input and output units. + if (ilngunits <= 0) + tilngunits = sk_stati (cooin, S_NLNGUNITS) + else + tilngunits = ilngunits + if (ilatunits <= 0) + tilatunits = sk_stati (cooin, S_NLATUNITS) + else + tilatunits = ilatunits + if (olngunits <= 0) + tolngunits = sk_stati (cooout, S_NLNGUNITS) + else + tolngunits = olngunits + if (olatunits <= 0) + tolatunits = sk_stati (cooout, S_NLATUNITS) + else + tolatunits = olatunits + + # Set the output format. + call sk_oformats (cooin, cooout, olngformat, olatformat, + tolngunits, tolatunits, Memc[tolngformat], Memc[tolatformat], + SZ_FNAME) + + # Check the input and output units. + call sk_iunits (cooin, mwin, tilngunits, tilatunits, tilngunits, + tilatunits) + call sk_ounits (cooout, mwout, tolngunits, tolatunits, tolngunits, + tolatunits) + + # Loop over the input coordinates. + max_fields = MAX_FIELDS + for (nline = 1; getline (infd, Memc[inbuf]) != EOF; nline = nline + 1) { + + # Check for blank lines and comment lines. + 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 (lngcolumn > nfields || latcolumn > 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+lngcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], ilng, nsdig_lng) + 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+latcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], ilat, nsdig_lat) + 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 + } + + # Get the proper motions. + if (! IS_INDEFI(plngcolumn) && ! IS_INDEFI(platcolumn)) { + if (plngcolumn > nfields || platcolumn > 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+plngcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], pilng, nsdig_lng) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad pm 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+platcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], pilat, nsdig_lat) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad pm value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + if (IS_INDEFD(pilng) || IS_INDEFD(pilat)) { + pilng = INDEFD + pilat = INDEFD + } + } else { + pilng = INDEFD + pilat = INDEFD + } + + # Get the parallax value. + if (! IS_INDEFI(pxcolumn)) { + if (pxcolumn > 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+pxcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], px, nsdig_lat) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ( + "Bad parallax value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + if (IS_INDEFD(px)) + px = 0.0d0 + } else + px = 0.0d0 + + # Get the parallax value. + if (! IS_INDEFI(rvcolumn)) { + if (rvcolumn > 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+rvcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], rv, nsdig_lat) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ( + "Bad radial velocity value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + if (IS_INDEFD(rv)) + rv = 0.0d0 + } else + rv = 0.0d0 + + # Convert the input coordinates to world coordinates in radians. + call sk_incc (cooin, mwin, ctin, tilngunits, tilatunits, ilng, + ilat, olng, olat) + + # Convert the proper motions to the correct units. + if (IS_INDEFD(pilng) || IS_INDEFD(pilat)) { + pilng = INDEFD + pilat = INDEFD + } else { + pilng = DEGTORAD(pilng * 15.0d0 / 3600.0d0) + pilat = DEGTORAD(pilat / 3600.0d0) + call sl_dtps (pilng / 15.0d0, pilat, 0.0d0, olat, pilng, pilat) + pilng = sl_da1p (pilng) + pilat = pilat - olat + } + + # Perform the transformation. + call sk_lltran (cooin, cooout, olng, olat, pilng, pilat, + px, rv, tlng, tlat) + + # Convert the output celestial coordinates from radians to output + # coordinates. + call sk_outcc (cooout, mwout, ctout, tolngunits, tolatunits, + tlng, tlat, olng, olat) + + # Output the results. + if (transform) { + call li_pack_lined (Memc[linebuf], Memc[outbuf], SZ_LINE, + Memi[field_pos], nfields, lngcolumn, latcolumn, olng, + olat, Memc[tolngformat], Memc[tolatformat], nsdig_lng, + nsdig_lat, min_sigdigits) + } else { + call li_append_lined (Memc[linebuf], Memc[outbuf], SZ_LINE, + olng, olat, Memc[tolngformat], Memc[tolatformat], + nsdig_lng, nsdig_lat, min_sigdigits) + } + call putline (outfd, Memc[outbuf]) + } + + call sfree (sp) +end + + +# SK_COPYTRAN -- Copy the input coordinate file to the output coordinate file. + +procedure sk_copytran (infd, outfd, lngcolumn, latcolumn, transform) + +int infd #I the input file descriptor +int outfd #I the output file descriptor +int lngcolumn #I the input ra/longitude column +int latcolumn #I the input dec/latitude column +bool transform #I tranform the input file + +double ilng, ilat +int ip, nline, max_fields, nfields, xoffset, yoffset, nchars +int nsdig_lng, nsdig_lat, xwidth, ywidth +pointer sp, inbuf, linebuf, outbuf, field_pos +int getline(), li_get_numd() + +begin + call smark (sp) + call salloc (inbuf, SZ_LINE, TY_CHAR) + call salloc (linebuf, SZ_LINE, TY_CHAR) + call salloc (outbuf, SZ_LINE, TY_CHAR) + call salloc (field_pos, MAX_FIELDS, TY_INT) + + if (transform) { + while (getline (infd, Memc[inbuf]) != EOF) + call putline (outfd, Memc[inbuf]) + } else { + max_fields = MAX_FIELDS + for (nline = 1; getline (infd, Memc[inbuf]) != EOF; + nline = nline + 1) { + + # Check for blank lines and comment lines. + 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 (lngcolumn > nfields || latcolumn > 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 + } + + xoffset = Memi[field_pos+lngcolumn-1] + nchars = li_get_numd (Memc[linebuf+xoffset-1], ilng, nsdig_lng) + 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 + } + xwidth = Memi[field_pos+lngcolumn] - Memi[field_pos+lngcolumn-1] + + yoffset = Memi[field_pos+latcolumn-1] + nchars = li_get_numd (Memc[linebuf+yoffset-1], ilat, nsdig_lat) + 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 + } + ywidth = Memi[field_pos+latcolumn] - Memi[field_pos+latcolumn-1] + + call li_cappend_line (Memc[linebuf], Memc[outbuf], SZ_LINE, + xoffset, yoffset, xwidth, ywidth) + call putline (outfd, Memc[outbuf]) + } + } + + call sfree (sp) +end + + +# SK_CURTRAN -- Transform the cursor coordinate list. + +procedure sk_curtran (outfd, mwin, mwout, cooin, cooout, olngunits, olatunits, + olngformat, olatformat, transform) + +int outfd #I the input file descriptor +pointer mwin #I the input image wcs +pointer mwout #I the output image wcs +pointer cooin #I the input coordinate descriptor +pointer cooout #I the output coordinate descriptor +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +char olngformat[ARB] #I the output ra/longitude format +char olatformat[ARB] #I the output dec/latitude format +bool transform #I transform the input file + +double ilng, ilat, tlng, tlat, olng, olat +int wcs, key, tolngunits, tolatunits, newsystem, newformat, newobject +int ijunk +pointer sp, cmd, fmtstr, ctin, ctout, tolngformat, tolatformat +real wx, wy +int clgcur(), sk_stati() +pointer sk_ictran(), sk_octran() +errchk sk_ictran(), sk_octran() + +begin + # Initialize. + newsystem = YES + newformat = YES + newobject = NO + ctin = NULL + ctout = NULL + + # Get some working space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (tolngformat, SZ_FNAME, TY_CHAR) + call salloc (tolatformat, SZ_FNAME, TY_CHAR) + + while (clgcur ("icommands", wx, wy, wcs, key, Memc[cmd], + SZ_LINE) != EOF) { + + newobject = NO + ilng = wx + ilat = wy + + switch (key) { + + case '?': + call pagefile (HELPFILE1, "[space=cmhelp,q=quit,?=help]") + + case 'q': + break + + case ':': + call sk_ccolon (NULL, outfd, cooin, cooout, mwin, mwout, + ijunk, ijunk, olngunits, olatunits, olngformat, + olatformat, Memc[cmd], CURCMDS, newsystem, newformat) + + case ' ': + newobject = YES + + default: + ; + } + + if (newobject == NO) + next + + # Compile the mwcs transformation. + if (newsystem == YES) { + if (ctin != NULL) + call mw_ctfree (ctin) + if (ctout != NULL) + call mw_ctfree (ctout) + iferr { + ctin = sk_ictran (cooin, mwin) + ctout = sk_octran (cooout, mwout) + } then { + ctin = NULL + ctout = NULL + } + newsystem = NO + } + + # Set the output coordinates units and format. + if (newformat == YES) { + if (olngunits <= 0) + tolngunits = sk_stati (cooout, S_NLNGUNITS) + else + tolngunits = olngunits + if (olatunits <= 0) + tolatunits = sk_stati (cooout, S_NLATUNITS) + else + tolatunits = olatunits + call sk_oformats (cooin, cooout, olngformat, olatformat, + tolngunits, tolatunits, Memc[tolngformat], + Memc[tolatformat], SZ_FNAME) + call sk_ounits (cooout, mwout, tolngunits, tolatunits, + tolngunits, tolatunits) + if (sk_stati(cooin, S_STATUS) == ERR || sk_stati(cooout, + S_STATUS) == ERR) { + if (transform) + call strcpy ("%10.3f %10.3f\n", Memc[fmtstr], SZ_LINE) + else + call strcpy ("%10.3f %10.3f %10.3f %10.3f\n", + Memc[fmtstr], SZ_LINE) + } else { + if (transform) { + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s\n") + call pargstr (Memc[tolngformat]) + call pargstr (Memc[tolatformat]) + } else { + call sprintf (Memc[fmtstr], SZ_LINE, + "%%10.3f %%10.3f %s %s\n") + call pargstr (Memc[tolngformat]) + call pargstr (Memc[tolatformat]) + } + } + newformat = NO + } + + # Compute the transformation. + if (sk_stati(cooin, S_STATUS) == ERR || sk_stati(cooout, + S_STATUS) == ERR) { + olng = ilng + olat = ilat + } else { + call sk_incc (cooin, mwin, ctin, SKY_DEGREES, SKY_DEGREES, + ilng, ilat, olng, olat) + call sk_lltran (cooin, cooout, olng, olat, INDEFD, INDEFD, + 0.0d0, 0.0d0, tlng, tlat) + call sk_outcc (cooout, mwout, ctout, tolngunits, + tolatunits, tlng, tlat, olng, olat) + } + + # Write out the results. + if (transform) { + call fprintf (outfd, Memc[fmtstr]) + call pargd (olng) + call pargd (olat) + } else { + call fprintf (outfd, Memc[fmtstr]) + call pargr (wx) + call pargr (wy) + call pargd (olng) + call pargd (olat) + } + + newobject = NO + + } + + call sfree (sp) +end + +# SKY_CCOLON -- Process image cursor colon commands. + +procedure sk_ccolon (infd, outfd, cooin, cooout, mwin, mwout, ilngunits, + ilatunits, olngunits, olatunits, olngformat, olatformat, cmdstr, + cmdlist, newsystem, newformat) + +int infd #I the input file descriptor +int outfd #I the output file descriptor +pointer cooin #U the input coordinate descriptor +pointer cooout #U the output coordinate descriptor +pointer mwin #U the input image wcs +pointer mwout #U the output image wcs +int ilngunits #U the input ra/longitude units +int ilatunits #U the input dec/latitude units +int olngunits #U the output ra/longitude units +int olatunits #U the output dec/latitude units +char olngformat[ARB] #U the output ra/longitude format +char olatformat[ARB] #U the output dec/latitude format +char cmdstr[ARB] #I the input command string +char cmdlist[ARB] #I the input command list +int newsystem #U new coordinate system ? +int newformat #U new coordinate format ? + +int ncmd, stat +pointer sp, cmd, str1, str2, str3, str4, tmw, tcoo +int sk_stati(), strdic(), sk_decwcs() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (str1, SZ_FNAME, TY_CHAR) + call salloc (str2, SZ_FNAME, TY_CHAR) + call salloc (str3, SZ_FNAME, TY_CHAR) + call salloc (str4, SZ_FNAME, 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, cmdlist) + call gargstr (Memc[cmd], SZ_LINE) + switch (ncmd) { + + case CCMD_SHOW: + call fprintf (outfd, "\n") + if (sk_stati (cooin, S_STATUS) == ERR) + call fprintf (outfd, + "# Error decoding the input coordinate system\n") + call sk_stats (cooin, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiwrite (outfd, "Insystem", Memc[str1], mwin, + cooin) + if (infd == NULL) + call sk_wiformats (cooin, ilngunits, ilatunits, "%10.3f", + "%10.3f", Memc[str1], Memc[str2], Memc[str3], Memc[str4], + SZ_FNAME) + else + call sk_wiformats (cooin, ilngunits, ilatunits, "INDEF", + "INDEF", Memc[str1], Memc[str2], Memc[str3], Memc[str4], + SZ_FNAME) + call fprintf (outfd, "# Units: %s %s Format: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call pargstr (Memc[str3]) + call pargstr (Memc[str4]) + if (sk_stati(cooout, S_STATUS) == ERR) + call fprintf (outfd, + "# Error decoding the output coordinate system\n") + call sk_stats (cooout, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiwrite (outfd, "Outsystem", Memc[str1], mwout, + cooout) + call sk_woformats (cooin, cooout, olngunits, olatunits, + olngformat, olatformat, Memc[str1], Memc[str2], Memc[str3], + Memc[str4], SZ_FNAME) + call fprintf (outfd, "# Units: %s %s Format: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call pargstr (Memc[str3]) + call pargstr (Memc[str4]) + call fprintf (outfd, "\n") + + if (outfd != STDOUT) { + call printf ("\n") + if (sk_stati (cooin, S_STATUS) == ERR) + call printf ( + "Error decoding the input coordinate system\n") + call sk_stats (cooin, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiprint ("Insystem", Memc[str1], mwin, cooin) + if (infd == NULL) + call sk_wiformats (cooin, ilngunits, ilatunits, "%10.3f", + "%10.3f", Memc[str1], Memc[str2], Memc[str3], + Memc[str4], SZ_FNAME) + else + call sk_wiformats (cooin, ilngunits, ilatunits, "INDEF", + "INDEF", Memc[str1], Memc[str2], Memc[str3], Memc[str4], + SZ_FNAME) + call printf ("# Units: %s %s Format: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call pargstr (Memc[str3]) + call pargstr (Memc[str4]) + if (sk_stati(cooout, S_STATUS) == ERR) + call printf ( + "Error decoding the output coordinate system\n") + call sk_stats (cooout, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiprint ("Outsystem", Memc[str1], mwout, cooout) + call sk_woformats (cooin, cooout, olngunits, olatunits, + olngformat, olatformat, Memc[str1], Memc[str2], Memc[str3], + Memc[str4], SZ_FNAME) + call printf (" Units: %s %s Format: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call pargstr (Memc[str3]) + call pargstr (Memc[str4]) + call printf ("\n") + } + + case CCMD_ISYSTEM: + stat = sk_decwcs (Memc[cmd], tmw, tcoo, NULL) + if (Memc[cmd] == EOS || stat == ERR || (infd == NULL && + tmw == NULL)) { + if (tmw != NULL) + call mw_close (tmw) + call sk_close (tcoo) + call fprintf (outfd, "\n") + if (sk_stati(cooin, S_STATUS) == ERR) + call fprintf (outfd, + "# Error decoding the input coordinate system\n") + call sk_stats (cooin, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiwrite (outfd, "Insystem", Memc[str1], mwin, cooin) + call fprintf (outfd, "\n") + if (outfd != STDOUT) { + call printf ("\n") + if (sk_stati(cooin, S_STATUS) == ERR) + call printf ( + "# Error decoding the input coordinate system\n") + call sk_stats (cooin, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiprint ("Insystem", Memc[str1], mwin, cooin) + call printf ("\n") + } + } else { + if (mwin != NULL) + call mw_close (mwin) + call sk_close (cooin) + mwin = tmw + cooin = tcoo + if (infd == NULL) + call sk_seti (cooin, S_PIXTYPE, PIXTYPE_TV) + newsystem = YES + newformat = YES + } + + case CCMD_OSYSTEM: + stat = sk_decwcs (Memc[cmd], tmw, tcoo, NULL) + if (Memc[cmd] == EOS || stat == ERR) { + if (tmw != NULL) + call mw_close (tmw) + call sk_close (tcoo) + call fprintf (outfd, "\n") + if (sk_stati(cooout, S_STATUS) == ERR) + call fprintf (outfd, + "# Error decoding the output coordinate system\n") + call sk_stats (cooout, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiwrite (outfd, "Outsystem", Memc[str1], mwout, cooout) + call fprintf (outfd, "\n") + if (outfd != STDOUT) { + call printf ("\n") + if (sk_stati(cooout, S_STATUS) == ERR) + call printf ( + "# Error decoding the output coordinate system\n") + call sk_stats (cooout, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiprint ("Outsystem", Memc[str1], mwout, cooout) + call printf ("\n") + } + } else { + if (mwout != NULL) + call mw_close (mwout) + call sk_close (cooout) + mwout = tmw + cooout = tcoo + newsystem = YES + newformat = YES + } + + case CCMD_IUNITS: + call sscan (Memc[cmd]) + call gargwrd (Memc[str1], SZ_FNAME) + call gargwrd (Memc[str2], SZ_FNAME) + if (Memc[cmd] == EOS) { + call sk_wiformats (cooin, ilngunits, ilatunits, "", "", + Memc[str1], Memc[str2], Memc[str3], Memc[str4], SZ_FNAME) + call fprintf (outfd, "\n") + call fprintf (outfd, "# Units: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call fprintf (outfd, "\n") + if (outfd != STDOUT) { + call printf ("\n") + call printf ("Units: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call printf ("\n") + } + } else { + ilngunits = strdic (Memc[str1], Memc[str1], SZ_FNAME, + SKY_LNG_UNITLIST) + ilatunits = strdic (Memc[str2], Memc[str2], SZ_FNAME, + SKY_LAT_UNITLIST) + newformat = YES + } + + case CCMD_OUNITS: + call sscan (Memc[cmd]) + call gargwrd (Memc[str1], SZ_FNAME) + call gargwrd (Memc[str2], SZ_FNAME) + if (Memc[cmd] == EOS) { + call sk_woformats (cooin, cooout, olngunits, olatunits, + olngformat, olatformat, Memc[str1], Memc[str2], Memc[str3], + Memc[str4], SZ_FNAME) + call fprintf (outfd, "\n") + call fprintf (outfd, "# Units: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call fprintf (outfd, "\n") + if (outfd != STDOUT) { + call printf ("\n") + call printf ("Units: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call printf ("\n") + } + } else { + olngunits = strdic (Memc[str1], Memc[str1], SZ_FNAME, + SKY_LNG_UNITLIST) + olatunits = strdic (Memc[str2], Memc[str2], SZ_FNAME, + SKY_LAT_UNITLIST) + newformat = YES + } + + case CCMD_OFORMATS: + call sscan (Memc[cmd]) + call gargwrd (Memc[str1], SZ_FNAME) + call gargwrd (Memc[str2], SZ_FNAME) + if (Memc[cmd] == EOS) { + call sk_woformats (cooin, cooout, olngunits, olatunits, + olngformat, olatformat, Memc[str1], Memc[str2], Memc[str3], + Memc[str4], SZ_FNAME) + call fprintf (outfd, "\n") + call fprintf (outfd, "# Formats: %s %s\n") + call pargstr (Memc[str3]) + call pargstr (Memc[str4]) + call fprintf (outfd, "\n") + if (outfd != STDOUT) { + call printf ("\n") + call printf ("Formats: %s %s\n") + call pargstr (Memc[str3]) + call pargstr (Memc[str4]) + call printf ("\n") + } + } else { + call strcpy (Memc[str1], olngformat, SZ_FNAME) + call strcpy (Memc[str2], olatformat, SZ_FNAME) + newformat = YES + } + + default: + ; + } + + call sfree (sp) +end + + +# SK_GRTRAN -- Transform the grid coordinate list. + +procedure sk_grtran (outfd, mwin, mwout, cooin, cooout, ilngmin, ilngmax, + nilng, ilatmin, ilatmax, nilat, ilngunits, ilatunits, olngunits, + olatunits, ilngformat, ilatformat, olngformat, olatformat, transform) + +int outfd #I the input file descriptor +pointer mwin #I the input image wcs +pointer mwout #I the output image wcs +pointer cooin #I the input coordinate descriptor +pointer cooout #I the output coordinate descriptor +double ilngmin #I the x/ra/longitude minimum +double ilngmax #I the x/ra/longitude maximum +int nilng #I the number of x/ra/longitude grid points +double ilatmin #I the y/dec/longitude minimum +double ilatmax #I the y/dec/longitude maximum +int nilat #I the number of y/dec/latitude grid points +int ilngunits #I the input ra/longitude units +int ilatunits #I the input dec/latitude units +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +char ilngformat[ARB] #I the input ra/longitude format +char ilatformat[ARB] #I the input dec/latitude format +char olngformat[ARB] #I the output ra/longitude format +char olatformat[ARB] #I the output dec/latitude format +bool transform #I transform the input file + +double ilng1, ilng2, ilat1, ilat2, ilngstep, ilatstep, ilng, ilat, olng, olat +double tlng, tlat +int i, j, tilngunits, tilatunits, tolngunits, tolatunits +pointer sp, fmtstr, ctin, ctout, tilngformat, tilatformat +pointer tolngformat, tolatformat +int sk_stati() +pointer sk_ictran(), sk_octran() +errchk sk_ictran(), sk_octran() + +begin + # Compile the input and output transformations. + iferr { + ctin = sk_ictran (cooin, mwin) + ctout = sk_octran (cooout, mwout) + } then + return + + # Get some working space. + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (tilngformat, SZ_FNAME, TY_CHAR) + call salloc (tilatformat, SZ_FNAME, TY_CHAR) + call salloc (tolngformat, SZ_FNAME, TY_CHAR) + call salloc (tolatformat, SZ_FNAME, TY_CHAR) + + # Set the input and output units. + if (ilngunits <= 0) + tilngunits = sk_stati (cooin, S_NLNGUNITS) + else + tilngunits = ilngunits + if (ilatunits <= 0) + tilatunits = sk_stati (cooin, S_NLATUNITS) + else + tilatunits = ilatunits + if (olngunits <= 0) + tolngunits = sk_stati (cooout, S_NLNGUNITS) + else + tolngunits = olngunits + if (olatunits <= 0) + tolatunits = sk_stati (cooout, S_NLATUNITS) + else + tolatunits = olatunits + + # Set the input and output formats. + call sk_iformats (cooin, ilngformat, ilatformat, + tilngunits, tilatunits, Memc[tilngformat], Memc[tilatformat], + SZ_FNAME) + call sk_oformats (cooin, cooout, olngformat, olatformat, + tolngunits, tolatunits, Memc[tolngformat], Memc[tolatformat], + SZ_FNAME) + + # Check the input and output units. + call sk_iunits (cooin, mwin, tilngunits, tilatunits, tilngunits, + tilatunits) + call sk_ounits (cooout, mwout, tolngunits, tolatunits, tolngunits, + tolatunits) + + # Create the format string. + if (transform) { + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s\n") + call pargstr (Memc[tolngformat]) + call pargstr (Memc[tolatformat]) + } else { + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s\n") + call pargstr (Memc[tilngformat]) + call pargstr (Memc[tilatformat]) + call pargstr (Memc[tolngformat]) + call pargstr (Memc[tolatformat]) + } + + # Compute the grid parameters in x/ra/longitude. + if (IS_INDEFD(ilngmin)) { + switch (sk_stati(cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + ilng1 = 1.0d0 + default: + switch (sk_stati(cooin, S_CTYPE)) { + case 0: + ilng1 = 1.0d0 + default: + switch (tilngunits) { + case SKY_HOURS: + ilng1 = 0.0d0 + case SKY_DEGREES: + ilng1 = 0.0d0 + case SKY_RADIANS: + ilng1 = 0.0d0 + } + } + } + } else + ilng1 = ilngmin + + if (IS_INDEFD(ilngmax)) { + switch (sk_stati(cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + ilng2 = sk_stati (cooin, S_NLNGAX) + default: + switch (sk_stati (cooin, S_CTYPE)) { + case 0: + ilng2 = sk_stati(cooin, S_NLNGAX) + default: + switch (tilngunits) { + case SKY_HOURS: + ilng2 = 24.0d0 + case SKY_DEGREES: + ilng2 = 360.0d0 + case SKY_RADIANS: + ilng2 = TWOPI + } + } + } + } else + ilng2 = ilngmax + if (nilng == 1) + ilngstep = 0.0d0 + else + ilngstep = (ilng2 - ilng1) / (nilng - 1) + + # Compute the grid parameters in y/dec/latitude. + if (IS_INDEFD(ilatmin)) { + switch (sk_stati (cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + ilat1 = 1.0d0 + default: + switch (sk_stati (cooin, S_CTYPE)) { + case 0: + ilat1 = 1.0d0 + default: + switch (tilatunits) { + case SKY_HOURS: + ilat1 = 0.0d0 + case SKY_DEGREES: + ilat1 = -90.0d0 + case SKY_RADIANS: + ilat1 = -HALFPI + } + } + } + } else + ilat1 = ilatmin + + if (IS_INDEFD(ilatmax)) { + switch (sk_stati (cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + ilat2 = sk_stati (cooin, S_NLATAX) + default: + switch (sk_stati (cooin, S_CTYPE)) { + case 0: + ilat2 = sk_stati(cooin, S_NLATAX) + default: + switch (tilatunits) { + case SKY_HOURS: + ilat2 = 24.0d0 + case SKY_DEGREES: + ilat2 = 90.0d0 + case SKY_RADIANS: + ilat2 = HALFPI + } + } + } + } else + ilat2 = ilatmax + if (nilat == 1) + ilatstep = 0.0d0 + else + ilatstep = (ilat2 - ilat1) / (nilat - 1) + + # Compute the grid of points. + do j = 1, nilat { + + ilat = ilat1 + (j - 1) * ilatstep + + do i = 1, nilng { + + ilng = ilng1 + (i - 1) * ilngstep + + # Convert the input coordinates to world coordinates in + # radians. + call sk_incc (cooin, mwin, ctin, tilngunits, tilatunits, + ilng, ilat, olng, olat) + + # Perform the transformation. + call sk_lltran (cooin, cooout, olng, olat, INDEFD, + INDEFD, 0.0d0, 0.0d0, tlng, tlat) + + # Convert the celestial coordinates to output coordinates. + call sk_outcc (cooout, mwout, ctout, tolngunits, tolatunits, + tlng, tlat, olng, olat) + + # Write out the results + if (transform) { + call fprintf (outfd, Memc[fmtstr]) + call pargd (olng) + call pargd (olat) + } else { + call fprintf (outfd, Memc[fmtstr]) + call pargd (ilng) + call pargd (ilat) + call pargd (olng) + call pargd (olat) + } + } + } + + call sfree (sp) +end + + +# SK_GRCOPY -- Copy the input logical pixel grid to the output logical +# pixel grid. + +procedure sk_grcopy (outfd, cooin, cooout, ilngmin, ilngmax, nilng, ilatmin, + ilatmax, nilat, ilngunits, ilatunits, olngunits, olatunits, ilngformat, + ilatformat, olngformat, olatformat, transform) + +int outfd #I the output file descriptor +pointer cooin #I the pointer to input coordinate structure +pointer cooout #I the pointer to output coordinate structure +double ilngmin #I the x/ra/longitude minimum +double ilngmax #I the x/ra/longitude maximum +int nilng #I the number of x/ra/longitude grid points +double ilatmin #I the y/dec/longitude minimum +double ilatmax #I the y/dec/longitude maximum +int nilat #I the number of y/dec/latitude grid points +int ilngunits #I the input x/ra/longitude units +int ilatunits #I the input y/dec/latitude/units +int olngunits #I the output x/ra/longitude units +int olatunits #I the output y/dec/latitude/units +char ilngformat[ARB] #I the input x format string +char ilatformat[ARB] #I the intput y format string +char olngformat[ARB] #I the output x format string +char olatformat[ARB] #I the output y format string +bool transform #I transform the input file + +double x1, x2, x, y1, y2, y, xstep, ystep +int i, j, tilngunits, tilatunits, tolngunits, tolatunits +pointer sp, tilngformat, tilatformat, tolngformat, tolatformat, fmtstr +int sk_stati() + +begin + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (tilngformat, SZ_FNAME, TY_CHAR) + call salloc (tilatformat, SZ_FNAME, TY_CHAR) + call salloc (tolngformat, SZ_FNAME, TY_CHAR) + call salloc (tolatformat, SZ_FNAME, TY_CHAR) + + # Set the input units. + if (ilngunits <= 0) + tilngunits = sk_stati (cooin, S_NLNGUNITS) + else + tilngunits = ilngunits + if (ilatunits <= 0) + tilatunits = sk_stati (cooin, S_NLATUNITS) + else + tilatunits = ilatunits + if (olngunits <= 0) + tolngunits = sk_stati (cooout, S_NLNGUNITS) + else + tolngunits = olngunits + if (olatunits <= 0) + tolatunits = sk_stati (cooout, S_NLATUNITS) + else + tolatunits = olatunits + + # Set the input and output formats. + call sk_iformats (cooin, ilngformat, ilatformat, + tilngunits, tilatunits, Memc[tilngformat], Memc[tilatformat], + SZ_FNAME) + call sk_oformats (cooin, cooout, olngformat, olatformat, + tolngunits, tolatunits, Memc[tolngformat], Memc[tolatformat], + SZ_FNAME) + + # Create the format string. + if (transform) { + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s\n") + call pargstr (Memc[tolngformat]) + call pargstr (Memc[tolatformat]) + } else { + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s\n") + call pargstr (Memc[tilngformat]) + call pargstr (Memc[tilatformat]) + call pargstr (Memc[tolngformat]) + call pargstr (Memc[tolatformat]) + } + + # Compute the grid parameters in x/ra/longitude. + if (IS_INDEFD(ilngmin)) { + switch (sk_stati (cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + x1 = 1.0d0 + default: + switch (sk_stati (cooin, S_CTYPE)) { + case 0: + x1 = 1.0d0 + default: + switch (tilngunits) { + case SKY_HOURS: + x1 = 0.0d0 + case SKY_DEGREES: + x1 = 0.0d0 + case SKY_RADIANS: + x1 = 0.0d0 + } + } + } + } else + x1 = ilngmin + if (IS_INDEFD(ilngmax)) { + switch (sk_stati(cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + x2 = sk_stati(cooin, S_NLNGAX) + default: + switch (sk_stati (cooin, S_CTYPE)) { + case 0: + x2 = sk_stati (cooin, S_NLNGAX) + default: + switch (tilngunits) { + case SKY_HOURS: + x2 = 24.0d0 + case SKY_DEGREES: + x2 = 360.0d0 + case SKY_RADIANS: + x2 = TWOPI + } + } + } + } else + x2 = ilngmax + if (nilng == 1) + xstep = 0.0d0 + else + xstep = (x2 - x1) / (nilng - 1) + + # Compute the grid parameters in y/dec/latitude. + if (IS_INDEFD(ilatmin)) { + switch (sk_stati (cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + y1 = 1.0d0 + default: + switch (sk_stati(cooin, S_CTYPE)) { + case 0: + y1 = 1.0d0 + default: + switch (tilatunits) { + case SKY_HOURS: + y1 = 0.0d0 + case SKY_DEGREES: + y1 = -90.0d0 + case SKY_RADIANS: + y1 = -HALFPI + } + } + } + } else + y1 = ilatmin + + if (IS_INDEFD(ilatmax)) { + switch (sk_stati (cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + y2 = sk_stati (cooin, S_NLATAX) + default: + switch (sk_stati(cooin, S_CTYPE)) { + case 0: + y2 = sk_stati (cooin, S_NLATAX) + default: + switch (tilatunits) { + case SKY_HOURS: + y2 = 24.0d0 + case SKY_DEGREES: + y2 = 90.0d0 + case SKY_RADIANS: + y2 = HALFPI + } + } + } + } else + y2 = ilatmax + if (nilat == 1) + ystep = 0.0d0 + else + ystep = (y2 - y1) / (nilat - 1) + + # Compute the points. + y = y1 + do j = 1, nilat { + x = x1 + do i = 1, nilng { + if (transform) { + call fprintf (outfd, Memc[fmtstr]) + call pargd (x) + call pargd (y) + } else { + call fprintf (outfd, Memc[fmtstr]) + call pargd (x) + call pargd (y) + call pargd (x) + call pargd (y) + } + x = x + xstep + } + y = y + ystep + } + + call sfree (sp) +end + + +# SK_WIFORMATS -- Format the input units and format strings. + +procedure sk_wiformats (cooin, ilngunits, ilatunits, ilngformat, + ilatformat, ilngunitstr, ilatunitstr, oilngformat, oilatformat, maxch) + +pointer cooin #I the input coordinate structure +int ilngunits #I the output ra/longitude units +int ilatunits #I the output dec/latitude units +char ilngformat[ARB] #I the output ra/longitude format string +char ilatformat[ARB] #I the output dec/latitude format string +char ilngunitstr[ARB] #O the output output ra/longitude format string +char ilatunitstr[ARB] #O the output output dec/latitude format string +char oilngformat[ARB] #O the output output ra/longitude format string +char oilatformat[ARB] #O the output output dec/latitude format string +int maxch #I the maximum length of the format strings + +int tilngunits, tilatunits +int sk_stati() + +begin + # Determine the correct units. + if (ilngunits <= 0) + tilngunits = sk_stati (cooin, S_NLNGUNITS) + else + tilngunits = ilngunits + if (ilatunits <= 0) + tilatunits = sk_stati (cooin, S_NLATUNITS) + else + tilatunits = ilatunits + + # Format the units strings. + if (sk_stati(cooin, S_PIXTYPE) != PIXTYPE_WORLD) { + call strcpy ("pixels", ilngunitstr, maxch) + call strcpy ("pixels", ilatunitstr, maxch) + } else { + switch (tilngunits) { + case SKY_HOURS: + call strcpy ("hours", ilngunitstr, maxch) + case SKY_DEGREES: + call strcpy ("degrees", ilngunitstr, maxch) + case SKY_RADIANS: + call strcpy ("radians", ilngunitstr, maxch) + } + switch (tilatunits) { + case SKY_HOURS: + call strcpy ("hours", ilatunitstr, maxch) + case SKY_DEGREES: + call strcpy ("degrees", ilatunitstr, maxch) + case SKY_RADIANS: + call strcpy ("radians", ilatunitstr, maxch) + } + } + + # Format the format strings. + call sk_iformats (cooin, ilngformat, ilatformat, + tilngunits, tilatunits, oilngformat, oilatformat, + SZ_FNAME) +end + + +# SK_IFORMATS -- Set the input format strings. + +procedure sk_iformats (cooin, ilngformat, ilatformat, ilngunits, ilatunits, + oilngformat, oilatformat, maxch) + +pointer cooin #I the input coordinate structure +char ilngformat[ARB] #I the input ra/longitude format string +char ilatformat[ARB] #I the input dec/latitude format string +int ilngunits #I the input ra/longitude units +int ilatunits #I the input dec/latitude units +char oilngformat[ARB] #O the input ra/longitude format string +char oilatformat[ARB] #O the input dec/latitude format string +int maxch #I the maximum length of the format strings + +int sk_stati() + +begin + if (ilngformat[1] == EOS) { + if (sk_stati(cooin, S_STATUS) == ERR) + call strcpy ("%10.3f", oilngformat, maxch) + else { + switch (sk_stati(cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + call strcpy ("%10.3f", oilngformat, maxch) + default: + switch (ilngunits) { + case SKY_HOURS: + call strcpy ("%12.3h", oilngformat, maxch) + case SKY_DEGREES: + call strcpy ("%12.2h", oilngformat, maxch) + case SKY_RADIANS: + call strcpy ("%13.7g", oilngformat, maxch) + } + } + } + } else + call strcpy (ilngformat, oilngformat, maxch) + + if (ilatformat[1] == EOS) { + if (sk_stati (cooin, S_STATUS) == ERR) + call strcpy ("%10.3f", oilatformat, maxch) + else { + switch (sk_stati(cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + call strcpy ("%10.3f", oilatformat, maxch) + default: + switch (ilatunits) { + case SKY_HOURS: + call strcpy ("%12.3h", oilatformat, maxch) + case SKY_DEGREES: + call strcpy ("%12.2h", oilatformat, maxch) + case SKY_RADIANS: + call strcpy ("%13.7g", oilatformat, maxch) + } + } + } + } else + call strcpy (ilatformat, oilatformat, maxch) +end + + +# SK_WOFORMATS -- Format the units and format strings. + +procedure sk_woformats (cooin, cooout, olngunits, olatunits, olngformat, + olatformat, olngunitstr, olatunitstr, oolngformat, oolatformat, maxch) + +pointer cooin #I the input coordinate structure +pointer cooout #I the output coordinate structure +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +char olngformat[ARB] #I the output ra/longitude format string +char olatformat[ARB] #I the output dec/latitude format string +char olngunitstr[ARB] #O the output output ra/longitude format string +char olatunitstr[ARB] #O the output output dec/latitude format string +char oolngformat[ARB] #O the output output ra/longitude format string +char oolatformat[ARB] #O the output output dec/latitude format string +int maxch #I the maximum length of the format strings + +int tolngunits, tolatunits +int sk_stati() + +begin + # Determine the correct units. + if (olngunits <= 0) + tolngunits = sk_stati (cooout, S_NLNGUNITS) + else + tolngunits = olngunits + if (olatunits <= 0) + tolatunits = sk_stati (cooout, S_NLATUNITS) + else + tolatunits = olatunits + + # Format the units strings. + if (sk_stati(cooout, S_PIXTYPE) != PIXTYPE_WORLD) { + call strcpy ("pixels", olngunitstr, maxch) + call strcpy ("pixels", olatunitstr, maxch) + } else { + switch (tolngunits) { + case SKY_HOURS: + call strcpy ("hours", olngunitstr, maxch) + case SKY_DEGREES: + call strcpy ("degrees", olngunitstr, maxch) + case SKY_RADIANS: + call strcpy ("radians", olngunitstr, maxch) + } + switch (tolatunits) { + case SKY_HOURS: + call strcpy ("hours", olatunitstr, maxch) + case SKY_DEGREES: + call strcpy ("degrees", olatunitstr, maxch) + case SKY_RADIANS: + call strcpy ("radians", olatunitstr, maxch) + } + } + + # Format the format strings. + call sk_oformats (cooin, cooout, olngformat, olatformat, + tolngunits, tolatunits, oolngformat, oolatformat, + SZ_FNAME) +end + + +# SK_OFORMATS -- Set the output format strings. + +procedure sk_oformats (cooin, cooout, olngformat, olatformat, olngunits, + olatunits, oolngformat, oolatformat, maxch) + +pointer cooin #I the input coordinate structure +pointer cooout #I the output coordinate structure +char olngformat[ARB] #I the output ra/longitude format string +char olatformat[ARB] #I the output dec/latitude format string +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +char oolngformat[ARB] #O the output output ra/longitude format string +char oolatformat[ARB] #O the output output dec/latitude format string +int maxch #I the maximum length of the format strings + +int sptype +int sk_stati() + +begin + if (olngformat[1] == EOS) { + if (sk_stati(cooin, S_STATUS) == ERR) + call strcpy ("%10.3f", oolngformat, maxch) + else { + if (sk_stati(cooout, S_STATUS) == ERR) + sptype = sk_stati (cooin, S_PIXTYPE) + else + sptype = sk_stati (cooout, S_PIXTYPE) + switch (sptype) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + call strcpy ("%10.3f", oolngformat, maxch) + default: + switch (olngunits) { + case SKY_HOURS: + call strcpy ("%12.3h", oolngformat, maxch) + case SKY_DEGREES: + call strcpy ("%12.2h", oolngformat, maxch) + case SKY_RADIANS: + call strcpy ("%13.7g", oolngformat, maxch) + } + } + } + } else + call strcpy (olngformat, oolngformat, maxch) + + if (olatformat[1] == EOS) { + if (sk_stati (cooin, S_STATUS) == ERR) + call strcpy ("%10.3f", oolatformat, maxch) + else { + if (sk_stati(cooout, S_STATUS) == ERR) + sptype = sk_stati (cooin, S_PIXTYPE) + else + sptype = sk_stati (cooout, S_PIXTYPE) + switch (sptype) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + call strcpy ("%10.3f", oolatformat, maxch) + default: + switch (olatunits) { + case SKY_HOURS: + call strcpy ("%12.3h", oolatformat, maxch) + case SKY_DEGREES: + call strcpy ("%12.2h", oolatformat, maxch) + case SKY_RADIANS: + call strcpy ("%13.7g", oolatformat, maxch) + } + } + } + } else + call strcpy (olatformat, oolatformat, maxch) +end + + +# SK_ICTRAN -- Compile the input mwcs transformation. + +pointer procedure sk_ictran (cooin, mwin) + +pointer cooin #I the input coordinate descriptor +pointer mwin #I the input mwcs descriptor + +int axbits +pointer ctin +int sk_stati() +pointer mw_sctran() +errchk mw_sctran() + +begin + if (mwin != NULL) { + switch (sk_stati(cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + axbits = 2 ** (sk_stati(cooin, S_XLAX) - 1) + + 2 ** (sk_stati(cooin, S_YLAX) - 1) + iferr { + if (sk_stati(cooin, S_PIXTYPE) == PIXTYPE_PHYSICAL) + ctin = mw_sctran (mwin, "physical", "world", axbits) + else + ctin = mw_sctran (mwin, "logical", "world", axbits) + } then + call error (0, "Error compiling input mwcs transform") + default: + ctin = NULL + } + } else { + ctin = NULL + } + + return (ctin) +end + + +# SK_IUNITS -- Set the input celestial coordinate units. + +procedure sk_iunits (cooin, mwin, ilngunits, ilatunits, oilngunits, oilatunits) + +pointer cooin #I the input coordinate descriptor +pointer mwin #I the input mwcs descriptor +int ilngunits #I the input ra/longitude units +int ilatunits #I the input dec/latitude units +int oilngunits #O the output input ra/longitude units +int oilatunits #O the output input dec/latitude units + +int sk_stati() + +begin + if (mwin != NULL) { + switch (sk_stati(cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + oilngunits = SKY_DEGREES + oilatunits = SKY_DEGREES + default: + oilngunits = ilngunits + oilatunits = ilatunits + } + } else { + oilngunits = ilngunits + oilatunits = ilatunits + } +end + + +# SK_OCTRAN -- Compile the output mwcs transformation. + +pointer procedure sk_octran (cooout, mwout) + +pointer cooout #I the output coordinate descriptor +pointer mwout #I the output mwcs descriptor + +int axbits +pointer ctout +int sk_stati() +pointer mw_sctran() +errchk mw_sctran() + +begin + if (mwout != NULL) { + switch (sk_stati(cooout, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + axbits = 2 ** (sk_stati (cooout, S_XLAX) - 1) + + 2 ** (sk_stati (cooout, S_YLAX) - 1) + iferr { + if (sk_stati (cooout, S_PIXTYPE) == PIXTYPE_PHYSICAL) + ctout = mw_sctran (mwout, "world", "physical", axbits) + else + ctout = mw_sctran (mwout, "world", "logical", axbits) + } then + call error (0, "Error compiling output mwcs transform") + default: + ctout = NULL + } + } else { + ctout = NULL + } + + return (ctout) +end + + +# SK_OUNITS -- Compile the output mwcs transformation and set the output +# celestial coordinate units. + +procedure sk_ounits (cooout, mwout, olngunits, olatunits, oolngunits, + oolatunits) + +pointer cooout #I the output coordinate descriptor +pointer mwout #I the output mwcs descriptor +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +int oolngunits #O the output output ra/longitude units +int oolatunits #O the output output dec/latitude units + +int sk_stati() + +begin + if (mwout != NULL) { + switch (sk_stati(cooout, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + oolngunits = SKY_RADIANS + oolatunits = SKY_RADIANS + default: + oolngunits = olngunits + oolatunits = olatunits + } + } else { + oolngunits = olngunits + oolatunits = olatunits + } +end + + +# SK_INCC -- Transform the input coordinates to the correct celestial +# coordinates in radians. + +procedure sk_incc (cooin, mwin, ctin, ilngunits, ilatunits, ilng, ilat, + olng, olat) + +pointer cooin #I the input coordinate descriptor +pointer mwin #I the input mwcs descriptor +pointer ctin #I the mwcs transformation descriptor +int ilngunits #I the input ra/longitude units +int ilatunits #I the input dec/latitude units +double ilng #I the input ra/longitude coordinates +double ilat #I the input dec/latitude coordinates +double olng #O the output ra/longitude coordinates +double olat #O the output dec/latitude coordinates + +double tlng, tlat +double sk_statd() +int sk_stati() + +begin + # Convert the input image coordinates to world coordinates. + if (mwin != NULL) { + switch (sk_stati (cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_PHYSICAL: + if (ctin == NULL) { + olng = ilng + olat = ilat + } else if (sk_stati (cooin, S_PLNGAX) < sk_stati (cooin, + S_PLATAX)) { + call mw_c2trand (ctin, ilng, ilat, olng, olat) + } else { + call mw_c2trand (ctin, ilng, ilat, olat, olng) + } + case PIXTYPE_TV: + tlng = (ilng - sk_statd(cooin, S_VXOFF)) / + sk_statd (cooin, S_VXSTEP) + tlat = (ilat - sk_statd (cooin, S_VYOFF)) / + sk_statd (cooin, S_VYSTEP) + if (ctin == NULL) { + olng = tlng + olat = tlat + } else if (sk_stati (cooin, S_PLNGAX) < sk_stati (cooin, + S_PLATAX)) { + call mw_c2trand (ctin, tlng, tlat, olng, olat) + } else { + call mw_c2trand (ctin, tlng, tlat, olat, olng) + } + case PIXTYPE_WORLD: + olng = ilng + olat = ilat + } + } else { + olng = ilng + olat = ilat + } + + # Convert the input values to radians. + switch (ilngunits) { + case SKY_HOURS: + olng = DEGTORAD(15.0d0 * olng) + case SKY_DEGREES: + olng = DEGTORAD(olng) + case SKY_RADIANS: + ; + } + switch (ilatunits) { + case SKY_HOURS: + olat = DEGTORAD(15.0d0 * olat) + case SKY_DEGREES: + olat = DEGTORAD(olat) + case SKY_RADIANS: + ; + } +end + + +# SK_OUTCC -- Transform the output celestial coordinates to the correct +# output coordinate system. + +procedure sk_outcc (cooout, mwout, ctout, olngunits, olatunits, ilng, ilat, + olng, olat) + +pointer cooout #I the output coordinate descriptor +pointer mwout #I the output mwcs descriptor +pointer ctout #I the output mwcs transformation descriptor +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +double ilng #I the output ra/longitude coordinates +double ilat #I the output dec/latitude coordinates +double olng #O the output coordinates +double olat #O the output coordinates + +double tlng, tlat +double sk_statd() +int sk_stati() + +begin + # Convert the output image coordinates to image coordinates. + #if (mwout == NULL || (sk_stati(cooin, S_PIXTYPE) == PIXTYPE_WORLD && + # sk_stati (cooout, S_PIXTYPE) == PIXTYPE_WORLD)) { + if (mwout == NULL || ctout == NULL) { + switch (olngunits) { + case SKY_HOURS: + olng = RADTODEG(ilng / 15.0d0) + case SKY_DEGREES: + olng = RADTODEG(ilng) + case SKY_RADIANS: + ; + } + switch (olatunits) { + case SKY_HOURS: + olat = RADTODEG(ilat / 15.0d0) + case SKY_DEGREES: + olat = RADTODEG(ilat) + case SKY_RADIANS: + ; + } + } else { + switch (sk_stati (cooout, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_PHYSICAL: + tlng = RADTODEG(ilng) + tlat = RADTODEG(ilat) + if (ctout == NULL) { + olng = tlat + olat = tlng + } else if (sk_stati(cooout, S_PLNGAX) < sk_stati(cooout, + S_PLATAX)) { + call mw_c2trand (ctout, tlng, tlat, olng, olat) + } else { + call mw_c2trand (ctout, tlat, tlng, olng, olat) + } + case PIXTYPE_TV: + tlng = RADTODEG(ilng) + tlat = RADTODEG(ilat) + if (ctout == NULL) { + olng = tlat + olat = tlng + } else if (sk_stati(cooout, S_PLNGAX) < sk_stati(cooout, + S_PLATAX)) { + call mw_c2trand (ctout, tlng, tlat, olng, olat) + } else { + call mw_c2trand (ctout, tlat, tlng, olng, olat) + } + olng = olng * sk_statd(cooout, S_VXSTEP) + + sk_statd(cooout, S_VXOFF) + olat = olat * sk_statd (cooout, S_VYSTEP) + + sk_statd (cooout, S_VYOFF) + case PIXTYPE_WORLD: + if (sk_stati(cooout, S_PLNGAX) > sk_stati(cooout, + S_PLATAX)) { + olng = ilat + olat = ilng + switch (olngunits) { + case SKY_HOURS: + olat = RADTODEG(olat / 15.0d0) + case SKY_DEGREES: + olat = RADTODEG(olat) + case SKY_RADIANS: + ; + } + switch (olatunits) { + case SKY_HOURS: + olng = RADTODEG(olng / 15.0d0) + case SKY_DEGREES: + olng = RADTODEG(olng) + case SKY_RADIANS: + ; + } + } else { + switch (olngunits) { + case SKY_HOURS: + olng = RADTODEG(ilng / 15.0d0) + case SKY_DEGREES: + olng = RADTODEG(ilng) + case SKY_RADIANS: + ; + } + switch (olatunits) { + case SKY_HOURS: + olat = RADTODEG(ilat / 15.0d0) + case SKY_DEGREES: + olat = RADTODEG(ilat) + case SKY_RADIANS: + ; + } + } + } + } +end diff --git a/pkg/images/imcoords/src/skycur.key b/pkg/images/imcoords/src/skycur.key new file mode 100644 index 00000000..2aa61fe1 --- /dev/null +++ b/pkg/images/imcoords/src/skycur.key @@ -0,0 +1,38 @@ + INTERACTIVE KEYSTROKE COMMANDS + +? Print help +: Execute colon command +spbar Measure object +q Exit task + + + COLON COMMANDS + +:show Show the input and output coordinate systems +:isystem [string] Show / set the input coordinate system +:osystem [string] Show / set the output coordinate system +:ounits [string string] Show / set the output coordinate units +:oformat [string string] Show / set the output coordinate format + + VALID INPUT COORDINATE SYSTEMS + +image [tv] + + VALID OUTPUT COORDINATE SYSTEMS + +image [logical/tv/physical/world] +equinox [epoch] +noefk4 [equinox [epoch]] +fk4 [equinox [epoch]] +fk5 [equinox [epoch]] +icrs [equinox [epoch]] +apparent epoch +ecliptic epoch +galactic [epoch] +supergalactic [epoch] + + VALID OUTPUT CELESTIAL COORDINATE UNITS AND THEIR DEFAULT FORMATS + +hours %12.3h +degrees %12.2h +radians %13.7g diff --git a/pkg/images/imcoords/src/starfind.h b/pkg/images/imcoords/src/starfind.h new file mode 100644 index 00000000..d535716a --- /dev/null +++ b/pkg/images/imcoords/src/starfind.h @@ -0,0 +1,51 @@ +# STARFIND Structure + +define LEN_STARFIND (15) + +define SF_HWHMPSF Memr[P2R($1)] # HWHM of the PSF in pixels +define SF_FRADIUS Memr[P2R($1+1)] # Fitting radius in HWHM +define SF_DATAMIN Memr[P2R($1+2)] # Minimum good data limit in ADU +define SF_DATAMAX Memr[P2R($1+3)] # Maximum good data limit in ADU +define SF_THRESHOLD Memr[P2R($1+4)] # Detection threshold in ADU +define SF_SEPMIN Memr[P2R($1+5)] # Minimum separation in HWHM +define SF_SHARPLO Memr[P2R($1+6)] # Lower sharpness limit +define SF_SHARPHI Memr[P2R($1+7)] # Upper sharpness limit +define SF_ROUNDLO Memr[P2R($1+8)] # Lower roundness limit +define SF_ROUNDHI Memr[P2R($1+9)] # Upper roundness limit +define SF_MAGLO Memr[P2R($1+10)] # Lower magnitude limit +define SF_MAGHI Memr[P2R($1+11)] # Upper magnitude limit +define SF_NPIXMIN Memi[$1+12] # Minimum pixels above threshold + + +# default values + +define DEF_HWHMPSF 1.0 +define DEF_FRADIUS 1.5 +define DEF_THRESHOLD 0.0 +define DEF_SEPMIN 1.5 +define DEF_DATAMIN -MAX_REAL +define DEF_DATAMAX MAX_REAL +define DEF_SHARPLO 0.2 +define DEF_SHARPHI 1.0 +define DEF_ROUNDLO -1.0 +define DEF_ROUNDHI 1.0 +define DEF_MAGLO -MAX_REAL +define DEF_MAGHI MAX_REAL +define DEF_NPIXMIN 5 + + +# define the gaussian sums structure + +define LEN_GAUSS 10 + +define GAUSS_SUMG 1 +define GAUSS_SUMGSQ 2 +define GAUSS_PIXELS 3 +define GAUSS_DENOM 4 +define GAUSS_SGOP 5 + + +# miscellaneous constants + +define HWHM_TO_SIGMA 0.8493218 +define RMIN 2.001 diff --git a/pkg/images/imcoords/src/t_ccfind.x b/pkg/images/imcoords/src/t_ccfind.x new file mode 100644 index 00000000..0a8bc9b8 --- /dev/null +++ b/pkg/images/imcoords/src/t_ccfind.x @@ -0,0 +1,782 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <fset.h> +include <ctype.h> +include <imhdr.h> +include <pkg/skywcs.h> + +# T_CCFIND -- Locate objects with known celestial coordinates in an image +# using the image WCS or a user supplied WCS. Write the matched celestial and +# coordinates list to the output file. + +procedure t_ccfind () + +bool usewcs, center, verbose +double xref, yref, xmag, ymag, xrot, yrot, tlngref, tlatref, txref, tyref +double txmag, tymag, txrot, tyrot +int ip, nchars, sbox, cbox, min_sigdigits, ncenter, maxiter, tol +int inlist, ninfiles, outlist, noutfiles, imlist, nimages, in, out +int lngcolumn, latcolumn, lngunits, latunits, coostat, refstat +int lngrefunits, latrefunits, proj, pfd +pointer sp, insystem, refsystem, infile, outfile, image, projstr, str +pointer slngref, slatref, xformat, yformat, coo, refcoo, im, mw +real datamin, datamax, back + +bool clgetb() +double clgetd(), imgetd() +int clpopnu(), clplen(), imtopenp(), imtlen(), clgeti(), clgwrd(), strlen() +int sk_decwcs(), sk_decim(), open(), clgfil(), imtgetim(), strncmp(), ctod() +int cc_listran(), strdic(), cc_rdproj() +real clgetr() +pointer immap(), cc_mkwcs() +errchk imgstr(), imgetd(), open() + +begin + # Get some working space. + call smark (sp) + call salloc (infile, SZ_FNAME, TY_CHAR) + call salloc (outfile, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (insystem, SZ_FNAME, TY_CHAR) + call salloc (refsystem, SZ_FNAME, TY_CHAR) + call salloc (slngref, SZ_FNAME, TY_CHAR) + call salloc (slatref, SZ_FNAME, TY_CHAR) + call salloc (xformat, SZ_FNAME, TY_CHAR) + call salloc (yformat, SZ_FNAME, TY_CHAR) + call salloc (projstr, SZ_LINE, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Get the input data file list. + inlist = clpopnu ("input") + ninfiles = clplen (inlist) + if (ninfiles <= 0) { + call eprintf ("Error: The input coordinate file list is empty\n") + call clpcls (inlist) + call sfree (sp) + return + } + + # Get the output results lists. + outlist = clpopnu ("output") + noutfiles = clplen (outlist) + if (noutfiles != ninfiles) { + call eprintf ( + "Error: The number of input and output files must be the same\n") + call clpcls (inlist) + call clpcls (outlist) + call sfree (sp) + return + } + + + # Get the input image list. + imlist = imtopenp ("images") + nimages = imtlen (imlist) + if (nimages != ninfiles) { + call eprintf ( + "Error: The number of input files and images must be the same\n") + call imtclose (imlist) + call clpcls (inlist) + call clpcls (outlist) + call sfree (sp) + return + } + + # Get the coordinates file format. + lngcolumn = clgeti ("lngcolumn") + latcolumn = clgeti ("latcolumn") + call clgstr ("insystem", Memc[insystem], SZ_FNAME) + iferr (lngunits = clgwrd ("lngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + lngunits = 0 + iferr (latunits = clgwrd ("latunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + latunits = 0 + + # Get the user wcs if there is one. + usewcs = clgetb ("usewcs") + if (! usewcs) { + xref = clgetd ("xref") + yref = clgetd ("yref") + xmag = clgetd ("xmag") + ymag = clgetd ("ymag") + xrot = clgetd ("xrot") + yrot = clgetd ("yrot") + call clgstr ("lngref", Memc[slngref], SZ_FNAME) + call clgstr ("latref", Memc[slatref], SZ_FNAME) + call clgstr ("refsystem", Memc[refsystem], SZ_FNAME) + if (strncmp (Memc[refsystem], "INDEF", 5) == 0) + Memc[refsystem] = EOS + call clgstr ("projection", Memc[projstr], SZ_LINE) + iferr { + pfd = open (Memc[projstr], READ_ONLY, TEXT_FILE) + } then { + proj = strdic (Memc[projstr], Memc[projstr], SZ_LINE, + WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projstr] = EOS + } else { + proj = cc_rdproj (pfd, Memc[projstr], SZ_LINE) + call close (pfd) + } + } + iferr (lngrefunits = clgwrd ("lngrefunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + lngrefunits = 0 + iferr (latrefunits = clgwrd ("latrefunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + latrefunits = 0 + + # Get the centering parameters. + center = clgetb ("center") + sbox = clgeti ("sbox") + cbox = clgeti ("cbox") + datamin = clgetr ("datamin") + datamax = clgetr ("datamax") + back = clgetr ("background") + maxiter = clgeti ("maxiter") + tol = clgeti ("tolerance") + if (mod (sbox,2) == 0) + sbox = sbox + 1 + if (mod (cbox,2) == 0) + cbox = cbox + 1 + + # Get the output formatting parameters. + call clgstr ("xformat", Memc[xformat], SZ_FNAME) + call clgstr ("yformat", Memc[yformat], SZ_FNAME) + #min_sigdigits = clgeti ("min_sigdigits") + min_sigdigits = 7 + verbose = clgetb ("verbose") + + # Open the input coordinate system and determine its units. + coostat = sk_decwcs (Memc[insystem], mw, coo, NULL) + if (coostat == ERR || mw != NULL) { + call eprintf ("Error: Cannot decode the input coordinate system\n") + if (mw != NULL) + call mw_close (mw) + call imtclose (imlist) + call clpcls (inlist) + call clpcls (outlist) + call sfree (sp) + return + } + if (lngunits > 0) + call sk_seti (coo, S_NLNGUNITS, lngunits) + if (latunits > 0) + call sk_seti (coo, S_NLATUNITS, latunits) + + # Flush standard output on newline. + call fseti (STDOUT, F_FLUSHNL, YES) + + # Loop over the files. + while (clgfil (inlist, Memc[infile], SZ_FNAME) != EOF && + clgfil (outlist, Memc[outfile], SZ_FNAME) != EOF && + imtgetim(imlist, Memc[image], SZ_FNAME) != EOF) { + + # Open the input file of celestial coordinates. + in = open (Memc[infile], READ_ONLY, TEXT_FILE) + + # Open the output file of matched coordinates. + out = open (Memc[outfile], NEW_FILE, TEXT_FILE) + + # Open the input image. + im = immap (Memc[image], READ_ONLY, 0) + if (IM_NDIM(im) != 2) { + call printf ("Skipping file: %s Image: %s is not 2D\n") + call pargstr (Memc[infile]) + call pargstr (Memc[image]) + call imunmap (im) + call close (in) + call close (out) + next + } + + # Print the input and out file information. + if (verbose && out != STDOUT) { + call printf ("\nInput File: %s Output File: %s\n") + call pargstr (Memc[infile]) + call pargstr (Memc[outfile]) + call printf (" Image: %s Wcs: %s\n") + call pargstr (Memc[image]) + call pargstr ("") + } + call fprintf (out, "\n# Input File: %s Output File: %s\n") + call pargstr (Memc[infile]) + call pargstr (Memc[outfile]) + call fprintf (out, "# Image: %s Wcs: %s\n") + call pargstr (Memc[image]) + call pargstr ("") + + # Open the wcs and compile the transformation. + if (usewcs) { + + # Read the image wcs, skipping to the next image if the wcs + # is unreadable. + refstat = sk_decim (im, Memc[image], mw, refcoo) + if (refstat == ERR || mw == NULL) { + if (verbose && out != STDOUT) + call printf ( + "Error: Cannot decode the image coordinate system\n") + call fprintf (out, + "Error: Cannot decode the image coordinate system\n") + if (mw != NULL) + call mw_close (mw) + call sk_close (refcoo) + call imunmap (im) + call close (out) + call close (in) + next + } + + } else { + + # Get the image pixel reference coordinates + if (IS_INDEFD(xref)) + txref = (1.0d0 + IM_LEN(im,1)) / 2.0 + else + txref = xref + if (IS_INDEFD(yref)) + tyref = (1.0d0 + IM_LEN(im,2)) / 2.0 + else + tyref = yref + + # Get the image scale in arcsec / pixel. + if (IS_INDEFD(xmag)) + txmag = 1.0d0 + else + txmag = xmag + if (IS_INDEFD(ymag)) + tymag = 1.0d0 + else + tymag = ymag + + # Get the coordinate axes rotation angles in degrees. + if (IS_INDEFD(xrot)) + txrot = 0.0d0 + else + txrot = xrot + if (IS_INDEFD(yrot)) + tyrot = 0.0d0 + else + tyrot = yrot + + # Get the celestial coordinates of the tangent point from + # the image header or from the user. + iferr (tlngref = imgetd (im, Memc[slngref])) { + ip = 1 + nchars = ctod (Memc[slngref], ip, tlngref) + if (nchars <= 0 || nchars != strlen (Memc[slngref])) + tlngref = 0.0d0 + else if (IS_INDEFD(tlngref) || tlngref < 0.0d0 || + tlngref > 360.0d0) + tlngref = 0.0d0 + } + iferr (tlatref = imgetd (im, Memc[slatref])) { + ip = 1 + nchars = ctod (Memc[slatref], ip, tlatref) + if (nchars <= 0 || nchars != strlen (Memc[slatref])) + tlatref = 0.0d0 + else if (IS_INDEFD(tlatref) || tlatref < -90.0d0 || + tlatref > 90.0d0) + tlatref = 0.0d0 + } + + # Get the image reference system from the image header + # or from the user. + if (Memc[refsystem] == EOS) + call strcpy (Memc[refsystem], Memc[str], SZ_FNAME) + else { + iferr (call imgstr (im, Memc[refsystem], Memc[str], + SZ_FNAME)) + call strcpy (Memc[refsystem], Memc[str], SZ_FNAME) + } + refstat = sk_decwcs (Memc[str], mw, refcoo, NULL) + if (refstat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + call sk_close (refcoo) + refstat = sk_decwcs (Memc[insystem], mw, refcoo, NULL) + } + + # Force the units of the tangent point. + if (lngrefunits > 0) + call sk_seti (refcoo, S_NLNGUNITS, lngrefunits) + if (latrefunits > 0) + call sk_seti (refcoo, S_NLATUNITS, latrefunits) + + # Build the wcs. + mw = cc_mkwcs (refcoo, Memc[projstr], tlngref, tlatref, + txref, tyref, txmag, tymag, txrot, tyrot, false) + + # Force the wcs to look like an image wcs. + call sk_seti (refcoo, S_PIXTYPE, PIXTYPE_LOGICAL) + + } + + # Print out a description of the input coordinate and image + # systems. + if (verbose && out != STDOUT) + call sk_iiprint ("Insystem", Memc[insystem], NULL, coo) + call sk_iiwrite (out, "Insystem", Memc[insystem], NULL, coo) + call sk_stats (refcoo, S_COOSYSTEM, Memc[str], SZ_FNAME) + if (usewcs) { + if (verbose && out != STDOUT) { + call sk_iiprint ("Refsystem", Memc[str], mw, refcoo) + } + call sk_iiwrite (out, "Refsystem", Memc[str], mw, refcoo) + call fprintf (out, "\n") + } else { + if (verbose && out != STDOUT) { + call sk_iiprint ("Refsystem", Memc[str], NULL, refcoo) + } + call sk_iiwrite (out, "Refsystem", Memc[str], NULL, refcoo) + call fprintf (out, "\n") + } + + # Transform the coordinate lists. + ncenter = cc_listran (in, out, im, NULL, mw, coo, refcoo, lngcolumn, + latcolumn, lngunits, latunits, lngrefunits, latrefunits, + center, sbox / 2, cbox / 2, datamin, datamax, back, + maxiter, tol, Memc[xformat], Memc[yformat], min_sigdigits) + + if (verbose && out != STDOUT) { + call printf ("Located %d objects in image %s\n") + call pargi (ncenter) + call pargstr (Memc[image]) + call printf ("\n") + } + call sk_close (refcoo) + call mw_close (mw) + call imunmap (im) + call close (out) + call close (in) + } + + + call sk_close (coo) + call imtclose (imlist) + call clpcls (inlist) + call clpcls (outlist) + call sfree (sp) +end + + +define MAX_FIELDS 100 # Maximum number of fields in list +define TABSIZE 8 # Spacing of tab stops + +# CC_LISTRAN -- Transform the coordinate list. + +int procedure cc_listran (infd, outfd, im, mwin, mwout, cooin, cooout, + lngcolumn, latcolumn, ilngunits, ilatunits, olngunits, olatunits, + center, sbox, cbox, datamin, datamax, back, maxiter, tol, oxformat, + oyformat, min_sigdigits) + +int infd #I the input file descriptor +int outfd #I the output file descriptor +pointer im #I the input image descriptor +pointer mwin #I the input image wcs +pointer mwout #I the output image wcs +pointer cooin #I the input coordinate descriptor +pointer cooout #I the output coordinate descriptor +int lngcolumn #I the input ra/longitude column +int latcolumn #I the input dec/latitude column +int ilngunits #I the input ra/longitude units +int ilatunits #I the input dec/latitude units +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +bool center #I center the pixel coordinates +int sbox #I the search box half-width in pixels +int cbox #I the centering box half-width in pixels +real datamin #I the minimum good data value +real datamax #I the maximum good data value +real back #I the background reference value +int maxiter #I the maximum number of iterations +int tol #I the fitting tolerance in pixels +char oxformat[ARB] #I the output x format +char oyformat[ARB] #I the output y format +int min_sigdigits #I the minimum number of significant digits + +double ilng, ilat, tlng, tlat, olng, olat +int nline, ip, max_fields, nfields, offset, nchars, nsdig_lng, nsdig_lat +int tilngunits, tilatunits, tolngunits, tolatunits, cier, ncenter +pointer sp, inbuf, linebuf, field_pos, outbuf, ctin, ctout +pointer toxformat, toyformat +int sk_stati(), li_get_numd(), getline(), cc_center() +pointer sk_ictran(), sk_octran() +errchk sk_ictran(), sk_octran() + +begin + # Compile the input and output transformations. + iferr { + ctin = sk_ictran (cooin, mwin) + ctout = sk_octran (cooout, mwout) + } then + return + + # Allocate some memory. + 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) + call salloc (toxformat, SZ_FNAME, TY_CHAR) + call salloc (toyformat, SZ_FNAME, TY_CHAR) + + # Set the default input and output units. + if (ilngunits <= 0) + tilngunits = sk_stati (cooin, S_NLNGUNITS) + else + tilngunits = ilngunits + if (ilatunits <= 0) + tilatunits = sk_stati (cooin, S_NLATUNITS) + else + tilatunits = ilatunits + if (olngunits <= 0) + tolngunits = sk_stati (cooout, S_NLNGUNITS) + else + tolngunits = olngunits + if (olatunits <= 0) + tolatunits = sk_stati (cooout, S_NLATUNITS) + else + tolatunits = olatunits + + # Set the output format. + call sk_oformats (cooin, cooout, oxformat, oyformat, + tolngunits, tolatunits, Memc[toxformat], Memc[toyformat], + SZ_FNAME) + + # Check the input and output units. + call sk_iunits (cooin, mwin, tilngunits, tilatunits, tilngunits, + tilatunits) + call sk_ounits (cooout, mwout, tolngunits, tolatunits, tolngunits, + tolatunits) + + # Loop over the input coordinates. + max_fields = MAX_FIELDS + ncenter = 0 + for (nline = 1; getline (infd, Memc[inbuf]) != EOF; nline = nline + 1) { + + # Check for blank lines and comment lines. + 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 (lngcolumn > nfields || latcolumn > nfields) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Skipping object %d in file %s: too few fields\n") + call pargi (nline) + call pargstr (Memc[outbuf]) + #call putline (outfd, Memc[linebuf]) + next + } + + offset = Memi[field_pos+lngcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], ilng, nsdig_lng) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Skipping object %d in file %s: bad ra value\n") + call pargi (nline) + call pargstr (Memc[outbuf]) + #call putline (outfd, Memc[linebuf]) + next + } + + offset = Memi[field_pos+latcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], ilat, nsdig_lat) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Skipping object %d in file %s: bad dec value\n") + call pargi (nline) + call pargstr (Memc[outbuf]) + #call putline (outfd, Memc[linebuf]) + next + } + + # Convert the input coordinates to world coordinates in radians. + call sk_incc (cooin, mwin, ctin, tilngunits, tilatunits, ilng, + ilat, olng, olat) + + # Perform the transformation. + call sk_lltran (cooin, cooout, olng, olat, INDEFD, INDEFD, + 0.0d0, 0.0d0, tlng, tlat) + + # Convert the output celestial coordinates from radians to output + # coordinates. + call sk_outcc (cooout, mwout, ctout, tolngunits, tolatunits, + tlng, tlat, olng, olat) + + # Is the object on the image ? + if (olng < 0.5d0 || olng > (IM_LEN(im,1) + 0.5d0) || + olat < 0.5d0 || olat > (IM_LEN(im,2) + 0.5d0)) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Skipping object %d in file %s: off image %s\n") + call pargi (nline) + call pargstr (Memc[outbuf]) + call pargstr (IM_HDRFILE(im)) + #call putline (outfd, Memc[linebuf]) + next + } + + # Center the coordinates. + if (center) { + cier = cc_center (im, sbox, cbox, datamin, datamax, back, + maxiter, tol, olng, olat, olng, olat) + if (cier == ERR) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ( + "Skipping object %d in file %s: cannot center in image %s\n") + call pargi (nline) + call pargstr (Memc[outbuf]) + call pargstr (IM_HDRFILE(im)) + #call putline (outfd, Memc[linebuf]) + next + } + } + + # Output the results. + call li_append_lined (Memc[linebuf], Memc[outbuf], SZ_LINE, + olng, olat, Memc[toxformat], Memc[toyformat], nsdig_lng, + nsdig_lat, min_sigdigits) + call putline (outfd, Memc[outbuf]) + ncenter = ncenter + 1 + } + + call sfree (sp) + + return (ncenter) +end + + +# CC_CENTER -- Given an initial x and y coordinate compute a more accurate +# center using a centroiding technique. + +int procedure cc_center (im, sbox, cbox, datamin, datamax, back, maxiter, + tolerance, xinit, yinit, xcenter, ycenter) + +pointer im #I pointer to the input image +int sbox #I the search box half-width in pixels +int cbox #I the centering box half-width in pixels +real datamin #I the minimum good data value +real datamax #I the maximum good data value +real back #I the background reference value +int maxiter #I the maximum number of iterations. +int tolerance #I the tolerance for convergence in pixels +double xinit, yinit #I the initial x and y positions +double xcenter, ycenter #I the final x and y positions + +bool converged +double xold, yold, xnew, ynew +int i, fbox, x1, x2, y1, y2, nx, ny +real lo, hi, sky +pointer buf, sp, xbuf, ybuf +pointer imgs2r() +real cc_ctr1d() +errchk imgs2r(), cc_threshold(), cc_rowsum(), cc_colsum(), cc_ctr1d() + + +begin + xold = xinit + yold = yinit + converged = false + + do i = 1, maxiter { + + if (i == 1) + fbox = sbox + else + fbox = cbox + x1 = max (nint (xold) - fbox, 1) + x2 = min (nint (xold) + fbox, IM_LEN(im,1)) + y1 = max (nint (yold) - fbox, 1) + y2 = min (nint (yold) + fbox, IM_LEN(im,2)) + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + + call smark (sp) + call salloc (xbuf, nx, TY_REAL) + call salloc (ybuf, ny, TY_REAL) + + iferr { + buf = imgs2r (im, x1, x2, y1, y2) + call cc_threshold (Memr[buf], nx * ny, datamin, datamax, + back, lo, hi, sky) + call cc_rowsum (Memr[buf], Memr[xbuf], nx, ny, lo, hi, sky) + call cc_colsum (Memr[buf], Memr[ybuf], nx, ny, lo, hi, sky) + xnew = x1 + cc_ctr1d (Memr[xbuf], nx) + ynew = y1 + cc_ctr1d (Memr[ybuf], ny) + } then { + call sfree (sp) + return (ERR) + } + + call sfree (sp) + + # Force at least one iteration. + if (i > 1) { + if (abs(nint(xnew) - nint(xold)) <= tolerance && + abs(nint(ynew) - nint(yold)) <= tolerance) { + converged = true + break + } + } + + xold = xnew + yold = ynew + } + + if (converged) { + xcenter = xnew + ycenter = ynew + return (OK) + } else { + xcenter = xinit + ycenter = yinit + return (ERR) + } +end + + +# CC_THRESHOLD -- Find the low and high thresholds for the subraster. + +procedure cc_threshold (raster, npix, datamin, datamax, back, ldatamin, + ldatamax, lback) + +real raster[ARB] #I input data +int npix #I length of input data +real datamin #I minimum good data value +real datamax #I maximum good data value +real back #I background value +real ldatamin #I local minimum good data value +real ldatamax #I local maximum good data value +real lback #I local background value + +real junk +int awvgr() +errchk alimr, awvgr + +begin + # use the local data min or max for thresholds that are INDEF. + if (IS_INDEFR(datamin) || IS_INDEFR(datamax)) + call alimr (raster, npix, ldatamin, ldatamax) + if (! IS_INDEFR(datamin)) + ldatamin = datamin + if (! IS_INDEFR(datamax)) + ldatamax = datamax + + if (IS_INDEFR(back)) { + if (awvgr (raster, npix, lback, junk, ldatamin, + ldatamax) <= 0) + call error (1, "No data in good data range") + } else + lback = back + + ldatamin = max (ldatamin, lback) + ldatamax = ldatamax +end + + +# CC_ROWSUM -- Sum all rows in a raster, subject to the thresholds, the +# background, and other parameters. + +procedure cc_rowsum (raster, row, nx, ny, lo, hi, back) + +real raster[nx,ny] #I the input 2-D subraster +real row[ARB] #O the output averaged row vector +int nx, ny #I dimensions of the subraster +real lo, hi #I minimum and maximum good data values +real back #I the background value + +int i, j +real pix, minpix, maxpix + +begin + # Compute the x marginal. + call aclrr (row, nx) + do j = 1, ny + do i = 1, nx { + pix = raster[i,j] + if (lo <= pix && pix <= hi) + row[i] = row[i] + pix - back + } + call adivkr (row, real(ny), row, nx) + + # Check for low values. + call alimr (row, nx, minpix, maxpix) + if (minpix < 0.0) + call error (1, "Negative value in marginal row") +end + + +# CC_COLSUM -- Sum all columns in a raster, subject to the thresholds, the +# background, and other parameters. + +procedure cc_colsum (raster, col, nx, ny, lo, hi, back) + +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 +real lo, hi #I minimum and maximum good data values +real back #I the background value + + +int i, j +real pix, minpix, maxpix + +begin + # Compute the y marginal. + call aclrr (col, ny) + do j = 1, ny + do i = 1, nx { + pix = raster[i,j] + if (lo <= pix && pix <= hi) + col[j] = col[j] + pix - back + } + call adivkr (col, real(nx), col, ny) + + # Check for low values. + call alimr (col, ny, minpix, maxpix) + if (minpix < 0.) + call error (1, "Negative value in marginal column") +end + + +# CC_CNTR1D -- Compute the the first moment. + +real procedure cc_ctr1d (a, npix) + +real a[ARB] #I marginal vector +int npix #I size of the vector + +real centroid, pix, sumi, sumix +int i + +begin + sumi = 0. + sumix = 0. + do i = 1, npix { + pix = a[i] + sumi = sumi + pix + sumix = sumix + pix * (i-1) + } + + if (sumi == 0.0) + call error (1, "The center is undefined\n") + else + centroid = sumix / sumi + + return (centroid) +end + diff --git a/pkg/images/imcoords/src/t_ccget.x b/pkg/images/imcoords/src/t_ccget.x new file mode 100644 index 00000000..8955daf9 --- /dev/null +++ b/pkg/images/imcoords/src/t_ccget.x @@ -0,0 +1,1201 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <fset.h> +include <evvexpr.h> +include <math.h> +include <ctotok.h> +include <lexnum.h> +include <ctype.h> +include <pkg/skywcs.h> + +# Define the input data structure + +define DC_DLENGTH 10 +define DC_NCOLUMNS Memi[$1] # the number of columns in record +define DC_LNGCOLUMN Memi[$1+1] # the ra / longitude column index +define DC_LATCOLUMN Memi[$1+2] # the dec / latitude column index +define DC_COLNAMES Memi[$1+3] # the column names pointer +define DC_RECORD Memi[$1+4] # the record pointer +define DC_COFFSETS Memi[$1+5] # the column offsets + +define MAX_NCOLUMNS 100 # the maximum number of columns +define SZ_COLNAME 19 # the column name +define TABSIZE 8 # the spacing of the tab stops + +# Define the output structure + +define EC_ELENGTH 10 + +define EC_NEXPR Memi[$1] # the number of expressions +define EC_ELIST Memi[$1+1] # the expression list pointer +define EC_ERANGES Memi[$1+2] # the expression column ranges +define EC_EFORMATS Memi[$1+3] # the expression formats +define EC_ELNGFORMAT Memi[$1+4] # the expression formats +define EC_ELATFORMAT Memi[$1+5] # the expression formats + +define MAX_NEXPR 20 +define MAX_NERANGES 100 +define SZ_EXPR SZ_LINE +define SZ_EFORMATS 9 + +# T_CCGET -- Given a field center, field width, and field epoch extract objects +# within the rectangular field from a catalog. + +procedure t_ccget () + +double dlngcenter, dlatcenter, dlngwidth, dlatwidth, tlngcenter, tlatcenter +double dlng1, dlng2, dlat1, dlat2 +int ip, inlist, ninfiles, outlist, noutfiles, fclngunits, fclatunits +int fldstat, catstat, outstat, catlngunits, catlatunits, olngunits +int olatunits, in, out +pointer sp, lngcenter, latcenter, fcsystem, catsystem, outsystem, olngformat +pointer olatformat, lngcolumn, latcolumn, colnames, exprs, formats +pointer infile, outfile, str +pointer fldcoo, catcoo, outcoo, mw, dc, ec +bool verbose +double clgetd() +pointer cc_dinit(), cc_einit() +int clpopnu(), clplen(), ctod(), strncmp(), clgwrd(), sk_decwcs() +int sk_stati(), clgfil(), open() +bool clgetb(), streq() +errchk clgwrd() + +begin + # Open the list of input catalogs. These catalogs must have the + # same format. + inlist = clpopnu ("input") + ninfiles = clplen (inlist) + if (ninfiles <= 0) { + call eprintf ("Error: The input catalog list is empty\n") + call clpcls (inlist) + return + } + + # Open the list of output catalogs. The number of output catalogs + # must be 1 or equal to the number of input catalogs. + outlist = clpopnu ("output") + noutfiles = clplen (outlist) + if (noutfiles <= 0) { + call eprintf ("Error: The output catalog list is empty\n") + call clpcls (inlist) + call clpcls (outlist) + return + } else if (noutfiles > 1 && noutfiles != ninfiles) { + call eprintf ( + "Error: The number of input and output catalogs are not the same\n") + call clpcls (inlist) + call clpcls (outlist) + return + } + + # Get some working space. + call smark (sp) + call salloc (infile, SZ_FNAME, TY_CHAR) + call salloc (outfile, SZ_FNAME, TY_CHAR) + call salloc (lngcenter, SZ_FNAME, TY_CHAR) + call salloc (latcenter, SZ_FNAME, TY_CHAR) + call salloc (fcsystem, SZ_FNAME, TY_CHAR) + call salloc (catsystem, SZ_FNAME, TY_CHAR) + call salloc (lngcolumn, SZ_FNAME, TY_CHAR) + call salloc (latcolumn, SZ_FNAME, TY_CHAR) + call salloc (colnames, SZ_LINE, TY_CHAR) + call salloc (outsystem, SZ_FNAME, TY_CHAR) + call salloc (olngformat, SZ_FNAME, TY_CHAR) + call salloc (olatformat, SZ_FNAME, TY_CHAR) + call salloc (exprs, SZ_LINE, TY_CHAR) + call salloc (formats, SZ_LINE, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Get the field center coordinates and make some preliminary checks. + call clgstr ("lngcenter", Memc[lngcenter], SZ_FNAME) + call clgstr ("latcenter", Memc[latcenter], SZ_FNAME) + ip = 1 + if (ctod (Memc[lngcenter], ip, dlngcenter) <= 0) + dlngcenter = INDEFD + else if (dlngcenter < 0.0 || dlngcenter > 360.0) + dlngcenter = INDEFD + ip = 1 + if (ctod (Memc[latcenter], ip, dlatcenter) <= 0) + dlatcenter = INDEFD + else if (dlatcenter < -90.0 || dlatcenter > 90.0) + dlatcenter = INDEFD + if (IS_INDEFD(dlngcenter) || IS_INDEFD(dlatcenter)) { + call eprintf ( "Error: Undefined field center\n") + call clpcls (inlist) + call clpcls (outlist) + call sfree (sp) + return + } + + dlngwidth = clgetd ("lngwidth") + if (dlngwidth < 0.0 || dlngwidth > 360.0) + dlngwidth = INDEFD + dlatwidth = clgetd ("latwidth") + if (dlatwidth < 0.0 || dlatwidth > 180.0) + dlatwidth = INDEFD + if (IS_INDEFD(dlngwidth) || IS_INDEFD(dlatwidth)) { + call eprintf ( "Error: Undefined field width\n") + call clpcls (inlist) + call clpcls (outlist) + call sfree (sp) + return + } + + # Get the field coordinate system and convert INDEF to EOS + # to avoid passing the wcs decoding routine a large number. + call clgstr ("fcsystem", Memc[fcsystem], SZ_FNAME) + if (strncmp (Memc[fcsystem], "INDEF", 5) == 0) + Memc[fcsystem] = EOS + + # Get the field center coordinate units. + iferr (fclngunits = clgwrd ("fclngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + fclngunits = 0 + iferr (fclatunits = clgwrd ("fclatunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + fclatunits = 0 + + # Get the coordinates file format. + call clgstr ("lngcolumn", Memc[lngcolumn], SZ_FNAME) + call clgstr ("latcolumn", Memc[latcolumn], SZ_FNAME) + + # Get the catalog coordinate system and convert INDEF to EOS + # to avoid passing the wcs decoding routine a large number. + call clgstr ("catsystem", Memc[catsystem], SZ_FNAME) + if (strncmp (Memc[catsystem], "INDEF", 5) == 0) + Memc[catsystem] = EOS + + # Get the input catalog coordinate units. + iferr (catlngunits = clgwrd ("catlngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + catlngunits = 0 + iferr (catlatunits = clgwrd ("catlatunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + catlatunits = 0 + + # Get the output catalog coordinates system. + call clgstr ("outsystem", Memc[outsystem], SZ_FNAME) + if (strncmp (Memc[outsystem], "INDEF", 5) == 0) + Memc[outsystem] = EOS + + # Get the output catalog coordinate units. + iferr (olngunits = clgwrd ("olngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + olngunits = 0 + iferr (olatunits = clgwrd ("olatunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + olatunits = 0 + call clgstr ("olngformat", Memc[olngformat], SZ_LINE) + call clgstr ("olatformat", Memc[olatformat], SZ_LINE) + + # Get the output catalog format. + call clgstr ("colaliases", Memc[colnames], SZ_LINE) + call clgstr ("exprs", Memc[exprs], SZ_LINE) + call clgstr ("formats", Memc[formats], SZ_LINE) + + verbose = clgetb ("verbose") + + # Open the reference coordinate system. + if (streq (Memc[catsystem], Memc[fcsystem]) && + (fclngunits == catlngunits) && + (fclatunits == catlatunits)) { + fldcoo = NULL + } else { + fldstat = sk_decwcs (Memc[fcsystem], mw, fldcoo, NULL) + if (fldstat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + fldcoo = NULL + } + } + + # Open the catalog coordinate system. + catstat = sk_decwcs (Memc[catsystem], mw, catcoo, NULL) + if (catstat == ERR || mw != NULL) { + call eprintf ("Error: Cannot decode the input coordinate system\n") + if (mw != NULL) + call mw_close (mw) + if (fldcoo != NULL) + call sk_close (fldcoo) + call clpcls (inlist) + call clpcls (outlist) + call sfree (sp) + return + } + + # Determine the units of the input coordinate system. + if (catlngunits <= 0) + catlngunits = sk_stati (catcoo, S_NLNGUNITS) + if (catlatunits <= 0) + catlatunits = sk_stati (catcoo, S_NLATUNITS) + call sk_seti (catcoo, S_NLNGUNITS, catlngunits) + call sk_seti (catcoo, S_NLATUNITS, catlatunits) + if (fldcoo == NULL) { + if (fclngunits <= 0) + fclngunits = sk_stati (catcoo, S_NLNGUNITS) + if (fclatunits <= 0) + fclatunits = sk_stati (catcoo, S_NLATUNITS) + } else { + if (fclngunits <= 0) + fclngunits = sk_stati (fldcoo, S_NLNGUNITS) + if (fclatunits <= 0) + fclatunits = sk_stati (fldcoo, S_NLATUNITS) + call sk_seti (fldcoo, S_NLNGUNITS, fclngunits) + call sk_seti (fldcoo, S_NLATUNITS, fclatunits) + } + + # Open the output catalog coordinate system. + if (streq (Memc[outsystem], Memc[catsystem]) && + (olngunits == catlngunits) && + (olatunits == catlatunits)) { + outcoo = NULL + } else { + outstat = sk_decwcs (Memc[outsystem], mw, outcoo, NULL) + if (outstat == ERR || mw != NULL) { + call eprintf ( + "Warning: Cannot decode the output coordinate system\n") + if (mw != NULL) + call mw_close (mw) + outcoo = NULL + } + } + + # Set the output catalog units. + if (outcoo == NULL) { + if (olngunits <= 0) + olngunits = sk_stati (catcoo, S_NLNGUNITS) + if (olatunits <= 0) + olatunits = sk_stati (catcoo, S_NLATUNITS) + } else { + if (olngunits <= 0) + olngunits = sk_stati (outcoo, S_NLNGUNITS) + if (olatunits <= 0) + olatunits = sk_stati (outcoo, S_NLATUNITS) + call sk_seti (outcoo, S_NLNGUNITS, olngunits) + call sk_seti (outcoo, S_NLATUNITS, olatunits) + } + + # Get default output coordinate formats. + if (outcoo != NULL) { + if (Memc[olngformat] == EOS || Memc[olngformat] == ' ') { + switch (sk_stati(outcoo, S_NLNGUNITS)) { + case SKY_HOURS: + call strcpy (" %010.1h", Memc[olngformat], SZ_EFORMATS) + case SKY_DEGREES: + call strcpy (" %9.0h", Memc[olngformat], SZ_EFORMATS) + case SKY_RADIANS: + call strcpy (" %9.7g", Memc[olngformat], SZ_EFORMATS) + } + } + if (Memc[olatformat] == EOS || Memc[olngformat] == ' ') { + switch (sk_stati(outcoo, S_NLATUNITS)) { + case SKY_HOURS: + call strcpy (" %010.1h", Memc[olatformat], SZ_EFORMATS) + case SKY_DEGREES: + call strcpy (" %9.0h", Memc[olatformat], SZ_EFORMATS) + case SKY_RADIANS: + call strcpy (" %9.7g", Memc[olatformat], SZ_EFORMATS) + } + } + } + + # Convert the field center coordinates to the catalog + # coordinate system. + if (fldcoo == NULL) { + tlngcenter = dlngcenter + tlatcenter = dlatcenter + } else { + call sk_ultran (fldcoo, catcoo, dlngcenter, dlatcenter, + tlngcenter, tlatcenter, 1) + } + + # Determine the corners of the field in degrees. At present + # the maximum longitude width is actually 180 not 360 degrees + # and the maximum latitude width is 180 degrees. + call cc_limits (catcoo, tlngcenter, tlatcenter, dlngwidth, + dlatwidth, dlng1, dlng2, dlat1, dlat2) + + # Flush standard output on newline. + call fseti (STDOUT, F_FLUSHNL, YES) + + # Initialize the data structure. + dc = cc_dinit (Memc[colnames], Memc[lngcolumn], Memc[latcolumn]) + + # Initialize the expressions structure. + ec = cc_einit (Memc[exprs], Memc[formats], Memc[olngformat], + Memc[olatformat]) + + # Decode the expressions using info in the data structure. + call cc_edecode (dc, ec) + + # Loop over the catalog files. + while (clgfil (inlist, Memc[infile], SZ_FNAME) != EOF) { + + # Open text file of coordinates. + in = open (Memc[infile], READ_ONLY, TEXT_FILE) + + # Open the output file. + if (clgfil (outlist, Memc[outfile], SZ_FNAME) != EOF) + out = open (Memc[outfile], NEW_FILE, TEXT_FILE) + + # Print the input and output file information. + if (verbose && out != STDOUT) { + call printf ("\nCatalog File: %s Output File: %s\n") + call pargstr (Memc[infile]) + call pargstr (Memc[outfile]) + } + if (out != NULL) { + call fprintf (out, "\n# Catalog File: %s Output File: %s\n") + call pargstr (Memc[infile]) + call pargstr (Memc[outfile]) + } + + # Print information about the field center coordinate system. + if (fldcoo == NULL) { + if (verbose && out != STDOUT) + call sk_iiprint ("Field System", Memc[catsystem], NULL, + catcoo) + if (out != NULL) + call sk_iiwrite (out, "Field System", Memc[catsystem], + NULL, catcoo) + } else { + if (verbose && out != STDOUT) + call sk_iiprint ("Field System", Memc[fcsystem], NULL, + fldcoo) + if (out != NULL) + call sk_iiwrite (out, "Field System", Memc[fcsystem], NULL, + fldcoo) + } + + # Print information about the input coordinate system. + if (verbose && out != STDOUT) + call sk_iiprint ( + "Catalog System", Memc[catsystem], NULL, catcoo) + if (out != NULL) + call sk_iiwrite (out, "Catalog System", Memc[catsystem], NULL, + catcoo) + + # Print information about the output coordinate system. + if (outcoo == NULL) { + if (verbose && out != STDOUT) + call sk_iiprint ("Output System", Memc[catsystem], NULL, + catcoo) + if (out != NULL) + call sk_iiwrite (out, "Output System", Memc[catsystem], + NULL, catcoo) + } else { + if (verbose && out != STDOUT) + call sk_iiprint ("Output System", Memc[outsystem], NULL, + outcoo) + if (out != NULL) + call sk_iiwrite (out, "Output System", Memc[outsystem], + NULL, outcoo) + } + + # Print the corners field parameters. + if (verbose && out != STDOUT) { + if (sk_stati (catcoo, S_NLNGUNITS) == SKY_HOURS) + call printf ( + "#\n# Field Center: %10h %9h Width: %0.4f %0.4f\n") + else + call printf ( + "#\n# Field Center: %11h %9h Width: %0.4f %0.4f\n") + call pargd (tlngcenter) + call pargd (tlatcenter) + call pargd (dlngwidth) + call pargd (dlatwidth) + if (sk_stati (catcoo, S_NLNGUNITS) == SKY_HOURS) + call printf ("# Field Limits: %9H %9H %9h %9h\n#\n") + else + call printf ("# Field Limits: %9h %9h %9h %9h\n#\n") + call pargd (dlng1) + call pargd (dlng2) + call pargd (dlat1) + call pargd (dlat2) + } + + if (out != NULL) { + if (sk_stati (catcoo, S_NLNGUNITS) == SKY_HOURS) + call fprintf (out, + "#\n# Field Center: %10h %9h Width: %0.4f %0.4f\n") + else + call fprintf (out, + "#\n# Field Center: %11h %9h Width: %0.4f %0.4f\n") + call pargd (tlngcenter) + call pargd (tlatcenter) + call pargd (dlngwidth) + call pargd (dlatwidth) + if (sk_stati (catcoo, S_NLNGUNITS) == SKY_HOURS) + call fprintf (out, "# Field Limits: %9H %9H %9h %9h\n#\n") + else + call fprintf (out, "# Field Limits: %9h %9h %9h %9h\n#\n") + call pargd (dlng1) + call pargd (dlng2) + call pargd (dlat1) + call pargd (dlat2) + } + + # Read in the data line by line, selecting the records of + # interest. + call cc_select (in, out, dc, ec, catcoo, outcoo, tlngcenter, + tlatcenter, dlngwidth, dlatwidth, dlng1, dlng2, dlat1, + dlat2, verbose) + + call close (in) + if (noutfiles == ninfiles) + call close (out) + } + + call cc_dfree (dc) + call cc_efree (ec) + + if (noutfiles != ninfiles) + call close (out) + if (fldcoo != NULL) + call sk_close (fldcoo) + call sk_close (catcoo) + if (outcoo != NULL) + call sk_close (outcoo) + call clpcls (inlist) + call clpcls (outlist) + + call sfree (sp) +end + + +# CC_LIMITS - Given the field center and field width compute the ra / +# longitude and dec / latitude limits of the region of interest. + +procedure cc_limits (catcoo, dlngcenter, dlatcenter, dlngwidth, dlatwidth, + dlng1, dlng2, dlat1, dlat2) + +pointer catcoo #I the pointer to the catalog wcs +double dlngcenter #I the field center ra / longtitude +double dlatcenter #I the field center dec / latitude +double dlngwidth #I the field ra / longitude width (degrees) +double dlatwidth #I the field dec / latitude width (degrees) +double dlng1 #O the lower field ra / longitude limit +double dlng2 #O the upper field ra / longitude limit +double dlat1 #O the lower field dec / latitude limit +double dlat2 #O the upper field dec / longitude limit + +double tlngcenter, tlatcenter, cosdec, dhlngwidth +int sk_stati() + +begin + # Convert the field center coordinates to degrees. + switch (sk_stati(catcoo, S_NLNGUNITS)) { + case SKY_HOURS: + tlngcenter = 15.0d0 * dlngcenter + case SKY_DEGREES: + tlngcenter = dlngcenter + case SKY_RADIANS: + tlngcenter = RADTODEG(dlngcenter) + default: + tlngcenter = dlngcenter + } + switch (sk_stati (catcoo, S_NLATUNITS)) { + case SKY_HOURS: + tlatcenter = 15.0d0 * dlatcenter + case SKY_DEGREES: + tlatcenter = dlatcenter + case SKY_RADIANS: + tlatcenter = RADTODEG(dlatcenter) + default: + tlatcenter = dlatcenter + } + + # Find the field corners. + dlat1 = tlatcenter - 0.5d0 * dlatwidth + if (dlat1 <= -90.0d0) { + dlat1 = -90.0d0 + dlat2 = min (tlatcenter + 0.5d0 * dlatwidth, 90.0d0) + dlng1 = 0.0d0 + dlng2 = 360.0d0 + return + } + + dlat2 = tlatcenter + 0.5d0 * dlatwidth + if (dlat2 >= 90.0d0) { + dlat2 = 90.0d0 + dlat1 = max (tlatcenter - 0.5d0 * dlatwidth, -90.0d0) + dlng1 = 0.0d0 + dlng2 = 360.0d0 + return + } + + if (tlatcenter > 0.0d0) + cosdec = cos (DEGTORAD(dlat2)) + else + cosdec = cos (DEGTORAD(dlat1)) + dhlngwidth = 0.5d0 * dlngwidth / cosdec + if (dhlngwidth >= 180.0d0) { + dlng1 = 0.0d0 + dlng2 = 360.0d0 + } else { + dlng1 = tlngcenter - dhlngwidth + if (dlng1 < 0.0d0) + dlng1 = dlng1 + 360.0d0 + dlng2 = tlngcenter + dhlngwidth + if (dlng2 > 360.0d0) + dlng2 = dlng2 - 360.0d0 + } +end + + +# CC_SELECT -- Select and print the records matching the field position +# and size criteria. + +procedure cc_select (in, out, dc, ec, catcoo, outcoo, lngcenter, latcenter, + lngwidth, latwidth, dlng1, dlng2, dlat1, dlat2, verbose) + +int in #I the input file file descriptor +int out #I the output file descriptor +pointer dc #I the file data structure +pointer ec #I the expression structure +pointer catcoo #I the input catalog coordinate structure +pointer outcoo #I the output catalog coordinate structure +double lngcenter, latcenter #I the field center coordinates +double lngwidth, latwidth #I the field widths in degrees +double dlng1, dlng2 #I the ra / longitude limits in degrees +double dlat1, dlat2 #I the dec / latitude limits in degrees +bool verbose #I verbose mode + +double dlngcenter, dlatcenter, tlng, tlat, dlng, dlat, dist +double tmplng, tlngcenter +int ip, op, i, j, nline, lngoffset, latoffset, offset1, offset2, nsig +pointer sp, inbuf, outbuf, newval, eptr, rptr, fptr, pexpr +pointer evvexpr(), locpr() +int getline(), li_get_numd(), sk_stati(), gstrcpy(), strlen() +bool streq() +extern cc_getop() + +begin + call smark (sp) + call salloc (inbuf, SZ_LINE, TY_CHAR) + call salloc (outbuf, SZ_LINE, TY_CHAR) + call salloc (newval, SZ_LINE, TY_CHAR) + + # Convert the field center coordinates to degrees. + switch (sk_stati(catcoo, S_NLNGUNITS)) { + case SKY_HOURS: + dlngcenter = 15.0d0 * lngcenter + case SKY_RADIANS: + dlngcenter = RADTODEG(lngcenter) + default: + dlngcenter = lngcenter + } + switch (sk_stati (catcoo, S_NLATUNITS)) { + case SKY_HOURS: + dlatcenter = 15.0d0 * latcenter + case SKY_RADIANS: + dlatcenter = RADTODEG(latcenter) + default: + dlatcenter = latcenter + } + + for (nline = 1; getline (in, Memc[inbuf]) != EOF; nline = nline + 1) { + + # Skip over leading white space. + for (ip = inbuf; IS_WHITE(Memc[ip]); ip = ip + 1) + ; + + # Skip comment and blank lines. + if (Memc[ip] == '#') + next + else if (Memc[ip] == '\n' || Memc[ip] == EOS) + next + + # Expand tabs into blanks, determine field offsets. + call strdetab (Memc[inbuf], Memc[DC_RECORD(dc)], SZ_LINE, TABSIZE) + call li_find_fields (Memc[DC_RECORD(dc)], Memi[DC_COFFSETS(dc)], + MAX_NCOLUMNS, DC_NCOLUMNS(dc)) + + # Decode the longitude coordinate. + if (DC_LNGCOLUMN(dc) > DC_NCOLUMNS(dc)) + next + lngoffset = Memi[DC_COFFSETS(dc)+DC_LNGCOLUMN(dc)-1] + if (li_get_numd (Memc[DC_RECORD(dc)+lngoffset-1], tlng, nsig) == 0) + next + + # Decode the latitude coordinate. + if (DC_LATCOLUMN(dc) > DC_NCOLUMNS(dc)) + next + latoffset = Memi[DC_COFFSETS(dc)+DC_LATCOLUMN(dc)-1] + if (li_get_numd (Memc[DC_RECORD(dc)+latoffset-1], tlat, nsig) == 0) + next + + # Convert the catalog coordinates to degrees. + switch (sk_stati(catcoo, S_NLNGUNITS)) { + case SKY_HOURS: + dlng = 15.0d0 * tlng + case SKY_RADIANS: + dlng = RADTODEG(tlng) + default: + dlng = tlng + } + switch (sk_stati (catcoo, S_NLATUNITS)) { + case SKY_HOURS: + dlat = 15.0d0 * tlat + case SKY_RADIANS: + dlat = RADTODEG(tlat) + default: + dlat = tlat + } + + # Test the converted ra /dec or longitude / latitude value + # versus the user defined ra / longitude and dec / latitude + # limits. + if (dlat < dlat1 || dlat > dlat2) + next + if (dlng1 < dlng2) { + if (dlng >= dlng1 && dlng <= dlng2) + ; + else + next + } else { + if (dlng > dlng2 && dlng < dlng1) + next + else + ; + } + + # Check the longitude coordinate distance to remove pathologies + # in longitude or latitude strips involving the pole. This is + # an extra test of my own. + if (dlng1 < dlng2) { + dist = abs (dlng - dlngcenter) + } else { + if (dlng > dlng1) + tmplng = dlng - 360.0d0 + else + tmplng = dlng + if (dlngcenter > dlng1) + tlngcenter = dlngcenter - 360.0d0 + else + tlngcenter = dlngcenter + dist = abs (tmplng - tlngcenter) + } + if (abs (2.0d0*dist*cos(DEGTORAD(dlat))) > lngwidth) + next + + # If all the columns are selected and no column expressions have + # been defined dump the input records to the output. + + if (outcoo == NULL && (streq (Memc[EC_ELIST(ec)], "*") || + streq (Memc[EC_ELIST(ec)], "c[*]"))) { + if (verbose && out != STDOUT) + call putline (STDOUT, Memc[DC_RECORD(dc)]) + if (out != NULL) + call putline (out, Memc[DC_RECORD(dc)]) + next + } + + # Otherwise loop through the user specified output fields + # and expressions. + + # Initialize the expression list pointers. + rptr = EC_ERANGES(ec) + eptr = EC_ELIST(ec) + fptr = EC_EFORMATS(ec) + + # Initiliaze the output buffer. + op = outbuf + Memc[op] = EOS + + do i = 1, EC_NEXPR(ec) { + + # The next user output field is an expression. + if (IS_INDEFI(Memi[rptr])) { + + pexpr = evvexpr (Memc[eptr], locpr (cc_getop), dc, 0, dc, 0) + switch (O_TYPE(pexpr)) { + case TY_BOOL: + if (Memc[fptr] == '%') + call sprintf (Memc[newval], SZ_LINE, Memc[fptr]) + else + call sprintf (Memc[newval], SZ_LINE, "%5b") + call pargi (O_VALI(pexpr)) + case TY_CHAR: + if (Memc[fptr] == '%') + call sprintf (Memc[newval], SZ_LINE, Memc[fptr]) + else + call sprintf (Memc[newval], SZ_LINE, " %s") + call pargstr (O_VALC(pexpr)) + case TY_INT: + if (Memc[fptr] == '%') + call sprintf (Memc[newval], SZ_LINE, Memc[fptr]) + else + call sprintf (Memc[newval], SZ_LINE, " %10d") + call pargi (O_VALI(pexpr)) + case TY_REAL: + if (Memc[fptr] == '%') + call sprintf (Memc[newval], SZ_LINE, Memc[fptr]) + else + call sprintf (Memc[newval], SZ_LINE, " %10g") + call pargr (O_VALR(pexpr)) + case TY_DOUBLE: + if (Memc[fptr] == '%') + call sprintf (Memc[newval], SZ_LINE, Memc[fptr]) + else + call sprintf (Memc[newval], SZ_LINE, " %10g") + call pargd (O_VALD(pexpr)) + } + op = op + gstrcpy (Memc[newval], Memc[op], + min (SZ_LINE - op + outbuf, strlen (Memc[newval]))) + + # The next user fields are columns. + } else if (Memi[rptr] >= 1 && Memi[rptr+1] <= MAX_NCOLUMNS) { + + # Transform the coordinates if necessary. + if (outcoo != NULL) + call sk_ultran (catcoo, outcoo, tlng, tlat, tlng, + tlat, 1) + + pexpr = NULL + do j = max (1, Memi[rptr]), min (Memi[rptr+1], + DC_NCOLUMNS(dc)), Memi[rptr+2] { + offset1 = Memi[DC_COFFSETS(dc)+j-1] + offset2 = Memi[DC_COFFSETS(dc)+j] + if (outcoo != NULL && offset1 == lngoffset) { + call sprintf (Memc[newval], SZ_LINE, + Memc[EC_ELNGFORMAT(ec)]) + call pargd (tlng) + op = op + gstrcpy (Memc[newval], Memc[op], + min (SZ_LINE - op + outbuf, + strlen (Memc[newval]))) + } else if (outcoo != NULL && offset1 == latoffset) { + call sprintf (Memc[newval], SZ_LINE, + Memc[EC_ELATFORMAT(ec)]) + call pargd (tlat) + op = op + gstrcpy (Memc[newval], Memc[op], + min (SZ_LINE - op + outbuf, + strlen (Memc[newval]))) + } else + op = op + gstrcpy (Memc[DC_RECORD(dc)+offset1-1], + Memc[op], min (SZ_LINE - op + outbuf, + offset2 - offset1)) + } + } + + # Update the expression list pointers. + eptr = eptr + SZ_EXPR + 1 + rptr = rptr + 3 + fptr = fptr + SZ_EFORMATS + 1 + if (pexpr != NULL) + call mfree (pexpr, TY_STRUCT) + } + + # Attach a newline and EOS to the newly formatted line and output + # it. + if (Memc[outbuf] != EOS) { + Memc[op] = '\n' + Memc[op+1] = EOS + if (verbose && out != STDOUT) + call putline (STDOUT, Memc[outbuf]) + if (out != NULL) + call putline (out, Memc[outbuf]) + } + + } + + call sfree (sp) +end + + +# CC_DINIT -- Initialize the ccget data structure. + +pointer procedure cc_dinit (cnames, lngname, latname) + +char cnames[ARB] #I optional list of columm names +char lngname[ARB] #I the ra / longitude column name or number +char latname[ARB] #I the dec / latitude column name or number + +int i, ip, op +pointer dc, cptr +int cc_cnames(), ctotok(), ctoi() +bool streq() + +begin + call calloc (dc, DC_DLENGTH, TY_STRUCT) + + # Define the column names. + call calloc (DC_COLNAMES(dc), MAX_NCOLUMNS * (SZ_COLNAME + 1), TY_CHAR) + Memc[DC_COLNAMES(dc)] = EOS + + ip = 1 + cptr = DC_COLNAMES(dc) + do i = 1, MAX_NCOLUMNS { + op = 1 + if (cc_cnames (cnames, ip, Memc[cptr], SZ_COLNAME) == EOF) { + call sprintf (Memc[cptr], SZ_COLNAME, "c%d") + call pargi (i) + } else if (ctotok (Memc[cptr], op, Memc[cptr], SZ_COLNAME) != + TOK_IDENTIFIER) { + call sprintf (Memc[cptr], SZ_COLNAME, "c%d") + call pargi (i) + } + call strlwr (Memc[cptr]) + cptr = cptr + SZ_COLNAME + 1 + } + + # Find the longitude and latitude columns. + ip = 1 + DC_LNGCOLUMN(dc) = 0 + if (ctoi (lngname, ip, DC_LNGCOLUMN(dc)) <= 0) { + cptr = DC_COLNAMES(dc) + do i = 1, MAX_NCOLUMNS { + if (streq (lngname, Memc[cptr])) { + DC_LNGCOLUMN(dc) = i + break + } + cptr = cptr + SZ_COLNAME + 1 + } + } + if (DC_LNGCOLUMN(dc) <= 0) + DC_LNGCOLUMN(dc) = 2 + + ip = 1 + DC_LATCOLUMN(dc) = 0 + if (ctoi (latname, ip, DC_LATCOLUMN(dc)) <= 0) { + cptr = DC_COLNAMES(dc) + do i = 1, MAX_NCOLUMNS { + if (streq (latname, Memc[cptr])) { + DC_LATCOLUMN(dc) = i + break + } + cptr = cptr + SZ_COLNAME + 1 + } + } + if (DC_LATCOLUMN(dc) <= 0) + DC_LATCOLUMN(dc) = DC_LNGCOLUMN(dc) + 1 + + call calloc (DC_RECORD(dc), SZ_LINE, TY_CHAR) + Memc[DC_RECORD(dc)) = EOS + + call calloc (DC_COFFSETS(dc), MAX_NCOLUMNS + 1, TY_INT) + + return (dc) +end + + +# CC_DFREE -- Free the ccget data structure. + +procedure cc_dfree (dc) + +pointer dc #U pointer to the data structure + +begin + call mfree (DC_COLNAMES(dc), TY_CHAR) + call mfree (DC_RECORD(dc), TY_CHAR) + call mfree (DC_COFFSETS(dc), TY_INT) + call mfree (dc, TY_STRUCT) +end + + +# CC_CNAMES -- Decode the list of column names into individual column names. + +int procedure cc_cnames (colnames, ip, name, maxch) + +char colnames[ARB] #I list of column names +int ip #I pointer into the list of names +char name[ARB] #O the output column name +int maxch #I maximum length of a column name + +int op, token +int ctotok(), strlen() + +begin + # Decode the column labels. + op = 1 + while (colnames[ip] != EOS) { + + token = ctotok (colnames, ip, name[op], maxch) + if (name[op] == EOS) + next + + #if ((token == TOK_UNKNOWN) || (token == TOK_CHARCON)) + #break + + if ((token == TOK_PUNCTUATION) && (name[op] == ',')) { + if (op == 1) + next + else + break + } + + if (token != TOK_IDENTIFIER) { + op = 1 + next + } + + op = op + strlen (name[op]) + if (colnames[ip] == ' ') { + if (op == 1) + next + else + break + } + } + + name[op] = EOS + if ((colnames[ip] == EOS) && (op == 1)) + return (EOF) + else + return (op - 1) +end + + +# CC_EINIT -- Initialize the ccget expression structure. + +pointer procedure cc_einit (exprs, formats, lngformat, latformat) + +char exprs[ARB] #I the input expression list +char formats[ARB] #I the input formats list +char lngformat[ARB] #I the input output ra / longitude format +char latformat[ARB] #I the input output dec / latitude format + +int i, ip, nexpr +pointer ec, cptr, fptr +int cc_enames() + +begin + call calloc (ec, EC_ELENGTH, TY_STRUCT) + + # Define the column names. + call malloc (EC_ELIST(ec), MAX_NEXPR * (SZ_EXPR + 1), TY_CHAR) + Memc[EC_ELIST(ec)] = EOS + + # Create list of expressions. + ip = 1 + cptr = EC_ELIST(ec) + nexpr = 0 + do i = 1, MAX_NEXPR { + if (cc_enames (exprs, ip, Memc[cptr], SZ_EXPR) == EOF) + break + call strlwr (Memc[cptr]) + cptr = cptr + SZ_EXPR + 1 + nexpr = nexpr + 1 + } + EC_NEXPR(ec) = nexpr + + + # Decode the list of expressions into column names, column ranges, + # and column expressions. + call calloc (EC_ERANGES(ec), 3 * MAX_NERANGES + 1, TY_INT) + + call calloc (EC_EFORMATS(ec), MAX_NEXPR * (SZ_EFORMATS + 1), TY_CHAR) + Memc[EC_EFORMATS(ec)] = EOS + ip = 1 + fptr = EC_EFORMATS(ec) + cptr = EC_ELIST(ec) + do i = 1, EC_NEXPR(ec) { + if (cc_enames (formats, ip, Memc[fptr], SZ_EFORMATS) == EOF) + break + fptr = fptr + SZ_EFORMATS + 1 + cptr = cptr + SZ_EXPR + 1 + } + + call calloc (EC_ELNGFORMAT(ec), SZ_EFORMATS, TY_CHAR) + call strcpy (lngformat, Memc[EC_ELNGFORMAT(ec)], SZ_EFORMATS) + call calloc (EC_ELATFORMAT(ec), SZ_EFORMATS, TY_CHAR) + call strcpy (latformat, Memc[EC_ELATFORMAT(ec)], SZ_EFORMATS) + + return (ec) +end + + +# CC_EFREE -- Free the ccget expression structure. + +procedure cc_efree (ec) + +pointer ec #U pointer to the expression structure + +begin + call mfree (EC_ELIST(ec), TY_CHAR) + call mfree (EC_ERANGES(ec), TY_INT) + call mfree (EC_EFORMATS(ec), TY_CHAR) + call mfree (EC_ELNGFORMAT(ec), TY_CHAR) + call mfree (EC_ELATFORMAT(ec), TY_CHAR) + call mfree (ec, TY_STRUCT) +end + + +# CC_ENAMES -- Decode the list of expressions into individual expressions. + +int procedure cc_enames (exprs, ip, name, maxch) + +char exprs[ARB] #I list of expressions +int ip #I pointer into the list of names +char name[ARB] #O the output column name +int maxch #I maximum length of a column name + +int op, token +int ctotok(), strlen() + +begin + # Decode the column labels. + op = 1 + while (exprs[ip] != EOS) { + + token = ctotok (exprs, ip, name[op], maxch) + if (name[op] == EOS) + next + + if ((token == TOK_PUNCTUATION) && (name[op] == ',')) { + if (op == 1) + next + else + break + } + + + op = op + strlen (name[op]) + } + + name[op] = EOS + if ((exprs[ip] == EOS) && (op == 1)) + return (EOF) + else + return (op - 1) +end + + +# CC_EDECODE -- Decode the expression list. + +procedure cc_edecode (dc, ec) + +pointer dc #I the pointer to the data structure +pointer ec #I the pointer to the expression structure + +int i, j, ip1, ip2, c1, c2, lindex, rindex, column +pointer sp, ename, eptr, cptr, rptr +char lbracket, rbracket +int ctotok(), strldx(), ctoi() +bool streq() + +begin + call smark (sp) + call salloc (ename, SZ_EXPR, TY_CHAR) + + # Initialize. + lbracket = '[' + rbracket = ']' + eptr = EC_ELIST(ec) + rptr = EC_ERANGES(ec) + + do i = 1, EC_NEXPR(ec) { + + ip1 = 1 + lindex = strldx (lbracket, Memc[eptr]) + rindex = strldx (rbracket, Memc[eptr]) + ip2 = lindex + 1 + if (Memc[eptr] == 'c' && lindex == 2 && rindex > lindex) { + if (Memc[eptr+lindex] == '*') { + c1 = 1 + c2 = MAX_NCOLUMNS + } else { + if (ctoi (Memc[eptr], ip2, c1) <= 0) + c1 = 0 + else if (c1 < 1 || c1 > MAX_NCOLUMNS) + c1 = 0 + if (ctoi (Memc[eptr], ip2, c2) <= 0) + c2 = 0 + else + c2 = -c2 + if (c2 < 1 || c2 > MAX_NCOLUMNS) + c2 = 0 + } + + if (c1 > 0 && c2 > c1) { + Memi[rptr] = c1 + Memi[rptr+1] = c2 + Memi[rptr+2] = 1 + } + } else if (ctotok (Memc[eptr], ip1, Memc[ename], SZ_EXPR) == + TOK_IDENTIFIER) { + cptr = DC_COLNAMES(dc) + column = 0 + do j = 1, MAX_NCOLUMNS { + if (streq (Memc[eptr], Memc[cptr])) { + column = j + break + } + cptr = cptr + SZ_COLNAME + 1 + } + if (column > 0) { + Memi[rptr] = j + Memi[rptr+1] = j + Memi[rptr+2] = 1 + } else if (ctotok (Memc[eptr], ip1, Memc[ename], SZ_EXPR) != + EOS) { + Memi[rptr] = INDEFI + Memi[rptr+1] = INDEFI + Memi[rptr+2] = INDEFI + } + } else { + Memi[rptr] = INDEFI + Memi[rptr+1] = INDEFI + Memi[rptr+2] = INDEFI + } + eptr = eptr + SZ_EXPR + 1 + rptr = rptr + 3 + } + + call sfree (sp) +end + + +# CC_GETOP -- Fetch an operand from the data structure. + +procedure cc_getop (dc, operand, o) + +pointer dc #I pointer to the data structure +char operand[ARB] #I name of operand to be returned +pointer o #I pointer to output operand + +int ip, column, offset, csize, type, nchars +pointer cptr +bool streq() +int lexnum(), ctod(), ctoi() + +begin + # Find the symbol. + cptr = DC_COLNAMES(dc) + column = 0 + do ip = 1, MAX_NCOLUMNS { + if (streq (operand, Memc[cptr])) { + column = ip + break + } + cptr = cptr + SZ_COLNAME + 1 + } + if (column <= 0) + call xvv_error1 ("Column '%s' not found", operand[1]) + + # Find column pointer. + offset = Memi[DC_COFFSETS(dc)+column-1] + csize = Memi[DC_COFFSETS(dc)+column] - offset + cptr = DC_RECORD(dc)+offset-1 + + # Determine the type of the symbol. + ip = 1 + type = lexnum (Memc[cptr], ip, nchars) + #if (Memc[cptr+nchars+ip-1] != EOS) + #type = LEX_NONNUM + + # Decode the symbol. + switch (type) { + case LEX_OCTAL, LEX_DECIMAL, LEX_HEX: + call xvv_initop (o, 0, TY_INT) + ip = 1 + nchars = ctoi (Memc[cptr], ip, O_VALI(o)) + case LEX_REAL: + call xvv_initop (o, 0, TY_DOUBLE) + ip = 1 + nchars = ctod (Memc[cptr], ip, O_VALD(o)) + case LEX_NONNUM: + call xvv_initop (o, csize, TY_CHAR) + call strcpy (Memc[cptr], O_VALC(o), csize) + } +end diff --git a/pkg/images/imcoords/src/t_ccmap.x b/pkg/images/imcoords/src/t_ccmap.x new file mode 100644 index 00000000..969438be --- /dev/null +++ b/pkg/images/imcoords/src/t_ccmap.x @@ -0,0 +1,2079 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <fset.h> +include <ctype.h> +include <math.h> +include <math/gsurfit.h> +include <imhdr.h> +include <pkg/skywcs.h> +include "../../lib/geomap.h" + +# Define the source of the reference point. +define CC_REFPOINTSTR "|coords|user|tweak|" +define CC_COORDS 1 +define CC_USER 2 +define CC_TWEAK 3 + +# Define the possible pixel types. +define CC_PIXTYPESTR "|logical|physical|" +define CC_LOGICAL 1 +define CC_PHYSICAL 2 + +# Define some limits on the input file +define MAX_FIELDS 100 # the max number of fields in the list +define TABSIZE 8 # the spacing of the tab stops + +# Define the default data buffer size +define CC_DEFBUFSIZE 1000 # the default buffer size + +# T_CCMAP -- Compute the linear portion of the transformation required +# to convert image x and y coordinates to ra / longitude and dec / latitude +# coordinates. This version allows combining multiple inputs with different +# tangent points (as in a dither set) to create a single solution. + +procedure t_ccmap () + +pointer in, im, tdxref, tdyref, tdlngref, tdlatref +pointer sp, infile, image, database, insystem, refsystem, str +pointer xref, yref, lngref, latref +pointer graphics, coo, refcoo, tcoo, mw, fit, out, gd, projstr +double dxref, dyref, dlngref, dlatref, xmin, xmax, ymin, ymax, reject +int i, inlist, ninfiles, nin, imlist, nimages, coostat, refstat, nchars, ip +int xreflist, yreflist, lngreflist, latreflist +int xcolumn, ycolumn, lngcolumn, latcolumn, lngunits, latunits, res, pfd +int lngrefunits, latrefunits, refpoint_type, tweak, projection +int reslist, nresfiles +int geometry, function, xxorder, xyorder, xxterms, yxorder, yyorder, yxterms +int reclist, nrecords, pixsys, maxiter +bool verbose, update, interactive + +double clgetd() +pointer dtmap(), immap(), gopen(), cc_utan(), cc_imtan() +int clpopnu(), clplen(), imtopenp(), imtlen(), clgeti(), clgwrd(), strlen() +int sk_decwcs(), sk_stati(), imtgetim(), clgfil(), open(), ctod() +int errget(), imtopen(), strncmp(), cc_rdproj(), strdic() +bool clgetb() +errchk open(), cc_map() + +begin + # Get some working space. + call smark (sp) + call salloc (infile, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (database, SZ_FNAME, TY_CHAR) + call salloc (insystem, SZ_FNAME, TY_CHAR) + call salloc (xref, SZ_FNAME, TY_CHAR) + call salloc (yref, SZ_FNAME, TY_CHAR) + call salloc (lngref, SZ_FNAME, TY_CHAR) + call salloc (latref, SZ_FNAME, TY_CHAR) + call salloc (refsystem, SZ_FNAME, TY_CHAR) + call salloc (graphics, SZ_FNAME, TY_CHAR) + call salloc (projstr, SZ_LINE, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Get the input data file list. + inlist = clpopnu ("input") + ninfiles = clplen (inlist) + if (ninfiles <= 0) { + call eprintf ("Error: The input coordinate file list is empty\n") + call clpcls (inlist) + call sfree (sp) + return + } + + # Open the database output file. + call clgstr ("database", Memc[database], SZ_FNAME) + out = dtmap (Memc[database], APPEND) + + # Open the record list. + call clgstr ("solutions", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) { + reclist = NULL + nrecords = 0 + } else { + reclist = imtopen (Memc[str]) + nrecords = imtlen (reclist) + } + if (nrecords > 1 && nrecords != ninfiles) { + call eprintf ("Error: List of record names does not match input\n") + call clpcls (inlist) + call dtunmap (out) + if (reclist != NULL) + call imtclose (reclist) + call sfree (sp) + return + } + + # Get the input image list. + imlist = imtopenp ("images") + nimages = imtlen (imlist) + if (nimages > 1 && nimages != ninfiles) { + call eprintf ("Error: Coordinate files and images don't match\n") + call imtclose (imlist) + call clpcls (inlist) + call dtunmap (out) + if (reclist != NULL) + call imtclose (reclist) + call sfree (sp) + return + } + + # Get the output results lists. + reslist = clpopnu ("results") + nresfiles = clplen (reslist) + if (nresfiles > 1 && nresfiles != ninfiles) { + call eprintf ("Error: List of results files does not match input\n") + call imtclose (imlist) + call clpcls (inlist) + call clpcls (reslist) + call dtunmap (out) + if (reclist != NULL) + call imtclose (reclist) + call sfree (sp) + return + } + + # Get the coordinates file format. + xcolumn = clgeti ("xcolumn") + ycolumn = clgeti ("ycolumn") + lngcolumn = clgeti ("lngcolumn") + latcolumn = clgeti ("latcolumn") + call clgstr ("insystem", Memc[insystem], SZ_FNAME) + iferr (lngunits = clgwrd ("lngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + lngunits = 0 + iferr (latunits = clgwrd ("latunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + latunits = 0 + + # Get the reference point parameters. + refpoint_type = clgwrd ("refpoint", Memc[str], SZ_FNAME, + CC_REFPOINTSTR) + tweak = refpoint_type + xreflist = clpopnu ("xref") + yreflist = clpopnu ("yref") + lngreflist = clpopnu ("lngref") + latreflist = clpopnu ("latref") + call clgstr ("refsystem", Memc[refsystem], SZ_FNAME) + if (strncmp (Memc[refsystem], "INDEF", 5) == 0) + Memc[refsystem] = EOS + iferr (lngrefunits = clgwrd ("lngrefunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + lngrefunits = 0 + iferr (latrefunits = clgwrd ("latrefunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + latrefunits = 0 + + # Get the minimum and maximum reference values. + xmin = clgetd ("xmin") + xmax = clgetd ("xmax") + ymin = clgetd ("ymin") + ymax = clgetd ("ymax") + + # Get the coordinate mapping parameters. + call clgstr ("projection", Memc[str], SZ_LINE) + iferr { + pfd = open (Memc[str], READ_ONLY, TEXT_FILE) + } then { + projection = strdic (Memc[str], Memc[str], SZ_LINE, GM_PROJLIST) + if (projection <= 0 || projection == WTYPE_LIN) + Memc[projstr] = EOS + else + call strcpy (Memc[str], Memc[projstr], SZ_LINE) + } else { + projection = cc_rdproj (pfd, Memc[projstr], SZ_LINE) + call close (pfd) + } + 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") + + # Get the input and output parameters. + update = clgetb ("update") + iferr (pixsys = clgwrd ("pixsystem", Memc[str], SZ_FNAME, + CC_PIXTYPESTR)) + pixsys = PIXTYPE_LOGICAL + else if (pixsys == CC_PHYSICAL) + pixsys = PIXTYPE_PHYSICAL + else + pixsys = PIXTYPE_LOGICAL + verbose = clgetb ("verbose") + + # Open the input coordinate system. + coostat = sk_decwcs (Memc[insystem], mw, coo, NULL) + if (coostat == ERR || mw != NULL) { + call eprintf ("Error: Cannot decode the input coordinate system\n") + if (mw != NULL) + call mw_close (mw) + call imtclose (imlist) + call clpcls (inlist) + call clpcls (reslist) + call dtunmap (out) + call sfree (sp) + return + } + + # Determine the units of the input coordinate system. + if (lngunits <= 0) + lngunits = sk_stati (coo, S_NLNGUNITS) + call sk_seti (coo, S_NLNGUNITS, lngunits) + if (latunits <= 0) + latunits = sk_stati (coo, S_NLATUNITS) + call sk_seti (coo, S_NLATUNITS, latunits) + call sk_seti (coo, S_PIXTYPE, pixsys) + + # Set default reference coordinate. + Memc[xref] = EOS + Memc[yref] = EOS + Memc[lngref] = EOS + Memc[latref] = EOS + + # Open the reference coordinate system if possible. + refstat = sk_decwcs (Memc[refsystem], mw, refcoo, NULL) + if (refstat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + refcoo = NULL + if (lngrefunits <= 0) + lngrefunits = sk_stati (coo, S_NLNGUNITS) + if (latrefunits <= 0) + latrefunits = sk_stati (coo, S_NLATUNITS) + } else { + if (lngrefunits <= 0) + lngrefunits = sk_stati (refcoo, S_NLNGUNITS) + call sk_seti (refcoo, S_NLNGUNITS, lngrefunits) + if (latrefunits <= 0) + latrefunits = sk_stati (refcoo, S_NLATUNITS) + call sk_seti (refcoo, S_NLATUNITS, latrefunits) + } + + # Get the graphics parameters. + interactive = clgetb ("interactive") + call clgstr ("graphics", Memc[graphics], SZ_FNAME) + + # Flush standard output on newline. + call fseti (STDOUT, F_FLUSHNL, YES) + + # Initialize the coordinate mapping structure. + call geo_minit (fit, projection, geometry, function, xxorder, xyorder, + xxterms, yxorder, yyorder, yxterms, maxiter, reject) + call strcpy (Memc[projstr], GM_PROJSTR(fit), SZ_LINE) + + # Process the input. + call calloc (in, ninfiles, TY_INT) + call calloc (im, ninfiles, TY_POINTER) + call calloc (tdxref, ninfiles, TY_DOUBLE) + call calloc (tdyref, ninfiles, TY_DOUBLE) + call calloc (tdlngref, ninfiles, TY_DOUBLE) + call calloc (tdlatref, ninfiles, TY_DOUBLE) + call amovkd (INDEFD, Memd[tdxref], ninfiles) + call amovkd (INDEFD, Memd[tdyref], ninfiles) + call amovkd (INDEFD, Memd[tdlngref], ninfiles) + call amovkd (INDEFD, Memd[tdlatref], ninfiles) + + # Loop over the files. This is a little messy in order to allow + # both the case where all inputs are combined or separately done. + repeat { + + nin = 0 + while (clgfil (inlist, Memc[infile], SZ_FNAME) != EOF) { + + # Open text file of coordinates. + Memi[in+nin] = open (Memc[infile], READ_ONLY, TEXT_FILE) + + # Open the input image. + if (nimages > 0) { + if (imtgetim (imlist, Memc[image], SZ_FNAME) == EOF) { + Memi[im+nin] = NULL + } else if (update) { + Memi[im+nin] = immap (Memc[image], READ_WRITE, 0) + } else { + Memi[im+nin] = immap (Memc[image], READ_ONLY, 0) + } + if (Memi[im+nin] != NULL) { + if (IM_NDIM(Memi[im+nin]) != 2) { + call printf ("Skipping file: %s Image: %s is not 2D\n") + call pargstr (Memc[infile]) + call pargstr (Memc[image]) + call imunmap (Memi[im+nin]) + next + } + } else + Memc[image] = EOS + } else { + Memi[im+nin] = NULL + Memc[image] = EOS + } + + if (nin == 0) { + + # Open the results file. + if (nresfiles <= 0) + res = NULL + else if (clgfil (reslist, Memc[str], SZ_FNAME) != EOF) + res = open (Memc[str], NEW_FILE, TEXT_FILE) + else + res = NULL + + # Set the output file record name. + if (nrecords > 0) { + if (imtgetim (reclist, GM_RECORD(fit), SZ_FNAME) != EOF) + ; + } else if (Memi[im] == NULL) { + call strcpy (Memc[infile], GM_RECORD(fit), SZ_FNAME) + } else { + #call imgimage (Memc[image], Memc[str], SZ_FNAME) + call strcpy (Memc[image], GM_RECORD(fit), SZ_FNAME) + } + } + + # Determine the coordinates of the reference point if possible. + if (clgfil (xreflist, Memc[xref], SZ_FNAME) == EOF) + ; + if (clgfil (yreflist, Memc[yref], SZ_FNAME) == EOF) + ; + if (clgfil (lngreflist, Memc[lngref], SZ_FNAME) == EOF) + ; + if (clgfil (latreflist, Memc[latref], SZ_FNAME) == EOF) + ; + ip = 1 + nchars = ctod (Memc[xref], ip, dxref) + if (nchars <= 0 || nchars != strlen (Memc[xref])) + dxref = INDEFD + ip = 1 + nchars = ctod (Memc[yref], ip, dyref) + if (nchars <= 0 || nchars != strlen (Memc[yref])) + dyref = INDEFD + ip = 1 + nchars = ctod (Memc[lngref], ip, dlngref) + if (nchars <= 0 || nchars != strlen (Memc[lngref])) + dlngref = INDEFD + if (dlngref < 0.0d0 || dlngref > 360.0d0) + dlngref = INDEFD + ip = 1 + nchars = ctod (Memc[latref], ip, dlatref) + if (nchars <= 0 || nchars != strlen (Memc[latref])) + dlatref = INDEFD + if (dlatref < -90.0d0 || dlatref > 90.0d0) + dlatref = INDEFD + + Memd[tdxref+nin] = dxref + Memd[tdyref+nin] = dyref + Memd[tdlngref+nin] = dlngref + Memd[tdlatref+nin] = dlatref + + # Determine the tangent points and convert them to the + # celestial coordinate system of the input data, + + # The tangent point will be determined directly from + # the input coordinates. + if (refpoint_type == CC_COORDS) { + + if (nin == 0) { + if (verbose && res != STDOUT) + call sk_iiprint ("Refsystem", Memc[insystem], + NULL, coo) + if (res != NULL) + call sk_iiwrite (res, "Refsystem", Memc[insystem], + NULL, coo) + } + Memd[tdxref+nin] = INDEFD + Memd[tdyref+nin] = INDEFD + Memd[tdlngref+nin] = INDEFD + Memd[tdlatref+nin] = INDEFD + + # The tangent point was set by the user and a tangent point + # reference system may or may not have been defined. + } else if (! IS_INDEFD(dlngref) && ! IS_INDEFD (dlatref)) { + + tcoo = cc_utan (refcoo, coo, dxref, dyref, dlngref, dlatref, + Memd[tdlngref+nin], Memd[tdlatref+nin], + lngrefunits, latrefunits) + call sk_stats (tcoo, S_COOSYSTEM, Memc[str], SZ_FNAME) + if (nin == 0) { + if (verbose && res != STDOUT) + call sk_iiprint ("Refsystem", Memc[str], NULL, tcoo) + if (res != NULL) + call sk_iiwrite (res, "Refsystem", Memc[str], + NULL, tcoo) + call sk_close (tcoo) + } + + } else if (Memi[im+nin] != NULL) { + + tcoo = cc_imtan (Memi[im+nin], Memc[xref], Memc[yref], + Memc[lngref], Memc[latref], Memc[refsystem], + refcoo, coo, Memd[tdxref+nin], Memd[tdyref+nin], + Memd[tdlngref+nin], Memd[tdlatref+nin], + lngrefunits, latrefunits) + call sk_stats (tcoo, S_COOSYSTEM, Memc[str], SZ_FNAME) + if (nin == 0) { + if (verbose && res != STDOUT) + call sk_iiprint ("Refsystem", Memc[str], NULL, tcoo) + if (res != NULL) + call sk_iiwrite (res, "Refsystem", Memc[str], + NULL, tcoo) + call sk_close (tcoo) + } + + # The tangent point will be determined directly from + # the input coordinates. + } else { + + if (nin == 0) { + if (verbose && res != STDOUT) + call sk_iiprint ("Refsystem", Memc[insystem], + NULL, coo) + if (res != NULL) + call sk_iiwrite (res, "Refsystem", Memc[insystem], + NULL, coo) + } + Memd[tdxref+nin] = INDEFD + Memd[tdyref+nin] = INDEFD + Memd[tdlngref+nin] = INDEFD + Memd[tdlatref+nin] = INDEFD + + } + + if (nin == 0) { + # Print information about the input coordinate system. + if (verbose && res != STDOUT) + call sk_iiprint ("Insystem", Memc[insystem], NULL, coo) + if (res != NULL) + call sk_iiwrite (res, "Insystem", Memc[insystem], + NULL, coo) + } + + # Print the input and out file information. + if (verbose && res != STDOUT) { + call printf ("\nCoords File: %s Image: %s\n") + call pargstr (Memc[infile]) + call pargstr (Memc[image]) + call printf (" Database: %s Solution: %s\n") + call pargstr (Memc[database]) + call pargstr (GM_RECORD(fit)) + } + if (res != NULL) { + call fprintf (res, "\n# Coords File: %s Image: %s\n") + call pargstr (Memc[infile]) + call pargstr (Memc[image]) + call fprintf (res, "# Database: %s Solution: %s\n") + call pargstr (Memc[database]) + call pargstr (GM_RECORD(fit)) + } + + nin = nin + 1 + if (nrecords > 1 || nresfiles > 1) + break + } + if (nin == 0) + break + + iferr { + if (interactive) + gd = gopen (Memc[graphics], NEW_FILE, STDGRAPH) + else + gd = NULL + call cc_map (gd, nin, Memi[in], out, Memi[im], res, coo, fit, + xcolumn, ycolumn, lngcolumn, latcolumn, tweak, + Memd[tdxref], Memd[tdyref], Memd[tdlngref], Memd[tdlatref], + xmin, xmax, ymin, ymax, update, verbose) + if (gd != NULL) + call gclose (gd) + } then { + if (verbose && res != STDOUT) { + if (nin == 1) { + call printf ("Error fitting coordinate list: %s\n") + call pargstr (Memc[infile]) + } else + call printf ("Error fitting coordinate lists\n") + call flush (STDOUT) + Memc[str] = EOS + if (errget (Memc[str], SZ_LINE) == 0) + ; + call printf (" %s\n") + call pargstr (Memc[str]) + } + if (res != NULL) { + if (nin == 1) { + call fprintf (res, + "# Error fitting coordinate list: %s\n") + call pargstr (Memc[infile]) + } else + call fprintf (res, + "# Error fitting coordinate lists\n") + call flush (STDOUT) + if (errget (Memc[str], SZ_LINE) == 0) + ; + call fprintf (res, "# %s\n") + call pargstr (Memc[str]) + } + if (gd != NULL) + call gclose (gd) + } + + + if (nresfiles == ninfiles) + call close (res) + do i = 1, nin { + call close (Memi[in+i-1]) + if (Memi[im+i-1] != NULL) + call imunmap (Memi[im+i-1]) + } + } + + call mfree (in, TY_INT) + call mfree (im, TY_POINTER) + call mfree (tdxref, TY_DOUBLE) + call mfree (tdyref, TY_DOUBLE) + call mfree (tdlngref, TY_DOUBLE) + call mfree (tdlatref, TY_DOUBLE) + + call geo_free (fit) + call sk_close (coo) + call clpcls (xreflist) + call clpcls (yreflist) + call clpcls (latreflist) + call clpcls (lngreflist) + if (nresfiles < ninfiles) + call close (res) + call dtunmap (out) + if (reclist != NULL) + call imtclose (reclist) + call imtclose (imlist) + call clpcls (inlist) + call clpcls (reslist) + call sfree (sp) +end + + +# CC_UTAN -- Convert the user defined tangent point from the reference +# point celestial coordinate system to the input coordinate celestial +# coordinate system. + +pointer procedure cc_utan (refcoo, coo, idxref, idyref, idlngref, idlatref, odlngref, odlatref, + lngrefunits, latrefunits) + +pointer refcoo #I pointer to the reference point system +pointer coo #I pointer to the input coordinate system +double idxref #I the input x reference point +double idyref #I the input y reference point +double idlngref #I the input reference point ra / longitude +double idlatref #I the input reference point dec / latitude +double odxref #O the output x reference point +double odyref #O the output y reference point +double odlngref #O the output reference point ra / longitude +double odlatref #O the output reference point dec / latitude +int lngrefunits #I the input reference ra / longitude units +int latrefunits #I the input reference dec / latitude units + +pointer trefcoo +pointer sk_copy() + +begin + odxref = idxref + odyref = idyref + if (refcoo != NULL) { + trefcoo = sk_copy (refcoo) + } else { + trefcoo = sk_copy (coo) + call sk_seti (trefcoo, S_NLNGUNITS, lngrefunits) + call sk_seti (trefcoo, S_NLATUNITS, latrefunits) + } + call sk_ultran (trefcoo, coo, idlngref, idlatref, odlngref, odlatref, 1) + + return (trefcoo) +end + + +# CC_IMTAN -- Read the tangent point from the image and convert it from the +# reference point celestial coordinate system to the input coordinate celestial +# coordinate system. + +pointer procedure cc_imtan (im, xref, yref, lngref, latref, refsystem, refcoo, + coo, odxref, odyref, odlngref, odlatref, lngrefunits, latrefunits) + +pointer im #I pointer to the input image +char xref[ARB] #I the x reference keyword +char yref[ARB] #I the y reference keyword +char lngref[ARB] #I the ra / longitude keyword +char latref[ARB] #I the dec / latitude keyword +char refsystem[ARB] #I the reference point coordinate system +pointer refcoo #I pointer to the reference point system +pointer coo #I pointer to the input coordinate system +double odxref #O the output x reference point +double odyref #O the output y reference point +double odlngref #O the output reference point ra / longitude +double odlatref #O the output reference point dec / latitude +int lngrefunits #I the input reference ra / longitude units +int latrefunits #I the input reference dec / latitude units + +double idxref, idyref, idlngref, idlatref, idepoch +pointer sp, str, tcoo, mw +double imgetd() +pointer sk_copy() +int sk_decwcs() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + iferr (idxref = imgetd (im, xref)) + idxref = INDEFD + iferr (idyref = imgetd (im, yref)) + idyref = INDEFD + iferr (idlngref = imgetd (im, lngref)) + idlngref = INDEFD + if (idlngref < 0.0d0 || idlngref > 360.0d0) + idlngref = INDEFD + iferr (idlatref = imgetd (im, latref)) + idlatref = INDEFD + if (idlatref < -90.0d0 || idlatref > 90.0d0) + idlatref = INDEFD + + if (!IS_INDEFD(idxref)) + odxref = idxref + if (!IS_INDEFD(idyref)) + odyref = idyref + + if (IS_INDEFD(idlngref) || IS_INDEFD(idlatref)) + tcoo = sk_copy (coo) + else if (refcoo != NULL) { + tcoo = sk_copy (refcoo) + call sk_ultran (tcoo, coo, idlngref, idlatref, odlngref, + odlatref, 1) + } else { + iferr (idepoch = imgetd (im, refsystem)) + idepoch = INDEFD + if (IS_INDEFD(idepoch)) + tcoo = sk_copy (coo) + else { + call sprintf (Memc[str], SZ_FNAME, "fk4 b%g") + call pargd (idepoch) + if (sk_decwcs (Memc[str], mw, tcoo, NULL) == ERR) { + call sk_close (tcoo) + tcoo = sk_copy (coo) + } + if (mw != NULL) + call mw_close (mw) + } + call sk_seti (tcoo, S_NLNGUNITS, lngrefunits) + call sk_seti (tcoo, S_NLATUNITS, latrefunits) + call sk_ultran (tcoo, coo, idlngref, idlatref, odlngref, + odlatref, 1) + } + + call sfree (sp) + + return (tcoo) +end + + +# CC_MAP -- Compute the required coordinate transformation. +# +# This version uses the nin variable. + +procedure cc_map (gd, nin, in, out, im, res, coo, fit, + xcolumn, ycolumn, lngcolumn, latcolumn, tweak, + xtan, ytan, ratan, dectan, + xmin, xmax, ymin, ymax, update, verbose) + +pointer gd #I graphics stream pointer +int nin #I number of input files +int in[ARB] #I the input file descriptors +pointer out #I the output file descriptor +pointer im[ARB] #I the input image pointers +int res #I the results file descriptor +pointer coo # pointer to the input coordinate system +pointer fit #I pointer to fit parameters +int xcolumn, ycolumn #I the x and y column numbers +int lngcolumn, latcolumn #I the longitude and latitude column numbers +int tweak #I tweak flag +double xtan[ARB], ytan[ARB] #I the input x and y of the tangent point +double ratan[ARB], dectan[ARB] #I the input ra and dec of the tangent point +double xmin, xmax #I max and min xref values +double ymin, ymax #I max and min yref values +bool update #I update the image wcs +bool verbose #I verbose mode + +double mintemp, maxtemp, lngrms, latrms, lngmean, latmean +pointer sp, str, projstr +pointer n, xref, yref, xifit, etafit, lngfit, latfit, wts +pointer lngref, latref, xi, eta, lngref1, latref1, xi1, eta1 +pointer sx1, sy1, sx2, sy2, xerrmsg, yerrmsg +int i, npts, npts1 +double asumd() +int cc_rdxyrd(), sk_stati(), rg_wrdstr() +bool streq() + +errchk geo_fitd, geo_mgfitd() + +begin + # Get working space. + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (projstr, SZ_LINE, TY_CHAR) + call salloc (xerrmsg, SZ_LINE, TY_CHAR) + call salloc (yerrmsg, SZ_LINE, TY_CHAR) + + # Initialize the pointers. + xref = NULL + yref = NULL + lngref = NULL + latref = NULL + xi = NULL + eta = NULL + xifit = NULL + etafit = NULL + lngfit = NULL + latfit = NULL + wts = NULL + + # Read in data and check that it is in range. + if (gd != NULL) + call gdeactivate (gd, 0) + npts = cc_rdxyrd (in, im, xtan, ytan, ratan, dectan, nin, + coo, xcolumn, ycolumn, lngcolumn, latcolumn, tweak, + n, xref, yref, lngref, latref, xmin, xmax, ymin, ymax) + if (gd != NULL) + call greactivate (gd, 0) + if (npts == 0) + return + + # Compute the mean of the reference and input coordinates. + GM_XOREF(fit) = asumd (Memd[xref], npts) / npts + GM_YOREF(fit) = asumd (Memd[yref], npts) / npts + GM_XOIN(fit) = asumd (Memd[lngref], npts) / npts + GM_YOIN(fit) = asumd (Memd[latref], npts) / npts + + # Set the sky projection str. + if (rg_wrdstr (GM_PROJECTION(fit), Memc[projstr], SZ_LINE, + GM_PROJLIST) <= 0 || GM_PROJECTION(fit) == GM_LIN) + Memc[projstr] = EOS + else + call strcpy (GM_PROJSTR(fit), Memc[projstr], SZ_LINE) + + # Compute the position of the reference point for the solution. + if (IS_INDEFD(ratan[1]) || IS_INDEFD(dectan[1])) { + call cc_refpt (coo, Memd[lngref], Memd[latref], npts, + lngmean, latmean) + if (IS_INDEFD(ratan[1])) + GM_XREFPT(fit) = lngmean + else + GM_XREFPT(fit) = ratan[1] + if (IS_INDEFD(dectan[1])) + GM_YREFPT(fit) = latmean + else + GM_YREFPT(fit) = dectan[1] + } else { + GM_XREFPT(fit) = ratan[1] + GM_YREFPT(fit) = dectan[1] + } + + # Allocate space for and compute the weights. + 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) = xmin + else + GM_XMIN(fit) = mintemp + if (! IS_INDEFD(xmax)) + GM_XMAX(fit) = xmax + else + GM_XMAX(fit) = maxtemp + } else { + GM_XMIN(fit) = xmin + GM_XMAX(fit) = 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) = ymin + else + GM_YMIN(fit) = mintemp + if (! IS_INDEFD(ymax)) + GM_YMAX(fit) = ymax + else + GM_YMAX(fit) = maxtemp + } else { + GM_YMIN(fit) = ymin + GM_YMAX(fit) = ymax + } + + # Convert the ra / longitude and dec / latitude values to standard + # coordinates in arc seconds before fitting. + call malloc (xi, npts, TY_DOUBLE) + call malloc (eta, npts, TY_DOUBLE) + lngref1 = lngref; latref1 = latref; xi1 = xi; eta1 = eta + do i = 1, nin { + npts1 = Memi[n+i-1] + if (npts1 == 0) + next + if (IS_INDEFD(ratan[i]) || IS_INDEFD(dectan[i])) + call rg_celtostd (Memc[projstr], Memd[lngref1], Memd[latref1], + Memd[xi1], Memd[eta1], npts1, lngmean, latmean, + sk_stati(coo, S_NLNGUNITS), sk_stati(coo, S_NLATUNITS)) + else + call rg_celtostd (Memc[projstr], Memd[lngref1], Memd[latref1], + Memd[xi1], Memd[eta1], npts1, ratan[i], dectan[i], + sk_stati(coo, S_NLNGUNITS), sk_stati(coo, S_NLATUNITS)) + lngref1 = lngref1 + npts1 + latref1 = latref1 + npts1 + xi1 = xi1 + npts1 + eta1 = eta1 + npts1 + } + call amulkd (Memd[xi], 3600.0d0, Memd[xi], npts) + call amulkd (Memd[eta], 3600.0d0, Memd[eta], npts) + + # Initalize surface pointers. + sx1 = NULL + sy1 = NULL + sx2 = NULL + sy2 = NULL + + # Fit the data. + if (! (IS_INDEFD(xtan[1]) || IS_INDEFD(ytan[1]))) { + call geo_setd (fit, GMXO, xtan[1]) + call geo_setd (fit, GMYO, ytan[1]) + call geo_setd (fit, GMXOREF, 0D0) + call geo_setd (fit, GMYOREF, 0D0) + } + if (gd != NULL) { + iferr { + call geo_mgfitd (gd, fit, sx1, sy1, sx2, sy2, Memd[xref], + Memd[yref], Memd[xi], Memd[eta], Memd[wts], npts, + Memc[xerrmsg], Memc[yerrmsg], SZ_LINE) + } then { + call gdeactivate (gd, 0) + call mfree (xi, TY_DOUBLE) + call mfree (eta, TY_DOUBLE) + call mfree (wts, TY_DOUBLE) + call geo_mmfreed (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few data points in XI or ETA 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[xi], Memd[eta], Memd[wts], npts, Memc[xerrmsg], + Memc[yerrmsg], SZ_LINE) + } then { + #call printf ("%s %s\n") + #call pargstr (Memc[xerrmsg]) + #call pargstr (Memc[yerrmsg]) + #call flush (STDOUT) + call mfree (xi, TY_DOUBLE) + call mfree (eta, TY_DOUBLE) + call mfree (wts, TY_DOUBLE) + call geo_mmfreed (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few data points in XI or ETA 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]) + } + } + + # Allocate fitting arrays. + call malloc (xifit, npts, TY_DOUBLE) + call malloc (etafit, npts, TY_DOUBLE) + call malloc (lngfit, npts, TY_DOUBLE) + call malloc (latfit, npts, TY_DOUBLE) + + # Compute the fitted ra / dec or longitude latitude, + if (res != NULL || verbose) { + call cc_eval (sx1, sy1, sx2, sy2, Memd[xref], Memd[yref], + Memd[xifit], Memd[etafit], npts) + call cc_rms (fit, Memd[xi], Memd[eta], Memd[xifit], Memd[etafit], + Memd[wts], npts, lngrms, latrms) + call adivkd (Memd[xifit], 3600.0d0, Memd[xifit], npts) + call adivkd (Memd[etafit], 3600.0d0, Memd[etafit], npts) + call rg_stdtocel (Memc[projstr], Memd[xifit], Memd[etafit], + Memd[lngfit], Memd[latfit], npts, GM_XREFPT(fit), + GM_YREFPT(fit), sk_stati(coo, S_NLNGUNITS), sk_stati(coo, + S_NLATUNITS)) + } + + # Print some detailed info about the fit. + if (verbose && res != STDOUT) { + call printf ( + " Ra/Dec or Long/Lat fit rms: %0.3g %0.3g (arcsec arcsec)\n") + call pargd (lngrms) + call pargd (latrms) + call cc_show (STDOUT, coo, Memc[projstr], GM_XREFPT(fit), + GM_YREFPT(fit), sx1, sy1, NO) + } + if (res != NULL) { + call fprintf (res, + "# Ra/Dec or Long/Lat fit rms: %0.3g %0.3g (arcsec arcsec)\n") + call pargd (lngrms) + call pargd (latrms) + call cc_show (res, coo, Memc[projstr], GM_XREFPT(fit), + GM_YREFPT(fit), sx1, sy1, YES) + } + + # Compute the wcs mapping rms. + if (! streq (GM_PROJSTR(fit), "tnx") && ! streq (GM_PROJSTR(fit), + "zpx")) { + call cc_eval (sx1, sy1, NULL, NULL, Memd[xref], Memd[yref], + Memd[xifit], Memd[etafit], npts) + call cc_rms (fit, Memd[xi], Memd[eta], Memd[xifit], + Memd[etafit], Memd[wts], npts, lngrms, latrms) + } + + # Update the image wcs. + do i = 1, nin { + if (im[i] != NULL) { + if (i == 1) { + if (verbose && res != STDOUT) { + call printf ("Wcs mapping status\n") + call printf ( + " Ra/Dec or Long/Lat wcs rms: %0.3g %0.3g (arcsec arcsec)\n") + call pargd (lngrms) + call pargd (latrms) + } + if (res != NULL) { + call fprintf (res, "# Wcs mapping status\n") + call fprintf (res, + "# Ra/Dec or Long/Lat wcs rms: %0.3g %0.3g (arcsec arcsec)\n") + call pargd (lngrms) + call pargd (latrms) + } + } + if (update) { + if (IS_INDEFD(ratan[i]) || IS_INDEFD(dectan[i])) + call cc_nwcsim (im[i], coo, Memc[projstr], lngmean, + latmean, sx1, sy1, sx2, sy2, false) + else + call cc_nwcsim (im[i], coo, Memc[projstr], ratan[i], + dectan[i], sx1, sy1, sx2, sy2, false) + if (i == 1) { + if (verbose && res != STDOUT) + call printf ("Updating image header wcs\n\n") + if (res != NULL) + call fprintf (res, + "# Updating image header wcs\n\n") + } + } + } + } + + # Write the database file. + call cc_out (fit, coo, out, sx1, sy1, sx2, sy2, lngrms, latrms) + + # List results for individual objects. + if (res != NULL) + call cc_plist (res, fit, coo, Memd[xref], Memd[yref], Memd[lngref], + Memd[latref], Memd[lngfit], Memd[latfit], Memd[wts], + npts) + + # Free the space and close files. + call geo_mmfreed (sx1, sy1, sx2, sy2) + + if (n != NULL) + call mfree (n, TY_INT) + if (xref != NULL) + call mfree (xref, TY_DOUBLE) + if (yref != NULL) + call mfree (yref, TY_DOUBLE) + if (lngref != NULL) + call mfree (lngref, TY_DOUBLE) + if (latref != NULL) + call mfree (latref, TY_DOUBLE) + if (xi != NULL) + call mfree (xi, TY_DOUBLE) + if (eta != NULL) + call mfree (eta, TY_DOUBLE) + if (xifit != NULL) + call mfree (xifit, TY_DOUBLE) + if (etafit != NULL) + call mfree (etafit, TY_DOUBLE) + if (wts != NULL) + call mfree (wts, TY_DOUBLE) + if (lngfit != NULL) + call mfree (lngfit, TY_DOUBLE) + if (latfit != NULL) + call mfree (latfit, TY_DOUBLE) + + call sfree (sp) +end + + +# CC_RDXYRD -- Read in the x, y, ra, and dec values from the input file(s). +# +# Adjust the tangent points if there is an image WCS. + +int procedure cc_rdxyrd (in, im, xtan, ytan, ratan, dectan, nin, + coo, xcolumn, ycolumn, lngcolumn, latcolumn, tweak, + n, xref, yref, lngref, latref, xmin, xmax, ymin, ymax) + +int in[nin] #I the input file file descriptors +pointer im[nin] #I the input image pointers +double xtan[ARB], ytan[ARB] #I the input x and y of the tangent point +double ratan[ARB], dectan[ARB] #I the input ra and dec of the tangent point +int nin #I number of input files +pointer coo #I the input coordinate system +int xcolumn, ycolumn #I the columns containing the x / y values +int lngcolumn, latcolumn #I the columns containing the lng / lat values +int tweak #I tweak flag +pointer n #U pointer to the number of points +pointer xref, yref #I pointers to the x / y value arrays +pointer lngref, latref #I pointers to the lng / lat value arrays +double xmin, xmax #U the min and max x values +double ymin, ymax #U the min and max y values + +int i, npts, npts1 +pointer xref1, yref1, lngref1, latref1 + +int cc_rdxyrd1() + +begin + call calloc (n, nin, TY_INT) + + npts = 0 + do i = 1, nin { + npts1 = cc_rdxyrd1 (in[i], im[i], xtan[i], ytan[i], ratan[i], + dectan[i], coo, xcolumn, ycolumn, lngcolumn, latcolumn, tweak, + xref1, yref1, lngref1, latref1, xmin, xmax, ymin, ymax) + Memi[n+i-1] = npts1 + if (npts1 == 0) + next + if (npts == 0) { + xref = xref1 + yref = yref1 + lngref = lngref1 + latref = latref1 + } else { + call realloc (xref, npts+npts1, TY_DOUBLE) + call realloc (yref, npts+npts1, TY_DOUBLE) + call realloc (lngref, npts+npts1, TY_DOUBLE) + call realloc (latref, npts+npts1, TY_DOUBLE) + call amovd (Memd[xref1], Memd[xref+npts], npts1) + call amovd (Memd[yref1], Memd[yref+npts], npts1) + call amovd (Memd[lngref1], Memd[lngref+npts], npts1) + call amovd (Memd[latref1], Memd[latref+npts], npts1) + call mfree (xref1, TY_DOUBLE) + call mfree (yref1, TY_DOUBLE) + call mfree (lngref1, TY_DOUBLE) + call mfree (latref1, TY_DOUBLE) + } + npts = npts + npts1 + } + + if (npts == 0) { + call mfree (n, TY_INT) + + if (i > 1) + call printf ("Coordinate lists have no data in range.\n") + } + + return (npts) +end + + +# CC_RDXYRD1 -- Read in the x, y, ra, and dec values from the input file. +# +# If a reference point (both pixel and value) and an image (with a +# valid celestial WCS) are defined then the WCS is reset to the reference +# point and the reference point value is then shifted to make the +# the WCS coordinates evaluated at the input pixel coordinates agree +# if the input celestial coordinates on average. + +int procedure cc_rdxyrd1 (in, im, xtan, ytan, ratan, dectan, icoo, + xcolumn, ycolumn, lngcolumn, latcolumn, tweak, + xref, yref, lngref, latref, xmin, xmax, ymin, ymax) + +int in #I the input file file descriptor +pointer im #I the input image pointer +double xtan, ytan #I the input x and y of the tangent point +double ratan, dectan #I the input ra and dec of the tangent point +pointer icoo #I the input coordinate system +int xcolumn, ycolumn #I the columns containing the x / y values +int lngcolumn, latcolumn #I the columns containing the lng / lat values +int tweak #I tweak flag +pointer xref, yref #I pointers to the input x / y values +pointer lngref, latref #I pointers to the input lng / lat values +double xmin, xmax #U the min and max x values +double ymin, ymax #U the min and max y values + +int nline, i, npts, bufsize, nfields, max_fields, nsig, offset +double lng1, lat1, lng2, lat2, x, y, z, sumx, sumy, sumz, r, pa, wterm[8] +pointer sp, inbuf, linebuf, field_pos +pointer mw, ct, coo +int getline(), li_get_numd(), sk_decim() +pointer mw_ctrand(), mw_sctran() + +int sk_stati() + +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) + + bufsize = CC_DEFBUFSIZE + call malloc (xref, bufsize, TY_DOUBLE) + call malloc (yref, bufsize, TY_DOUBLE) + call malloc (lngref, bufsize, TY_DOUBLE) + call malloc (latref, bufsize, TY_DOUBLE) + + # Check whether to adjust the reference value based on the + # current image WCS. + mw = NULL; ct = NULL; coo = NULL + if (tweak == 3 && im != NULL && !IS_INDEFD(xtan) && !IS_INDEFD(ytan) && + !IS_INDEFD(ratan) && !IS_INDEFD(dectan)) { + if (sk_decim (im, "logical", mw, coo) != ERR && mw != NULL) { + call sk_seti (coo, S_NLNGUNITS, SKY_DEGREES) + call sk_ultran (icoo, coo, ratan, dectan, lng1, lat1, 1) + call mw_gwtermd (mw, wterm[1], wterm[3], wterm[5], 2) + wterm[1] = xtan; wterm[2] = ytan + wterm[3] = lng1; wterm[4] = lat1 + call mw_swtermd (mw, wterm[1], wterm[3], wterm[5], 2) + ct = mw_sctran (mw, "logical", "world", 03B) + sumx = 0d0; sumy = 0d0; sumz = 0d0 + } else { + if (mw != NULL) + call mw_close (mw) + call sk_close (coo) + mw = NULL; coo = NULL + } + } + + npts = 0 + max_fields = MAX_FIELDS + for (nline = 1; getline (in, Memc[inbuf]) != EOF; nline = nline + 1) { + + # Skip over leading white space. + for (i = inbuf; IS_WHITE(Memc[i]); i = i + 1) + ; + + # Skip comment and blank lines. + if (Memc[i] == '#') + next + else if (Memc[i] == '\n' || Memc[i] == EOS) + 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) + + # Decode the x coordinate. + if (xcolumn > nfields) + next + offset = Memi[field_pos+xcolumn-1] + if (li_get_numd (Memc[linebuf+offset-1], Memd[xref+npts], + nsig) == 0) + next + + # Decode the y coordinate. + if (ycolumn > nfields) + next + offset = Memi[field_pos+ycolumn-1] + if (li_get_numd (Memc[linebuf+offset-1], Memd[yref+npts], + nsig) == 0) + next + + # Decode the ra / longitude coordinate. + if (lngcolumn > nfields) + next + offset = Memi[field_pos+lngcolumn-1] + if (li_get_numd (Memc[linebuf+offset-1], Memd[lngref+npts], + nsig) == 0) + next + + # Decode the dec / latitude coordinate. + if (latcolumn > nfields) + next + offset = Memi[field_pos+latcolumn-1] + if (li_get_numd (Memc[linebuf+offset-1], Memd[latref+npts], + nsig) == 0) + next + + # Accumulate cartisian shifts from image WCS coordinates. + if (ct != NULL) { + call mw_c2trand (ct, Memd[xref+npts], Memd[yref+npts], + lng1, lat1) + call sk_ultran (icoo, coo, Memd[lngref+npts], Memd[latref+npts], + lng2, lat2, 1) + lng1 = DDEGTORAD(lng1); lat1 = DDEGTORAD(lat1) + lng2 = DDEGTORAD(lng2); lat2 = DDEGTORAD(lat2) + x = sin (lat2) - sin(lat1) + y = cos (lat2) * sin (lng2) - cos (lat1) * sin (lng1) + z = cos (lat2) * cos (lng2) - cos (lat1) * cos (lng1) + sumx = sumx + x; sumy = sumy + y; sumz = sumz + z + } + + npts = npts + 1 + + if (npts >= bufsize) { + bufsize = bufsize + CC_DEFBUFSIZE + call realloc (xref, bufsize, TY_DOUBLE) + call realloc (yref, bufsize, TY_DOUBLE) + call realloc (lngref, bufsize, TY_DOUBLE) + call realloc (latref, bufsize, TY_DOUBLE) + } + } + + # Adjust the tangent point value. + if (npts > 0 && ct != NULL) { + sumx = sumx / npts; sumy = sumy / npts; sumz = sumz / npts + r = sqrt (sumx**2 + sumy**2 + sumz**2) / 2 + r = 2 * atan2 (r, sqrt(max(0d0,1d0-r))) + r = 3600 * DRADTODEG (r) + call eprintf ("Tangent point shift = %.2f\n") + call pargd (r) + + call sk_ultran (icoo, coo, ratan, dectan, lng1, lat1, 1) + lng2 = DDEGTORAD(lng1); lat2 = DDEGTORAD(lat1) + x = sin (lat2) + sumx + y = cos (lat2) * sin (lng2) + sumy + z = cos (lat2) * cos (lng2) + sumz + pa = atan2 (y, x) + if (pa < 0d0) + pa = pa + DTWOPI + if (pa >= DTWOPI) + pa = pa - DTWOPI + r = z + if (abs(r) > 0.99d0) { + if (r < 0d0) + r = DPI - asin (sqrt (x * x + y * y)) + else + r = asin (sqrt (x * x + y * y)) + } else + r = acos (r) + x = sin (r) * cos (pa) + y = sin (r) * sin (pa) + z = cos (r) + lng2 = atan2 (y, z) + if (lng2 < 0d0) + lng2 = lng2 + DTWOPI + if (lng2 >= DTWOPI) + lng2 = lng2 - DTWOPI + lat2 = x + if (abs (lat2) > 0.99d0) { + if (lat2 < 0d0) + lat2 = -acos (sqrt (y * y + z * z)) + else + lat2 = acos (sqrt (y * y + z * z)) + } else + lat2 = asin (lat2) + lng2 = DRADTODEG (lng2); lat2 = DRADTODEG (lat2) + call sk_ultran (coo, icoo, lng2, lat2, ratan, dectan, 1) + } + + # Finish up. + + if (npts <= 0) { + call mfree (xref, TY_DOUBLE) + call mfree (yref, TY_DOUBLE) + call mfree (lngref, TY_DOUBLE) + call mfree (latref, TY_DOUBLE) + + call fstats (in, F_FILENAME, Memc[linebuf], SZ_LINE) + call printf ("Coordinate list: %s has no data in range.\n") + call pargstr (Memc[linebuf]) + } else if (npts < bufsize) { + call realloc (xref, npts, TY_DOUBLE) + call realloc (yref, npts, TY_DOUBLE) + call realloc (lngref, npts, TY_DOUBLE) + call realloc (latref, npts, TY_DOUBLE) + } + + if (ct != NULL) + call mw_ctfree (ct) + if (mw != NULL) + call mw_close (mw) + if (coo != NULL) + call sk_close (coo) + call sfree (sp) + + return (npts) +end + + +# CC_REFPT -- Compute the coordinates of the reference point by averaging +# the celestial coordinates. + + +procedure cc_refpt (coo, lngref, latref, npts, lngmean, latmean) + +pointer coo #I the input coordinate system descriptor +double lngref[ARB] #I the input longitude coordinates +double latref[ARB] #I the input latitude coordinates +int npts #I the number of input coordinates +double lngmean #O the output mean longitude +double latmean #O the output mean latitude + +double sumx, sumy, sumz, sumdx, sumdy, sumdz +double tlng, tlat +double x, y, z, tr, tpa +int i +int sk_stati() + +begin + sumx = 0.0d0; sumy = 0.0d0; sumz = 0.0d0 + sumdx = 0.0d0; sumdy = 0.0d0; sumdz = 0.0d0 + + # Loop over the data points. + do i = 1, npts { + + # Convert to radians. + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_HOURS: + tlng = DDEGTORAD (15.0d0 * lngref[i]) + case SKY_DEGREES: + tlng = DDEGTORAD (lngref[i]) + case SKY_RADIANS: + tlng = lngref[i] + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_HOURS: + tlat = DDEGTORAD (15.0d0 * latref[i]) + case SKY_DEGREES: + tlat = DDEGTORAD (latref[i]) + case SKY_RADIANS: + tlat = latref[i] + } + + x = sin (tlat) + y = cos (tlat) * sin (tlng) + z = cos (tlat) * cos (tlng) + + sumx = sumx + x + sumy = sumy + y + sumz = sumz + z + } + + # Compute the average vector components. + sumx = sumx / npts + sumy = sumy / npts + sumz = sumz / npts + + # Now compute the average distance and position angle. + tpa = atan2 (sumy, sumx) + if (tpa < 0.0d0) + tpa = tpa + DTWOPI + if (tpa >= DTWOPI) + tpa = tpa - DTWOPI + tr = sumz + if (abs(tr) > 0.99d0) { + if (tr < 0.0d0) + tr = DPI - asin (sqrt (sumx * sumx + sumy * sumy)) + else + tr = asin (sqrt (sumx * sumx + sumy * sumy)) + } else + tr = acos (tr) + + # Solve for the average longitude and latitude. + sumx = sin (tr) * cos (tpa) + sumy = sin (tr) * sin (tpa) + sumz = cos (tr) + lngmean = atan2 (sumy, sumz) + if (lngmean < 0.0d0) + lngmean = lngmean + DTWOPI + if (lngmean >= DTWOPI) + lngmean = lngmean - DTWOPI + latmean = sumx + if (abs (latmean) > 0.99d0) { + if (latmean < 0.0d0) + latmean = -acos (sqrt(sumy ** 2 + sumz ** 2)) + else + latmean = acos (sqrt(sumy ** 2 + sumz ** 2)) + } else + latmean = asin (latmean) + + # Convert back to appropriate units. + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_HOURS: + lngmean = DRADTODEG (lngmean) / 15.0d0 + case SKY_DEGREES: + lngmean = DRADTODEG (lngmean) + case SKY_RADIANS: + ; + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_HOURS: + latmean = DRADTODEG (latmean) / 15.0d0 + case SKY_DEGREES: + latmean = DRADTODEG (latmean) + case SKY_RADIANS: + ; + } +end + + +# CC_EVAL -- Compute the fitted standard coordinates. + +procedure cc_eval (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 + + +# CC_RMS -- Compute the rms of the fit in arcseconds. + +procedure cc_rms (fit, xi, eta, xifit, etafit, wts, npts, xirms, etarms) + +pointer fit #I pointer to the fit structure +double xi[ARB] #I the input xi coordinates +double eta[ARB] #I the input eta coordinates +double xifit[ARB] #I the fitted chi coordinates +double etafit[ARB] #I the fitted eta coordinates +double wts[ARB] #I the input weights array +int npts #I the number of points +double xirms #O the output xi rms +double etarms #O the output eta rms + +int i, index, ngood +pointer sp, twts + +begin + # Allocate working space. + call smark (sp) + 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] > 0.0d0) + Memd[twts+index-1] = 0.0d0 + } + + # Accumulate the squares. + xirms = 0.0d0 + etarms = 0.0d0 + do i = 1, npts { + xirms = xirms + Memd[twts+i-1] * (xi[i] - xifit[i]) ** 2 + etarms = etarms + Memd[twts+i-1] * (eta[i] - etafit[i]) ** 2 + } + + # Compute the rms. + #ngood = max (0, GM_NPTS(fit) - GM_NREJECT(fit) - GM_NWTS0(fit)) + ngood = max (0, GM_NPTS(fit) - GM_NWTS0(fit)) + if (ngood > 1) { + xirms = sqrt (xirms / (ngood - 1)) + etarms = sqrt (etarms / (ngood - 1)) + } else { + xirms = 0.0d0 + etarms = 0.0d0 + } + xirms = xirms + etarms = etarms + + call sfree (sp) +end + + +# CC_SHOW -- Print the coodinate mapping parameters. + +procedure cc_show (fd, coo, projection, lngref, latref, sx1, sy1, comment) + +int fd #I the output file descriptor +pointer coo #I pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the coordinates of the reference point +pointer sx1, sy1 #I pointer to linear surfaces +int comment #I comment the output ? + +double xshift, yshift, a, b, c, d, denom +double xpix, ypix, xscale, yscale, xrot, yrot +pointer sp, str, keyword, value +bool fp_equald() +int sk_stati() + +begin + # Allocate temporary space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (keyword, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + + # Compute the geometric parameters. + call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) + + # Compute the position of the reference pixel from the geometric + # parameters. + denom = a * d - c * b + if (denom == 0.0d0) + xpix = INDEFD + else + xpix = (b * yshift - d * xshift) / denom + if (denom == 0.0d0) + ypix = INDEFD + else + ypix = (c * xshift - a * yshift) / denom + + if (comment == NO) { + call fprintf (fd, "Coordinate mapping parameters\n") + call fprintf (fd, " Sky projection geometry: %s\n") + } else { + call fprintf (fd, "# Coordinate mapping parameters\n") + call fprintf (fd, "# Sky projection geometry: %s\n") + } + if (projection[1] == EOS) + call pargstr ("lin") + else { + call sscan (projection) + call gargwrd (Memc[str], SZ_LINE) + call pargstr (Memc[str]) + repeat { + call gargwrd (Memc[keyword], SZ_FNAME) + if (Memc[keyword] == EOS) + break + call gargwrd (Memc[value], SZ_FNAME) + if (Memc[value] != '=') + break + call gargwrd (Memc[value], SZ_FNAME) + if (Memc[value] == EOS) + break + if (comment == NO) { + call fprintf (fd, " Projection parameter %s: %s\n") + } else { + call fprintf (fd, "# Projection parameter %s: %s\n") + } + call pargstr (Memc[keyword]) + call pargstr (Memc[value]) + } + + } + + # Output the reference point. + if (comment == NO) { + call sprintf (Memc[str], SZ_LINE, + " Reference point: %s %s (%s %s)\n") + } else { + call sprintf (Memc[str], SZ_LINE, + "# Reference point: %s %s (%s %s)\n") + } + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_DEGREES: + call pargstr ("%0.2h") + case SKY_RADIANS: + call pargstr ("%0.7g") + case SKY_HOURS: + call pargstr ("%0.3h") + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_DEGREES: + call pargstr ("%0.2h") + case SKY_RADIANS: + call pargstr ("%0.7g") + case SKY_HOURS: + call pargstr ("%0.3h") + } + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_DEGREES: + call pargstr ("degrees") + case SKY_RADIANS: + call pargstr ("radians") + case SKY_HOURS: + call pargstr ("hours") + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_DEGREES: + call pargstr ("degrees") + case SKY_RADIANS: + call pargstr ("radians") + case SKY_HOURS: + call pargstr ("hours") + } + if (comment == NO) { + call printf (Memc[str]) + call pargd (lngref) + call pargd (latref) + } else { + call fprintf (fd, Memc[str]) + call pargd (lngref) + call pargd (latref) + } + + if (comment == NO) { + call fprintf (fd, + " Reference point: %0.3f %0.3f (pixels pixels)\n") + call pargd (xpix) + call pargd (ypix) + } else { + call fprintf (fd, + "# Reference point: %0.3f %0.3f (pixels pixels)\n") + call pargd (xpix) + call pargd (ypix) + } + + # 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.3f %0.3f (arcsec/pixel arcsec/pixel)\n") + call pargd (xscale) + call pargd (yscale) + } else { + call fprintf (fd, + "# X and Y scale: %0.3f %0.3f (arcsec/pixel arcsec/pixel)\n") + call pargd (xscale) + call pargd (yscale) + } + + # Output the rotation factors. + if (fp_equald (a, 0.0d0) && fp_equald (c, 0.0d0)) + xrot = 0.0d0 + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < 0.0d0) + xrot = xrot + 360.0d0 + if (fp_equald (b, 0.0d0) && fp_equald (d, 0.0d0)) + yrot = 0.0d0 + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < 0.0d0) + yrot = yrot + 360.0d0 + if (comment == NO) { + call fprintf (fd, + " X and Y axis rotation: %0.3f %0.3f (degrees degrees)\n") + call pargd (xrot) + call pargd (yrot) + } else { + call fprintf (fd, + "# X and Y axis rotation: %0.3f %0.3f (degrees degrees)\n") + call pargd (xrot) + call pargd (yrot) + } + + call sfree (sp) +end + + +# CC_OUT -- Write the output database file record. + +procedure cc_out (fit, coo, out, sx1, sy1, sx2, sy2, lxrms, lyrms) + +pointer fit #I pointer to fitting structure +pointer coo #I pointer to the coordinate system structure +int out #I pointer to database file +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to distortion surfaces +double lxrms, lyrms #I the input wcs x and y rms + +double xshift, yshift, a, b, c, d, denom, xrms, yrms +double xpixref, ypixref, xscale, yscale, xrot, yrot +int i, npts, ncoeff +pointer sp, str, xcoeff, ycoeff, keyword, value +bool fp_equald() +int dgsgeti(), rg_wrdstr(), sk_stati() + +begin + # Allocate some working memory. + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (keyword, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + + # Compute the 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 + } + + # Compute the geometric parameters. + call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) + denom = a * d - c * b + if (denom == 0.0d0) + xpixref = INDEFD + else + xpixref = (b * yshift - d * xshift) / denom + if (denom == 0.0d0) + ypixref = INDEFD + else + ypixref = (c * xshift - a * yshift) / denom + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + if (fp_equald (a, 0.0d0) && fp_equald (c, 0.0d0)) + xrot = 0.0d0 + else + xrot = RADTODEG(atan2 (-c, a)) + if (xrot < 0.0d0) + xrot = xrot + 360.0d0 + if (fp_equald (b, 0.0d0) && fp_equald (d, 0.0d0)) + yrot = 0.0d0 + else + yrot = RADTODEG(atan2 (b, d)) + if (yrot < 0.0d0) + yrot = yrot + 360.0d0 + + # Print title. + call dtptime (out) + call dtput (out, "begin\t%s\n") + call pargstr (GM_RECORD(fit)) + + # Print out some information about the data. + 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, "\tlngmean\t\t%g\n") + call pargd (GM_XOIN(fit)) + call dtput (out, "\tlatmean\t\t%g\n") + call pargd (GM_YOIN(fit)) + + # Print out information about the tangent point. + if (rg_wrdstr(sk_stati(coo, S_PIXTYPE), Memc[str], SZ_FNAME, + PIXTYPE_LIST) <= 0) + call strcpy ("logical", Memc[str], SZ_FNAME) + call dtput (out, "\tpixsystem\t%s\n") + call pargstr (Memc[str]) + call sk_stats (coo, S_COOSYSTEM, Memc[str], SZ_FNAME) + call dtput (out, "\tcoosystem\t%g\n") + call pargstr (Memc[str]) + + if (rg_wrdstr (GM_PROJECTION(fit), Memc[str], SZ_FNAME, + GM_PROJLIST) <= 0) + call strcpy ("tan", Memc[str], SZ_FNAME) + call dtput (out, "\tprojection\t%s\n") + call pargstr (Memc[str]) + call sscan (GM_PROJSTR(fit)) + call gargwrd (Memc[str], SZ_FNAME) + repeat { + call gargwrd (Memc[keyword], SZ_FNAME) + if (Memc[keyword] == EOS) + break + call gargwrd (Memc[value], SZ_FNAME) + if (Memc[value] != '=') + break + call gargwrd (Memc[value], SZ_FNAME) + if (Memc[value] == EOS) + break + call dtput (out, "\t%s\t\t%s\n") + call pargstr (Memc[keyword]) + call pargstr (Memc[value]) + } + + call dtput (out, "\tlngref\t\t%g\n") + call pargd (GM_XREFPT(fit)) + call dtput (out, "\tlatref\t\t%g\n") + call pargd (GM_YREFPT(fit)) + if (rg_wrdstr (sk_stati(coo, S_NLNGUNITS), Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST) <= 0) + ; + call dtput (out, "\tlngunits\t%s\n") + call pargstr (Memc[str]) + if (rg_wrdstr (sk_stati(coo, S_NLATUNITS), Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST) <= 0) + ; + call dtput (out, "\tlatunits\t%s\n") + call pargstr (Memc[str]) + call dtput (out, "\txpixref\t\t%g\n") + call pargd (xpixref) + call dtput (out, "\typixref\t\t%g\n") + call pargd (ypixref) + + # Print out information about the fit. + 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]) + call dtput (out, "\txishift\t\t%g\n") + call pargd (xshift) + call dtput (out, "\tetashift\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) + + # Output the rms of the fit. + call dtput (out, "\twcsxirms\t%g\n") + call pargd (lxrms) + call dtput (out, "\twcsetarms\t%g\n") + call pargd (lyrms) + call dtput (out, "\txirms\t\t%g\n") + call pargd (xrms) + call dtput (out, "\tetarms\t\t%g\n") + call pargd (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) + + # Encode the linear coefficients. + call dgssave (sx1, Memd[xcoeff]) + call dgssave (sy1, Memd[ycoeff]) + + # Output the linear coefficients. + 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]) + } + + # Free the linear coefficient memory. + 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) + + # Encode 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 + + +# CC_PLIST -- List the coordinates and the residuals. + +procedure cc_plist (fd, fit, coo, xref, yref, lngref, latref, lngfit, latfit, + wts, npts) + +int fd #I the results file descriptor +pointer fit #I pointer to the fit structure +pointer coo #I pointer to the coordinate structure +double xref[ARB] #I the input x coordinates +double yref[ARB] #I the input y coordinates +double lngref[ARB] #I the input ra / longitude coordinates +double latref[ARB] #I the input dec / latitude coordinates +double lngfit[ARB] #I the fitted ra / longitude coordinates +double latfit[ARB] #I the fitted dec / latitude coordinates +double wts[ARB] #I the weights array +int npts #I the number of data points + +double diflng, diflat +int i, index +pointer sp, fmtstr, lngunits, latunits, twts +int sk_stati() + +begin + # Allocate working space. + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (lngunits, SZ_FNAME, TY_CHAR) + call salloc (latunits, SZ_FNAME, TY_CHAR) + call salloc (twts, npts, TY_DOUBLE) + + # Get the unit strings. + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_HOURS: + call strcpy ("hours", Memc[lngunits], SZ_FNAME) + case SKY_DEGREES: + call strcpy ("degrees", Memc[lngunits], SZ_FNAME) + default: + call strcpy ("radians", Memc[lngunits], SZ_FNAME) + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_HOURS: + call strcpy ("hours", Memc[latunits], SZ_FNAME) + case SKY_DEGREES: + call strcpy ("degrees", Memc[latunits], SZ_FNAME) + default: + call strcpy ("radians", Memc[latunits], SZ_FNAME) + } + + # 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] > 0.0d0) + Memd[twts+index-1] = 0.0d0 + } + + # Print banner. + call fprintf (fd, "\n# Input Coordinate Listing\n") + call fprintf (fd, "# Column 1: X (pixels)\n") + call fprintf (fd, "# Column 2: Y (pixels)\n") + call fprintf (fd, "# Column 3: Ra / Longitude (%s)\n") + call pargstr (Memc[lngunits]) + call fprintf (fd, "# Column 4: Dec / Latitude (%s)\n") + call pargstr (Memc[latunits]) + call fprintf (fd, "# Column 5: Fitted Ra / Longitude (%s)\n") + call pargstr (Memc[lngunits]) + call fprintf (fd, "# Column 6: Fitted Dec / Latitude (%s)\n") + call pargstr (Memc[latunits]) + call fprintf (fd, + "# Column 7: Residual Ra / Longitude (arcseconds)\n") + call fprintf (fd, + "# Column 8: Residual Dec / Latitude (arcseconds)\n\n") + + # Create format string. + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s %s %s %s %s\n") + call pargstr ("%10.3f") + call pargstr ("%10.3f") + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_HOURS: + call pargstr ("%12.3h") + case SKY_DEGREES: + call pargstr ("%12.2h") + default: + call pargstr ("%12.7g") + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_HOURS: + call pargstr ("%12.3h") + case SKY_DEGREES: + call pargstr ("%12.2h") + default: + call pargstr ("%12.7g") + } + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_HOURS: + call pargstr ("%12.3h") + case SKY_DEGREES: + call pargstr ("%12.2h") + default: + call pargstr ("%12.7g") + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_HOURS: + call pargstr ("%12.3h") + case SKY_DEGREES: + call pargstr ("%12.2h") + default: + call pargstr ("%12.7g") + } + call pargstr ("%6.3f") + call pargstr ("%6.3f") + + do i = 1, npts { + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_DEGREES: + diflng = (lngref[i] - lngfit[i]) * 3600.0d0 + case SKY_HOURS: + diflng = 15.0d0 * (lngref[i] - lngfit[i]) * 3600.0d0 * + cos (DEGTORAD(latref[i])) + case SKY_RADIANS: + diflng = RADTODEG ((lngref[i] - lngfit[i])) * 3600.0d0 + default: + diflng = lngref[i] - lngfit[i] + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_DEGREES: + diflat = (latref[i] - latfit[i]) * 3600.0d0 + case SKY_HOURS: + diflat = 15.0d0 * (latref[i] - latfit[i]) * 3600.0d0 + case SKY_RADIANS: + diflat = RADTODEG ((latref[i] - latfit[i])) * 3600.0d0 + default: + diflat = latref[i] - latfit[i] + } + call fprintf (fd, Memc[fmtstr]) + call pargd (xref[i]) + call pargd (yref[i]) + call pargd (lngref[i]) + call pargd (latref[i]) + if (Memd[twts+i-1] > 0.0d0) { + call pargd (lngfit[i]) + call pargd (latfit[i]) + call pargd (diflng) + call pargd (diflat) + } else { + call pargd (INDEFD) + call pargd (INDEFD) + call pargd (INDEFD) + call pargd (INDEFD) + } + } + + call fprintf (fd, "\n") + + call sfree (sp) +end diff --git a/pkg/images/imcoords/src/t_ccsetwcs.x b/pkg/images/imcoords/src/t_ccsetwcs.x new file mode 100644 index 00000000..85c0c0ff --- /dev/null +++ b/pkg/images/imcoords/src/t_ccsetwcs.x @@ -0,0 +1,751 @@ +include <imhdr.h> +include <math.h> +include <mwset.h> +include <pkg/skywcs.h> + +# Define the possible pixel types + +define CC_PIXTYPESTR "|logical|physical|" +define CC_LOGICAL 1 +define CC_PHYSICAL 2 + + +# T_CCSETWCS -- Create a wcs and write it to the image header. The wcs may +# be read from a database file written by CCMAP or it may be input by the +# user. + +procedure t_ccsetwcs () + +bool transpose, verbose, update +double xref, yref, xscale, yscale, xrot, yrot, lngref, latref +double txref, tyref, txscale, tyscale, txrot, tyrot, tlngref, tlatref +int imlist, reclist, lngunits, latunits, coostat, recstat, proj, pixsys, pfd +pointer sp, image, database, record, insystem, projstr, str +pointer dt, im, coo, tcoo, mw, sx1, sy1, sx2, sy2 +bool clgetb() +double clgetd() +int imtopenp(), clgwrd(), sk_decwcs(), sk_stati(), imtlen() +int imtgetim(), cc_dtwcs(), strdic(), cc_rdproj(), open() +pointer dtmap(), immap() +errchk open() + +begin + # Allocate some working space. + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (database, SZ_FNAME, TY_CHAR) + call salloc (record, SZ_FNAME, TY_CHAR) + call salloc (insystem, SZ_FNAME, TY_CHAR) + call salloc (projstr, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + imlist = imtopenp ("images") + call clgstr ("database", Memc[database], SZ_FNAME) + + # Fetch the celestial coordinate system parameters. + if (Memc[database] == EOS) { + dt = NULL + reclist = NULL + xref = clgetd ("xref") + yref = clgetd ("yref") + xscale = clgetd ("xmag") + yscale = clgetd ("ymag") + xrot = clgetd ("xrotation") + yrot = clgetd ("yrotation") + lngref = clgetd ("lngref") + latref = clgetd ("latref") + iferr (lngunits = clgwrd ("lngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + lngunits = 0 + iferr (latunits = clgwrd ("latunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + latunits = 0 + call clgstr ("coosystem", Memc[insystem], SZ_FNAME) + coostat = sk_decwcs (Memc[insystem], mw, coo, NULL) + if (coostat == ERR || mw != NULL) { + call eprintf ("Error decoding the coordinate system %s\n") + call pargstr (Memc[insystem]) + if (mw != NULL) + call mw_close (mw) + if (coo != NULL) + #call mfree (coo, TY_STRUCT) + call sk_close (coo) + call imtclose (imlist) + call sfree (sp) + return + } + if (lngunits <= 0) + lngunits = sk_stati (coo, S_NLNGUNITS) + call sk_seti (coo, S_NLNGUNITS, lngunits) + if (latunits <= 0) + latunits = sk_stati (coo, S_NLATUNITS) + call sk_seti (coo, S_NLATUNITS, latunits) + + call clgstr ("projection", Memc[projstr], SZ_LINE) + iferr { + pfd = open (Memc[projstr], READ_ONLY, TEXT_FILE) + } then { + proj = strdic (Memc[projstr], Memc[projstr], SZ_LINE, + WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projstr] = EOS + } else { + proj = cc_rdproj (pfd, Memc[projstr], SZ_LINE) + call close (pfd) + } + + iferr (pixsys = clgwrd ("pixsystem", Memc[str], SZ_FNAME, + CC_PIXTYPESTR)) + pixsys = PIXTYPE_LOGICAL + else if (pixsys == CC_PHYSICAL) + pixsys = PIXTYPE_PHYSICAL + else + pixsys = PIXTYPE_LOGICAL + call sk_seti (coo, S_PIXTYPE, pixsys) + } else { + dt = dtmap (Memc[database], READ_ONLY) + reclist = imtopenp ("solutions") + if ((imtlen (reclist) > 1) && (imtlen (imlist) != + imtlen (reclist))) { + call eprintf ( + " The image and record list lengths are different\n") + call imtclose (reclist) + call dtunmap (dt) + call imtclose (imlist) + call sfree (sp) + return + } + coo = NULL + } + + transpose = clgetb ("transpose") + verbose = clgetb ("verbose") + update = clgetb ("update") + + # Loop over the images. + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + if (update) + im = immap (Memc[image], READ_WRITE, 0) + else + im = immap (Memc[image], READ_ONLY, 0) + if (IM_NDIM(im) != 2) { + call printf ("Skipping non 2D image %s\n") + call pargstr (Memc[image]) + call imunmap (im) + next + } + + if (dt == NULL) { + + if (verbose) { + call printf ("Image: %s\n") + call pargstr (Memc[image]) + } + + # Compute the linear transformation parameters. + if (IS_INDEFD(lngref)) + tlngref = 0.0d0 + else + tlngref = lngref + if (IS_INDEFD(latref)) + tlatref = 0.0d0 + else + tlatref = latref + if (IS_INDEFD(xref)) + txref = (1.0d0 + IM_LEN(im,1)) / 2.0 + else + txref = xref + if (IS_INDEFD(yref)) + tyref = (1.0d0 + IM_LEN(im,2)) / 2.0 + else + tyref = yref + if (IS_INDEFD(xscale)) + txscale = 1.0d0 + else + txscale = xscale + if (IS_INDEFD(yscale)) + tyscale = 1.0d0 + else + tyscale = yscale + if (IS_INDEFD(xrot)) + txrot = 0.0d0 + else + txrot = xrot + if (IS_INDEFD(yrot)) + tyrot = 0.0d0 + else + tyrot = yrot + + if (verbose) + call cc_usershow (coo, Memc[projstr], tlngref, tlatref, + txref, tyref, txscale, tyscale, txrot, tyrot, + transpose) + + if (update) { + call cc_userwcs (im, coo, Memc[projstr], tlngref, tlatref, + txref, tyref, txscale, tyscale, txrot, tyrot, + transpose) + if (verbose) + call printf ("Updating image header wcs\n") + } + + } else { + if (imtgetim (reclist, Memc[record], SZ_FNAME) == EOF) + #call strcpy (Memc[image], Memc[record], SZ_FNAME) + ; + if (verbose) { + call printf ("Image: %s Database: %s Solution: %d\n") + call pargstr (Memc[image]) + call pargstr (Memc[database]) + call pargstr (Memc[record]) + } + sx1 = NULL; sx2 = NULL + sy1 = NULL; sy2 = NULL + tcoo = NULL + recstat = cc_dtwcs (dt, Memc[record], tcoo, Memc[projstr], + tlngref, tlatref, sx1, sy1, sx2, sy2, txref, tyref, txscale, + tyscale, txrot, tyrot) + if (recstat == ERR) { + call printf (" Cannot find or decode ") + call printf ("record %s in database file %s\n") + call pargstr (Memc[record]) + call pargstr (Memc[database]) + } else { + call sscan (Memc[projstr]) + call gargwrd (Memc[str], SZ_FNAME) + proj = strdic (Memc[str], Memc[str], SZ_FNAME, + WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projstr] = EOS + if (verbose) + call cc_usershow (tcoo, Memc[projstr], tlngref, + tlatref, txref, tyref, txscale, tyscale, txrot, + tyrot, transpose) + if (update) { + call cc_nwcsim (im, tcoo, Memc[projstr], tlngref, + tlatref, sx1, sy1, sx2, sy2, transpose) + if (verbose) + call printf ("Updating image header wcs\n") + } + } + if (tcoo != NULL) + #call mfree (tcoo, TY_STRUCT) + call sk_close (tcoo) + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) + } + + call imunmap (im) + } + + # Close up memory. + if (coo != NULL) + #call mfree (coo, TY_STRUCT) + call sk_close (coo) + if (dt != NULL) + call dtunmap (dt) + if (reclist != NULL) + call imtclose (reclist) + call imtclose (imlist) + + call sfree (sp) +end + + +define NEWCD Memd[ncd+(($2)-1)*ndim+($1)-1] + +# CC_USERWCS -- Compute the image wcs from the user parameters. + +procedure cc_userwcs (im, coo, projection, lngref, latref, xref, yref, + xscale, yscale, xrot, yrot, transpose) + +pointer im #I pointer to the input image +pointer coo #I pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the world coordinates of the reference point +double xref, yref #I the reference point in pixels +double xscale, yscale #I the x and y scale in arcsec / pixel +double xrot, yrot #I the x and y axis rotation angles in degrees +bool transpose #I transpose the wcs + +double tlngref, tlatref +int l, i, ndim, naxes, axmap, wtype, ax1, ax2, szatstr +pointer mw, sp, r, w, cd, ltm, ltv, iltm, nr, ncd, axes, axno, axval +pointer projstr, projpars, wpars, mwnew, atstr +int mw_stati(), sk_stati(), strdic(), strlen(), itoc() +pointer mw_openim(), mw_open() +errchk mw_newsystem(), mw_gwattrs() + +begin + mw = mw_openim (im) + ndim = mw_stati (mw, MW_NPHYSDIM) + # Allocate working memory for the vectors and matrices. + call smark (sp) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (projpars, SZ_LINE, TY_CHAR) + call salloc (wpars, SZ_LINE, TY_CHAR) + call salloc (r, ndim, TY_DOUBLE) + call salloc (w, ndim, TY_DOUBLE) + call salloc (cd, ndim * ndim, TY_DOUBLE) + call salloc (ltm, ndim * ndim, TY_DOUBLE) + call salloc (ltv, ndim, TY_DOUBLE) + call salloc (iltm, ndim * ndim, TY_DOUBLE) + call salloc (nr, ndim, TY_DOUBLE) + call salloc (ncd, ndim * ndim, TY_DOUBLE) + call salloc (axes, IM_MAXDIM, TY_INT) + call salloc (axno, IM_MAXDIM, TY_INT) + call salloc (axval, IM_MAXDIM, TY_INT) + + # Open the new wcs + mwnew = mw_open (NULL, ndim) + call mw_gsystem (mw, Memc[projstr], SZ_FNAME) + iferr { + call mw_newsystem (mw, "image", ndim) + } then { + call mw_newsystem (mwnew, Memc[projstr], ndim) + } else { + call mw_newsystem (mwnew, "image", ndim) + } + + # Set the LTERM. + call mw_gltermd (mw, Memd[ltm], Memd[ltv], ndim) + call mw_sltermd (mwnew, Memd[ltm], Memd[ltv], ndim) + + # Store the old axis map for later use. + call mw_gaxmap (mw, Memi[axno], Memi[axval], ndim) + + # Get the 2 logical axes. + call mw_gaxlist (mw, 03B, Memi[axes], naxes) + axmap = mw_stati (mw, MW_USEAXMAP) + ax1 = Memi[axes] + ax2 = Memi[axes+1] + + # Set the axes and projection type. + if (projection[1] == EOS) { + call mw_swtype (mwnew, Memi[axes], ndim, "linear", "") + } else { + call sscan (projection) + call gargwrd (Memc[projstr], SZ_FNAME) + call gargstr (Memc[projpars], SZ_LINE) + call sprintf (Memc[wpars], SZ_LINE, + "axis 1: axtype = ra %s axis 2: axtype = dec %s") + call pargstr (Memc[projpars]) + call pargstr (Memc[projpars]) + call mw_swtype (mwnew, Memi[axes], ndim, Memc[projstr], Memc[wpars]) + } + + # Copy in the atrributes of the other axes. + szatstr = SZ_LINE + call malloc (atstr, szatstr, TY_CHAR) + do l = 1, ndim { + if (l == ax1 || l == ax2) + next + iferr { + call mw_gwattrs (mw, l, "wtype", Memc[projpars], SZ_LINE) + } then { + call mw_swtype (mwnew, l, 1, "linear", "") + } else { + call mw_swtype (mwnew, l, 1, Memc[projpars], "") + } + for (i = 1; ; i = i + 1) { + if (itoc (i, Memc[projpars], SZ_LINE) <= 0) + Memc[atstr] = EOS + repeat { + iferr (call mw_gwattrs (mw, l, Memc[projpars], + Memc[atstr], szatstr)) + Memc[atstr] = EOS + if (strlen (Memc[atstr]) < szatstr) + break + szatstr = szatstr + SZ_LINE + call realloc (atstr, szatstr, TY_CHAR) + } + if (Memc[atstr] == EOS) + break + call mw_swattrs (mwnew, 1, Memc[projpars], Memc[atstr]) + } + } + call mfree (atstr, TY_CHAR) + + # Compute the referemce point world coordinates. + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_DEGREES: + tlngref = lngref + case SKY_RADIANS: + tlngref = RADTODEG(lngref) + case SKY_HOURS: + tlngref = 15.0d0 * lngref + default: + tlngref = lngref + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_DEGREES: + tlatref = latref + case SKY_RADIANS: + tlatref = RADTODEG(latref) + case SKY_HOURS: + tlatref = 15.0d0 * latref + default: + tlatref = latref + } + + if (! transpose) { + Memd[w+ax1-1] = tlngref + Memd[w+ax2-1] = tlatref + } else { + Memd[w+ax2-1] = tlngref + Memd[w+ax1-1] = tlatref + } + + # Compute the reference point pixel coordinates. + Memd[nr+ax1-1] = xref + Memd[nr+ax2-1] = yref + + # Compute the new CD matrix. + if (! transpose) { + NEWCD(ax1,ax1) = xscale * cos (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(ax2,ax1) = -yscale * sin (DEGTORAD(yrot)) / 3600.0d0 + NEWCD(ax1,ax2) = xscale * sin (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(ax2,ax2) = yscale * cos (DEGTORAD(yrot)) / 3600.0d0 + } else { + NEWCD(ax1,ax1) = xscale * sin (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(ax2,ax1) = yscale * cos (DEGTORAD(yrot)) / 3600.0d0 + NEWCD(ax1,ax2) = xscale * cos (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(ax2,ax2) = -yscale * sin (DEGTORAD(yrot)) / 3600.0d0 + } + + # Reset the axis map. + call mw_seti (mw, MW_USEAXMAP, axmap) + + # Recompute and store the new wcs if update is enabled. + call mw_saxmap (mwnew, Memi[axno], Memi[axval], ndim) + if (sk_stati (coo, S_PIXTYPE) == PIXTYPE_PHYSICAL) { + call mw_swtermd (mwnew, Memd[nr], Memd[w], Memd[ncd], ndim) + } else { + call mwmmuld (Memd[ncd], Memd[ltm], Memd[cd], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call asubd (Memd[nr], Memd[ltv], Memd[r], ndim) + call mwvmuld (Memd[iltm], Memd[r], Memd[nr], ndim) + call mw_swtermd (mwnew, Memd[nr], Memd[w], Memd[cd], ndim) + } + # Save the fit. + if (! transpose) { + call sk_seti (coo, S_PLNGAX, ax1) + call sk_seti (coo, S_PLATAX, ax2) + } else { + call sk_seti (coo, S_PLNGAX, ax2) + call sk_seti (coo, S_PLATAX, ax1) + } + call sk_saveim (coo, mwnew, im) + call mw_saveim (mwnew, im) + call mw_close (mwnew) + call mw_close (mw) + + # Force the CDELT keywords to update. This will be unecessary when + # mwcs is updated to deal with non-quoted and / or non left-justified + # CTYPE keywords.. + wtype = strdic (Memc[projstr], Memc[projstr], SZ_FNAME, WTYPE_LIST) + if (wtype > 0) + call sk_seti (coo, S_WTYPE, wtype) + call sk_ctypeim (coo, im) + + # Reset the fit. This will be unecessary when wcs is updated to deal + # with non-quoted and / or non left-justified CTYPE keywords. + call sk_seti (coo, S_WTYPE, 0) + call sk_seti (coo, S_PLNGAX, 0) + call sk_seti (coo, S_PLATAX, 0) + + call sfree (sp) +end + + +# CC_USERSHOW -- Print the image wcs parameters in user friendly format. + +procedure cc_usershow (coo, projection, lngref, latref, xref, yref, xscale, + yscale, xrot, yrot, transpose) + +pointer coo #I pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the world coordinates of the reference point +double xref, yref #I the reference point in pixels +double xscale, yscale #I the x and y scale in arcsec / pixel +double xrot, yrot #I the x and y axis rotation angles in degrees +bool transpose #I transpose the wcs + +pointer sp, str, keyword, value +int sk_stati() + +begin + # Allocate temporary space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (keyword, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + + call printf ("Coordinate mapping parameters\n") + call printf (" Sky projection geometry: %s\n") + if (projection[1] == EOS) + call pargstr ("lin") + else { + call sscan (projection) + call gargwrd (Memc[str], SZ_LINE) + call pargstr (Memc[str]) + repeat { + call gargwrd (Memc[keyword], SZ_FNAME) + if (Memc[keyword] == EOS) + break + call gargwrd (Memc[value], SZ_FNAME) + if (Memc[value] != '=') + break + call gargwrd (Memc[value], SZ_FNAME) + if (Memc[value] == EOS) + break + call printf (" Projection parameter %s: %s\n") + call pargstr (Memc[keyword]) + call pargstr (Memc[value]) + } + } + + # Output the reference point. + call sprintf (Memc[str], SZ_LINE, + " Reference point: %s %s (%s %s)\n") + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_DEGREES: + call pargstr ("%0.2h") + case SKY_RADIANS: + call pargstr ("%0.7g") + case SKY_HOURS: + call pargstr ("%0.3h") + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_DEGREES: + call pargstr ("%0.2h") + case SKY_RADIANS: + call pargstr ("%0.7g") + case SKY_HOURS: + call pargstr ("%0.3h") + } + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_DEGREES: + call pargstr ("degrees") + case SKY_RADIANS: + call pargstr ("radians") + case SKY_HOURS: + call pargstr ("hours") + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_DEGREES: + call pargstr ("degrees") + case SKY_RADIANS: + call pargstr ("radians") + case SKY_HOURS: + call pargstr ("hours") + } + call printf (Memc[str]) + call pargd (lngref) + call pargd (latref) + + # Output the logical axes. + if (sk_stati (coo, S_CTYPE) == CTYPE_EQUATORIAL) + call printf (" Ra/Dec logical image axes: %d %d\n") + else + call printf (" Long/Lat logical image axes: %d %d\n") + if (! transpose) { + call pargi (1) + call pargi (2) + } else { + call pargi (2) + call pargi (1) + } + + # Output the reference point in pixels. + call printf (" Reference point: %0.3f %0.3f (pixels pixels)\n") + call pargd (xref) + call pargd (yref) + + # Output the scale factors. + call printf ( + " X and Y scale: %0.3f %0.3f (arcsec/pixel arcsec/pixel)\n") + call pargd (xscale) + call pargd (yscale) + + # Output the rotation angles. + call printf ( + " X and Y coordinate rotation: %0.3f %0.3f (degrees degrees)\n") + call pargd (xrot) + call pargd (yrot) + + call sfree (sp) +end + + +# CC_DTWCS -- Read the wcs from the database records written by CCMAP. + +int procedure cc_dtwcs (dt, record, coo, projection, lngref, latref, sx1, sy1, + sx2, sy2, xref, yref, xscale, yscale, xrot, yrot) + +pointer dt #I pointer to the database +char record[ARB] #I the database records to be read +pointer coo #O pointer to the coordinate structure +char projection[ARB] #O the sky projection geometry +double lngref, latref #O the reference point world coordinates +pointer sx1, sy1 #O pointer to the linear x and y fits +pointer sx2, sy2 #O pointer to the distortion x and y fits +double xref, yref #O the reference point in pixels +double xscale, yscale #O the x and y scale factors +double xrot, yrot #O the x and y axis rotation angles + +int i, op, ncoeff, junk, rec, coostat, lngunits, latunits, pixsys +double xshift, yshift, a, b, c, d, denom +pointer sp, xcoeff, ycoeff, nxcoeff, nycoeff, mw, projpar, projvalue +bool fp_equald() +double dtgetd() +int dtlocate(), dtgeti(), dtscan(), sk_decwcs(), strdic(), strlen() +int gstrcpy() +errchk dtgstr(), dtgetd(), dtgeti(), dgsrestore() + +begin + # Locate the appropriate records. + iferr (rec = dtlocate (dt, record)) + return (ERR) + + # Open the coordinate structure. + iferr (call dtgstr (dt, rec, "coosystem", projection, SZ_FNAME)) + return (ERR) + coostat = sk_decwcs (projection, mw, coo, NULL) + if (coostat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + projection[1] = EOS + return (ERR) + } + + # Get the pixel coordinate system. + iferr (call dtgstr (dt, rec, "pixsystem", projection, SZ_FNAME)) { + pixsys = PIXTYPE_LOGICAL + } else { + pixsys = strdic (projection, projection, SZ_FNAME, PIXTYPE_LIST) + if (pixsys != PIXTYPE_PHYSICAL) + pixsys = PIXTYPE_LOGICAL + } + call sk_seti (coo, S_PIXTYPE, pixsys) + + + # Get the reference point units. + iferr (call dtgstr (dt, rec, "lngunits", projection, SZ_FNAME)) + return (ERR) + lngunits = strdic (projection, projection, SZ_FNAME, SKY_LNG_UNITLIST) + if (lngunits > 0) + call sk_seti (coo, S_NLNGUNITS, lngunits) + iferr (call dtgstr (dt, rec, "latunits", projection, SZ_FNAME)) + return (ERR) + latunits = strdic (projection, projection, SZ_FNAME, SKY_LAT_UNITLIST) + if (latunits > 0) + call sk_seti (coo, S_NLATUNITS, latunits) + + # Get the reference point. + iferr (call dtgstr (dt, rec, "projection", projection, SZ_FNAME)) + return (ERR) + iferr (lngref = dtgetd (dt, rec, "lngref")) + return (ERR) + iferr (latref = dtgetd (dt, rec, "latref")) + return (ERR) + + # Read in the coefficients. + iferr (ncoeff = dtgeti (dt, rec, "surface1")) + return (ERR) + call smark (sp) + call salloc (xcoeff, ncoeff, TY_DOUBLE) + call salloc (ycoeff, ncoeff, TY_DOUBLE) + do i = 1, ncoeff { + junk = dtscan(dt) + call gargd (Memd[xcoeff+i-1]) + call gargd (Memd[ycoeff+i-1]) + } + + # Restore the linear part of the fit. + call dgsrestore (sx1, Memd[xcoeff]) + call dgsrestore (sy1, Memd[ycoeff]) + + # Get and restore the distortion part of the fit. + ncoeff = dtgeti (dt, rec, "surface2") + if (ncoeff > 0) { + call salloc (nxcoeff, ncoeff, TY_DOUBLE) + call salloc (nycoeff, ncoeff, TY_DOUBLE) + do i = 1, ncoeff { + junk = dtscan(dt) + call gargd (Memd[nxcoeff+i-1]) + call gargd (Memd[nycoeff+i-1]) + } + iferr { + call dgsrestore (sx2, Memd[nxcoeff]) + } then { + call mfree (sx2, TY_STRUCT) + sx2 = NULL + } + iferr { + call dgsrestore (sy2, Memd[nycoeff]) + } then { + call mfree (sy2, TY_STRUCT) + sy2 = NULL + } + } else { + sx2 = NULL + sy2 = NULL + } + # Compute the coefficients. + call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) + + # Compute the reference point. + denom = a * d - c * b + if (denom == 0.0d0) + xref = INDEFD + else + xref = (b * yshift - d * xshift) / denom + if (denom == 0.0d0) + yref = INDEFD + else + yref = (c * xshift - a * yshift) / denom + + # Compute the scale factors. + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + + # Compute the rotation angles. + if (fp_equald (a, 0.0d0) && fp_equald (c, 0.0d0)) + xrot = 0.0d0 + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < 0.0d0) + xrot = xrot + 360.0d0 + if (fp_equald (b, 0.0d0) && fp_equald (d, 0.0d0)) + yrot = 0.0d0 + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < 0.0d0) + yrot = yrot + 360.0d0 + + # Read in up to 10 projection parameters. + call salloc (projpar, SZ_FNAME, TY_CHAR) + call salloc (projvalue, SZ_FNAME, TY_CHAR) + op = strlen (projection) + 1 + do i = 0, 9 { + call sprintf (Memc[projpar], SZ_FNAME, "projp%d") + call pargi (i) + iferr (call dtgstr (dt, rec, Memc[projpar], Memc[projvalue], + SZ_FNAME)) + next + op = op + gstrcpy (" ", projection[op], SZ_LINE - op + 1) + op = op + gstrcpy (Memc[projpar], projection[op], + SZ_LINE - op + 1) + op = op + gstrcpy (" = ", projection[op], SZ_LINE - op + 1) + op = op + gstrcpy (Memc[projvalue], projection[op], + SZ_LINE - op + 1) + } + + call sfree (sp) + + return (OK) +end diff --git a/pkg/images/imcoords/src/t_ccstd.x b/pkg/images/imcoords/src/t_ccstd.x new file mode 100644 index 00000000..d9ce3a6b --- /dev/null +++ b/pkg/images/imcoords/src/t_ccstd.x @@ -0,0 +1,468 @@ +include <fset.h> +include <ctype.h> +include <math.h> +include <pkg/skywcs.h> + + +define MAX_FIELDS 100 # Maximum number of fields in list +define TABSIZE 8 # Spacing of tab stops + +# T_CCSTD -- Transform a list of x and y and RA and DEC coordinates to +# their polar coordinate equivalents, after appying an optional linear +# transformation to the x and y side + +procedure t_ccstd() + +bool forward, polar +int inlist, outlist, reclist, infd, outfd +int xcolumn, ycolumn, lngcolumn, latcolumn, lngunits, latunits +int geometry, min_sigdigits +pointer sp, infile, outfile, record, str, dt, sx1, sy1, sx2, sy2, coo, mw +pointer xformat, yformat, lngformat, latformat +bool clgetb(), streq() +int fntopnb(), imtopenp(), fntlenb(), imtlen(), fntgfnb(), imtgetim() +int open(), clgwrd(), clgeti() +pointer dtmap() + +begin + # Allocate memory for transformation parameters structure + call smark (sp) + call salloc (infile, SZ_FNAME, TY_CHAR) + call salloc (outfile, 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 (lngformat, SZ_FNAME, TY_CHAR) + call salloc (latformat, 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 ("solutions") + geometry = clgwrd ("geometry", Memc[str], SZ_LINE, + ",linear,distortion,geometric,") + } else { + dt = NULL + reclist = NULL + geometry = 0 + } + forward = clgetb ("forward") + polar = clgetb ("polar") + + # 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 the input file format parameters. + xcolumn = clgeti ("xcolumn") + ycolumn = clgeti ("ycolumn") + lngcolumn = clgeti ("lngcolumn") + latcolumn = clgeti ("latcolumn") + iferr (lngunits = clgwrd ("lngunits", Memc[str], SZ_LINE, + SKY_LNG_UNITLIST)) + lngunits = 0 + iferr (latunits = clgwrd ("latunits", Memc[str], SZ_LINE, + SKY_LAT_UNITLIST)) + latunits = 0 + + # Get the output file format parameters. + call clgstr ("lngformat", Memc[lngformat], SZ_FNAME) + call clgstr ("latformat", Memc[latformat], SZ_FNAME) + 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[outfile], SZ_FNAME) == EOF) + call strcpy ("STDOUT", Memc[outfile], SZ_FNAME) + outfd = open (Memc[outfile], NEW_FILE, TEXT_FILE) + if (streq (Memc[outfile], "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. + coo = NULL; sx1 = NULL; sy1 = NULL; sx2 = NULL; sy2 = NULL + call cc_init_std (dt, Memc[record], geometry, lngunits, + latunits, sx1, sy1, sx2, sy2, mw, coo) + + # While input list is not depleted, open file and transform list. + while (fntgfnb (inlist, Memc[infile], SZ_FNAME) != EOF) { + + infd = open (Memc[infile], READ_ONLY, TEXT_FILE) + + # Transform the coordinates. + call cc_transform_std (infd, outfd, xcolumn, ycolumn, lngcolumn, + latcolumn, lngunits, latunits, Memc[xformat], Memc[yformat], + Memc[lngformat], Memc[latformat], min_sigdigits, sx1, sy1, sx2, + sy2, mw, coo, forward, polar) + + # 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[outfile], SZ_FNAME) != EOF) + outfd = open (Memc[outfile], NEW_FILE, TEXT_FILE) + if (streq (Memc[outfile], "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 cc_free_std (sx1, sy1, sx2, sy2, mw, coo) + call cc_init_std (dt, Memc[record], geometry, + lngunits, latunits, sx1, sy1, sx2, sy2, mw, coo) + } + } + } + + # Free the surface descriptors. + call cc_free_std (sx1, sy1, sx2, sy2, mw, coo) + + # 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 + + +# CC_TRANSFORM_STD -- 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 cc_transform_std (infd, outfd, xfield, yfield, lngfield, latfield, + lngunits, latunits, xformat, yformat, lngformat, latformat, + min_sigdigits, sx1, sy1, sx2, sy2, mw, coo, forward, polar) + +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 lngfield #I the ra / longitude column number +int latfield #I the dec / latitude column number +int lngunits #I the ra / longitude units +int latunits #I the dec / latitude units +char xformat[ARB] #I output format of the r / x coordinate +char yformat[ARB] #I output format of the t / y coordinate +char lngformat[ARB] #I output format of the r / longitude coordinate +char latformat[ARB] #I output format of the t / latitude 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 +pointer mw #I pointer to the mwcs structure +pointer coo #I pointer to the celestial coordinate structure +bool forward #I Is the transform in the forward direction ? +bool polar #I Polar standard coordinates ? + +double xd, yd, lngd, latd, txd, tyd, tlngd, tlatd +int max_fields, nline, nfields, nchars +int offset, tlngunits, tlatunits +pointer sp, inbuf, linebuf, field_pos, outbuf, ip, ct +pointer vfields, values, nsdigits, vformats +int getline(), li_get_numd(), sk_stati() +pointer mw_sctran() + +begin + # Allocate some working space. + 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) + call salloc (vfields, 4, TY_INT) + call salloc (values, 4, TY_DOUBLE) + call salloc (nsdigits, 4, TY_INT) + call salloc (vformats, (SZ_FNAME + 1) * 4, TY_CHAR) + + # Determine the longitude and latitude units. + if (lngunits <= 0) { + if (coo == NULL) + tlngunits = SKY_HOURS + else + tlngunits = sk_stati (coo, S_NLNGUNITS) + } else + tlngunits = lngunits + if (latunits <= 0) { + if (coo == NULL) + tlatunits = SKY_DEGREES + else + tlatunits = sk_stati (coo, S_NLATUNITS) + } else + tlatunits = latunits + + # Set the output fields. + Memi[vfields] = xfield + Memi[vfields+1] = yfield + Memi[vfields+2] = lngfield + Memi[vfields+3] = latfield + + # If the formats are undefined set suitable default formats. + if (lngformat[1] == EOS) { + if (forward) + call strcpy ("%10.3f", Memc[vformats+2*(SZ_FNAME+1)], SZ_FNAME) + else { + switch (tlngunits) { + case SKY_HOURS: + call strcpy ("%12.2h", Memc[vformats+2*(SZ_FNAME+1)], + SZ_FNAME) + case SKY_DEGREES: + call strcpy ("%11.1h", Memc[vformats+2*(SZ_FNAME+1)], + SZ_FNAME) + case SKY_RADIANS: + call strcpy ("%13.7g", Memc[vformats+2*(SZ_FNAME+1)], + SZ_FNAME) + default: + call strcpy ("%10.3f", Memc[vformats+2*(SZ_FNAME+1)], + SZ_FNAME) + } + } + } else + call strcpy (lngformat, Memc[vformats+2*(SZ_FNAME+1)], SZ_FNAME) + + if (latformat[1] == EOS) { + if (forward) + call strcpy ("%10.3f", Memc[vformats+3*(SZ_FNAME+1)], SZ_FNAME) + else { + switch (tlatunits) { + case SKY_HOURS: + call strcpy ("%12.2h", Memc[vformats+3*(SZ_FNAME+1)], + SZ_FNAME) + case SKY_DEGREES: + call strcpy ("%11.1h", Memc[vformats+3*(SZ_FNAME+1)], + SZ_FNAME) + case SKY_RADIANS: + call strcpy ("%13.7g", Memc[vformats+3*(SZ_FNAME+1)], + SZ_FNAME) + default: + call strcpy ("%10.3f", Memc[vformats+3*(SZ_FNAME+1)], + SZ_FNAME) + } + } + } else + call strcpy (latformat, Memc[vformats+3*(SZ_FNAME+1)], SZ_FNAME) + + if (xformat[1] == EOS) + call strcpy ("%10.3f", Memc[vformats], SZ_FNAME) + else + call strcpy (xformat, Memc[vformats], SZ_FNAME) + if (yformat[1] == EOS) + call strcpy ("%10.3f", Memc[vformats+(SZ_FNAME+1)], SZ_FNAME) + else + call strcpy (yformat, Memc[vformats+(SZ_FNAME+1)], SZ_FNAME) + + + # If the transformation can be represented by mwcs then compile the + # appropriate transform. Other wise use the surface fitting code + # to do the transformation. + if (mw != NULL) { + if (forward) + ct = mw_sctran (mw, "world", "logical", 03B) + else + ct = mw_sctran (mw, "logical", "world", 03B) + } + + max_fields = MAX_FIELDS + 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 + } + + # If the transformation is undefined then pass the line on + # undisturbed. + if (mw == NULL) { + 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) + + # Check that all the data is present. + if (lngfield > nfields || latfield > nfields || 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 + } + + # Read the longitude / latitude or rstd / thetastd coordinates. + offset = Memi[field_pos+lngfield-1] + nchars = li_get_numd (Memc[linebuf+offset-1], lngd, + Memi[nsdigits+2]) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad lng / xi 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+latfield-1] + nchars = li_get_numd (Memc[linebuf+offset-1], latd, + Memi[nsdigits+3]) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad lat / eta value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + # Read the x and y or r and theta coordinates. + offset = Memi[field_pos+xfield-1] + nchars = li_get_numd (Memc[linebuf+offset-1], xd, Memi[nsdigits]) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad x / r 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] + nchars = li_get_numd (Memc[linebuf+offset-1], yd, Memi[nsdigits+1]) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad y / theta value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + # Transform the longitude / latitude coordinates in lngunits / + # latunits to / from the xi / eta coordinates in arcseconds, and + # transform the x and y coordinates to or from the r and theta + # coordinates. + if (forward) { + switch (tlngunits) { + case SKY_RADIANS: + tlngd = RADTODEG(lngd) + case SKY_HOURS: + tlngd = 15.0d0 * lngd + default: + tlngd = lngd + } + switch (tlatunits) { + case SKY_RADIANS: + tlatd = RADTODEG(latd) + case SKY_HOURS: + tlatd = 15.0d0 * latd + default: + tlatd = latd + } + txd = xd + tyd = yd + } else if (polar) { + tlngd = lngd * cos (DEGTORAD(latd)) / 3600.0d0 + tlatd = lngd * sin (DEGTORAD(latd)) / 3600.0d0 + txd = xd * cos (DEGTORAD(yd)) + tyd = xd * sin (DEGTORAD(yd)) + } else { + tlngd = lngd / 3600.0d0 + tlatd = latd / 3600.0d0 + txd = xd + tyd = yd + } + call mw_c2trand (ct, tlngd, tlatd, lngd, latd) + call cc_do_std (txd, tyd, xd, yd, sx1, sy1, sx2, sy2, forward) + if (! forward) { + switch (tlngunits) { + case SKY_RADIANS: + Memd[values+2] = DEGTORAD(lngd) + case SKY_HOURS: + Memd[values+2] = lngd / 15.0d0 + default: + Memd[values+2] = lngd + } + switch (tlatunits) { + case SKY_RADIANS: + Memd[values+3] = DEGTORAD(latd) + case SKY_HOURS: + Memd[values+3] = latd / 15.0d0 + default: + Memd[values+3] = latd + } + Memd[values] = xd + Memd[values+1] = yd + } else if (polar) { + Memd[values] = sqrt (xd * xd + yd * yd) + Memd[values+1] = RADTODEG(atan2 (yd, xd)) + if (Memd[values+1] < 0.0d0) + Memd[values+1] = Memd[values+1] + 360.0d0 + Memd[values+2] = sqrt (lngd * lngd + latd * latd) * 3600.0d0 + Memd[values+3] = RADTODEG (atan2 (latd, lngd)) + if (Memd[values+3] < 0.0d0) + Memd[values+3] = Memd[values+3] + 360.0d0 + } else { + Memd[values] = xd + Memd[values+1] = yd + Memd[values+2] = lngd * 3600.0d0 + Memd[values+3] = latd * 3600.0d0 + } + + # Format the output line. + call li_npack_lined (Memc[linebuf], Memc[outbuf], SZ_LINE, + Memi[field_pos], nfields, Memi[vfields], Memd[values], + Memi[nsdigits], 4, Memc[vformats], SZ_FNAME, min_sigdigits) + + call putline (outfd, Memc[outbuf]) + } + + if (ct != NULL) + call mw_ctfree (ct) + + call sfree (sp) +end diff --git a/pkg/images/imcoords/src/t_cctran.x b/pkg/images/imcoords/src/t_cctran.x new file mode 100644 index 00000000..6efeaf35 --- /dev/null +++ b/pkg/images/imcoords/src/t_cctran.x @@ -0,0 +1,374 @@ +include <fset.h> +include <ctype.h> +include <math.h> +include <pkg/skywcs.h> + + +define MAX_FIELDS 100 # Maximum number of fields in list +define TABSIZE 8 # Spacing of tab stops + +# T_CCTRAN -- Transform a list of x and y coordinates to RA nad DEC or vice +# versa using the celestial coordinate transformation computed by the CCMAP +# task. + +procedure t_cctran() + +bool forward +int inlist, outlist, reclist, geometry, xcolumn, ycolumn, min_sigdigits +int infd, outfd, lngunits, latunits +pointer sp, infile, outfile, record, xformat, yformat, str, dt +pointer sx1, sy1, sx2, sy2, coo, mw +bool clgetb(), streq() +int fntopnb(), imtopenp(), fntlenb(), fntgfnb(), clgwrd(), clgeti() +int open(), imtgetim (), imtlen() +pointer dtmap() + +begin + # Allocate memory for transformation parameters structure + call smark (sp) + call salloc (infile, SZ_FNAME, TY_CHAR) + call salloc (outfile, 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 ("solution") + } 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 the fitting geometry. + geometry = clgwrd ("geometry", Memc[str], SZ_LINE, + ",linear,distortion,geometric,") + forward = clgetb ("forward") + + # Get the input and output file parameters. + iferr (lngunits = clgwrd ("lngunits", Memc[str], SZ_LINE, + SKY_LNG_UNITLIST)) + lngunits = 0 + iferr (latunits = clgwrd ("latunits", Memc[str], SZ_LINE, + SKY_LAT_UNITLIST)) + latunits = 0 + xcolumn = clgeti ("xcolumn") + ycolumn = clgeti ("ycolumn") + call clgstr ("lngformat", Memc[xformat], SZ_FNAME) + call clgstr ("latformat", Memc[yformat], SZ_FNAME) + min_sigdigits = clgeti ("min_sigdigits") + + # Get the output file name. + if (fntgfnb (outlist, Memc[outfile], SZ_FNAME) == EOF) + call strcpy ("STDOUT", Memc[outfile], SZ_FNAME) + outfd = open (Memc[outfile], NEW_FILE, TEXT_FILE) + if (streq (Memc[outfile], "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. + coo = NULL; sx1 = NULL; sy1 = NULL; sx2 = NULL; sy2 = NULL + call cc_init_transform (dt, Memc[record], geometry, lngunits, + latunits, sx1, sy1, sx2, sy2, mw, coo) + + # While input list is not depleted, open file and transform list. + while (fntgfnb (inlist, Memc[infile], SZ_FNAME) != EOF) { + + infd = open (Memc[infile], READ_ONLY, TEXT_FILE) + + # Transform the coordinates. + call cc_transform_file (infd, outfd, xcolumn, ycolumn, lngunits, + latunits, Memc[xformat], Memc[yformat], min_sigdigits, sx1, + sy1, sx2, sy2, mw, coo, forward) + + # 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[outfile], SZ_FNAME) != EOF) + outfd = open (Memc[outfile], NEW_FILE, TEXT_FILE) + if (streq (Memc[outfile], "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 cc_free_transform (sx1, sy1, sx2, sy2, mw, coo) + call cc_init_transform (dt, Memc[record], geometry, + lngunits, latunits, sx1, sy1, sx2, sy2, mw, coo) + } + } + } + + # Free the surface descriptors. + call cc_free_transform (sx1, sy1, sx2, sy2, mw, coo) + + # 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 + + +# CC_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 cc_transform_file (infd, outfd, xfield, yfield, lngunits, + latunits, xformat, yformat, min_sigdigits, sx1, sy1, sx2, sy2, + mw, coo, forward) + +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 lngunits #I the ra / longitude units +int latunits #I the dec / latitude units +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 +pointer mw #I pointer to the mwcs structure +pointer coo #I pointer to the celestial coordinate structure +bool forward #I forwards transform ? + +double xd, yd, xtd, ytd +int max_fields, nline, nfields, nchars, nsdig_x, nsdig_y, offset +int tlngunits, tlatunits +pointer sp, inbuf, linebuf, field_pos, outbuf, ip, ct, txformat, tyformat +int getline(), li_get_numd(), sk_stati() +pointer mw_sctran() + +begin + # Allocate some working space. + 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) + call salloc (txformat, SZ_LINE, TY_CHAR) + call salloc (tyformat, SZ_LINE, TY_CHAR) + + # Determine the units. + if (lngunits <= 0) { + if (coo == NULL) + tlngunits = SKY_HOURS + else + tlngunits = sk_stati (coo, S_NLNGUNITS) + } else + tlngunits = lngunits + if (latunits <= 0) { + if (coo == NULL) + tlatunits = SKY_DEGREES + else + tlatunits = sk_stati (coo, S_NLATUNITS) + } else + tlatunits = latunits + + # If the formats are undefined set suitable default formats. + if (xformat[1] == EOS) { + if (! forward) + call strcpy ("%10.3f", Memc[txformat], SZ_FNAME) + else { + switch (tlngunits) { + case SKY_HOURS: + call strcpy ("%12.2h", Memc[txformat], SZ_FNAME) + case SKY_DEGREES: + call strcpy ("%11.1h", Memc[txformat], SZ_FNAME) + case SKY_RADIANS: + call strcpy ("%13.7g", Memc[txformat], SZ_FNAME) + default: + call strcpy ("%10.3f", Memc[txformat], SZ_FNAME) + } + } + } else + call strcpy (xformat, Memc[txformat], SZ_FNAME) + + if (yformat[1] == EOS) { + if (! forward) + call strcpy ("%10.3f", Memc[tyformat], SZ_FNAME) + else { + switch (tlatunits) { + case SKY_HOURS: + call strcpy ("%12.2h", Memc[tyformat], SZ_FNAME) + case SKY_DEGREES: + call strcpy ("%11.1h", Memc[tyformat], SZ_FNAME) + case SKY_RADIANS: + call strcpy ("%13.7g", Memc[tyformat], SZ_FNAME) + default: + call strcpy ("%10.3f", Memc[tyformat], SZ_FNAME) + } + } + } else + call strcpy (yformat, Memc[tyformat], SZ_FNAME) + + # If the transformation can be represented by mwcs then compile the + # appropriate transform. Other wise use the surface fitting code + # to do the transformation. + if (mw != NULL) { + if (forward) + ct = mw_sctran (mw, "logical", "world", 03B) + else + ct = mw_sctran (mw, "world", "logical", 03B) + } + + max_fields = MAX_FIELDS + 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 + } + + # If the transformation is undefined then pass the line on + # undisturbed. + if (mw == NULL) { + 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] + 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] + 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 + } + + # Transform the coordinates. + if (! forward) { + switch (tlngunits) { + case SKY_RADIANS: + xd = RADTODEG(xd) + case SKY_HOURS: + xd = 15.0d0 * xd + default: + ; + } + switch (tlatunits) { + case SKY_RADIANS: + yd = RADTODEG(yd) + case SKY_HOURS: + yd = 15.0d0 * yd + default: + ; + } + } + if (sx2 != NULL || sy2 != NULL) + call cc_do_transform (xd, yd, xtd, ytd, ct, sx1, sy1, + sx2, sy2, forward) + else + call mw_c2trand (ct, xd, yd, xtd, ytd) + if (forward) { + switch (tlngunits) { + case SKY_RADIANS: + xtd = DEGTORAD(xtd) + case SKY_HOURS: + xtd = xtd / 15.0d0 + default: + ; + } + switch (tlatunits) { + case SKY_RADIANS: + ytd = DEGTORAD(ytd) + case SKY_HOURS: + ytd = ytd / 15.0d0 + default: + ; + } + } + + # Format the output line. + call li_pack_lined (Memc[linebuf], Memc[outbuf], SZ_LINE, + Memi[field_pos], nfields, xfield, yfield, xtd, ytd, + Memc[txformat], Memc[tyformat], nsdig_x, nsdig_y, min_sigdigits) + + call putline (outfd, Memc[outbuf]) + } + + if (ct != NULL) + call mw_ctfree (ct) + + call sfree (sp) +end + diff --git a/pkg/images/imcoords/src/t_ccxymatch.x b/pkg/images/imcoords/src/t_ccxymatch.x new file mode 100644 index 00000000..ea34b6c0 --- /dev/null +++ b/pkg/images/imcoords/src/t_ccxymatch.x @@ -0,0 +1,576 @@ +include <fset.h> +include <pkg/skywcs.h> +include "../../lib/xyxymatch.h" + +# T_CCXYMATCH -- This task computes the intersection of a set of pixel +# coordinate lists with a reference celestial coordinate list. The output is +# the set of objects common to both lists. In its simplest form CCXYMATCH +# uses a matching tolerance to generate the common list. Alternatively +# CCXYMATCH 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_ccxymatch() + +bool verbose +double lngin, latin, tlngin, tlatin +int ilist, rlist, olist, xcol, ycol, lngcol, latcol, lngunits, latunits +int match, maxntriangles, nreject, rfd, rpfd, ifd, ofd, pfd +int ntrefstars, nreftie, nrefstars, nrmaxtri, nreftri, nintie, ntie +int ntliststars, nliststars, ninter, ninmaxtri, nintri, proj +pointer sp, inname, refname, outname, refpoints, xreftie, yreftie +pointer xintie, yintie, coeff, projection, str +pointer xformat, yformat, lngformat, latformat +pointer lngref, latref, xref, yref, rlineno, rsindex, reftri, reftrirat +pointer xtrans, ytrans, listindex, xlist, ylist, ilineno, intri, intrirat +real tolerance, ptolerance, xin, yin, xmag, ymag, xrot, yrot +real pseparation, separation, ratio + +bool clgetb() +double clgetd() +int fstati(), clpopnu(), clplen(), clgeti(), clgwrd(), open(), clgfil() +int rg_getrefcel(), rg_rdlli(), rg_sort(), rg_factorial(), rg_triangle() +int rg_getreftie(), rg_lincoeff(), rg_rdxyi(), rg_llintersect() +int rg_match(), rg_mlincoeff(), cc_rdproj(), strdic() +real clgetr() +errchk open() + +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 (projection, SZ_LINE, TY_CHAR) + call salloc (xformat, SZ_FNAME, TY_CHAR) + call salloc (yformat, SZ_FNAME, TY_CHAR) + call salloc (lngformat, SZ_FNAME, TY_CHAR) + call salloc (latformat, 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") + match = clgwrd ("matching", Memc[str], SZ_LINE, RG_MATCHSTR) + if (match == RG_TRIANGLES) + ptolerance = clgetr ("ptolerance") + else + ptolerance = 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") + lngcol = clgeti ("lngcolumn") + latcol = clgeti ("latcolumn") + lngunits = clgwrd ("lngunits", Memc[str], SZ_FNAME, SKY_LNG_UNITLIST) + latunits = clgwrd ("latunits", Memc[str], SZ_FNAME, SKY_LAT_UNITLIST) + + call clgstr ("projection", Memc[projection], SZ_LINE) + iferr { + pfd = open (Memc[projection], READ_ONLY, TEXT_FILE) + } then { + proj = strdic (Memc[projection], Memc[projection], SZ_LINE, + WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projection] = EOS + } else { + proj = cc_rdproj (pfd, Memc[projection], SZ_LINE) + call close (pfd) + } + + # Get the matching parameters. + 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 + lngin = clgetd ("lngref") + latin = clgetd ("latref") + + # Get the algorithm parameters. + pseparation = clgetr ("pseparation") + 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) + call clgstr ("lngformat", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) { + switch (lngunits) { + case SKY_HOURS, SKY_DEGREES: + call strcpy ("%13.3h", Memc[lngformat], SZ_FNAME) + case SKY_RADIANS: + call strcpy ("%13.7g", Memc[lngformat], SZ_FNAME) + default: + call strcpy ("%10.3f", Memc[lngformat], SZ_FNAME) + } + } else + call strcpy (Memc[str], Memc[lngformat], SZ_FNAME) + call clgstr ("latformat", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) { + switch (latunits) { + case SKY_HOURS, SKY_DEGREES: + call strcpy ("%13.2h", Memc[latformat], SZ_FNAME) + case SKY_RADIANS: + call strcpy ("%13.7g", Memc[latformat], SZ_FNAME) + default: + call strcpy ("%10.3f", Memc[latformat], SZ_FNAME) + } + } else + call strcpy (Memc[str], Memc[latformat], SZ_FNAME) + + 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. + lngref = NULL + latref = NULL + 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) + + # Read the reference data. + if (lngref != NULL) + call mfree (lngref, TY_DOUBLE) + if (latref != NULL) + call mfree (latref, TY_DOUBLE) + 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_rdlli (rfd, lngref, latref, xref, yref, rlineno, + tlngin, tlatin, lngcol, latcol, Memc[projection], lngin, + latin, lngunits, latunits) + + # 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. + + call malloc (rsindex, ntrefstars, TY_INT) + 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 + } + + + # Fetch the reference tie points if any. + if (rpfd != NULL) + nreftie = rg_getrefcel (rpfd, Memr[xreftie], Memr[yreftie], + 3, Memc[projection], tlngin, tlatin, lngunits, latunits, + RG_REFFILE) + else + nreftie = 0 + + break + } + + # Fetch the input tie points and compute the coefficients. + if (rpfd != NULL) + nintie = rg_getreftie (rpfd, Memr[xintie], + Memr[yintie], nreftie, RG_INFILE, false) + else + nintie = 0 + ntie = min (nreftie, nintie) + if (ntie <= 0) + call rg_lmkcoeff (xin, yin, xmag, ymag, xrot, yrot, + 0.0, 0.0, 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, + 0.0, 0.0, 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 (" xi", " eta", Memr[xreftie], + Memr[yreftie], Memr[xintie], Memr[yintie], ntie, + Memr[coeff], MAX_NCOEFF) + call rg_wlincoeff (ofd, " xi", " eta", 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_pllcolumns (ofd) + ninter = rg_llintersect (ofd, Memd[lngref], Memd[latref], + Memr[xref], Memr[yref], Memi[rsindex], Memi[rlineno], + nrefstars, Memr[xlist], Memr[ylist], Memr[xtrans], + Memr[ytrans], Memi[listindex], Memi[ilineno], + nliststars, tolerance, Memc[lngformat], + Memc[latformat],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, + ptolerance, 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, ptolerance, + ratio, nreject) + } + if (nrefstars <= maxntriangles && nliststars <= + maxntriangles) { + call rg_pllcolumns (ofd) + call rg_lmwrite (ofd, Memd[lngref], Memd[latref], + Memi[rlineno], Memr[xlist], Memr[ylist], + Memi[ilineno], Memi[reftri], nrmaxtri, + Memi[intri], ninmaxtri, ninter, Memc[lngformat], + Memc[latformat], 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, + 0.0, 0.0, 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 (" xi", " eta", Memr[coeff], + MAX_NCOEFF) + call rg_wmlincoeff (ofd, " xi", " eta", Memr[coeff], + MAX_NCOEFF) + call rg_pllcolumns (ofd) + ninter = rg_llintersect (ofd, Memd[lngref], + Memd[latref], Memr[xref], Memr[yref], Memi[rsindex], + Memi[rlineno], nrefstars, Memr[xlist], Memr[ylist], + Memr[xtrans], Memr[ytrans], Memi[listindex], + Memi[ilineno], nliststars, tolerance, + Memc[lngformat], Memc[latformat], 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 (lngref, TY_DOUBLE) + call mfree (latref, TY_DOUBLE) + 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_RDLLI -- Read in the celestial coordinates from a file, convert them +# to standard coordinates, and set the line number index. + +int procedure rg_rdlli (fd, lng, lat, x, y, lineno, tlngref, tlatref, + xcolumn, ycolumn, projection, lngref, latref, lngunits, latunits) + +int fd #I the input file descriptor +pointer lng #U pointer to the x coordinates +pointer lat #U pointer to the y coordinates +pointer x #U pointer to the x coordinates +pointer y #U pointer to the y coordinates +pointer lineno #U pointer to the line numbers +double tlngref #O the adopted reference ra / longitude +double tlatref #O the adopted reference dec / latitude +int xcolumn #I column containing the x coordinate +int ycolumn #I column containing the y coordinate +char projection[ARB] #I the sky projection geometry +double lngref #I the input reference ra / longitude +double latref #I the input reference dec / latitude +int lngunits #I the ra / longitude units +int latunits #I the dec / latitude units + +int i, ip, bufsize, npts, lnpts, maxcols +double xval, yval +pointer sp, str, tx, ty +int fscan(), nscan(), ctod() +double asumd() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + bufsize = DEF_BUFSIZE + call malloc (lng, bufsize, TY_DOUBLE) + call malloc (lat, bufsize, TY_DOUBLE) + call malloc (x, bufsize, TY_REAL) + call malloc (y, bufsize, TY_REAL) + call malloc (lineno, bufsize, TY_INT) + maxcols = max (xcolumn, ycolumn) + + npts = 0 + lnpts = 0 + while (fscan(fd) != EOF) { + + lnpts = lnpts + 1 + xval = INDEFD + yval = INDEFD + do i = 1, maxcols { + call gargwrd (Memc[str], SZ_LINE) + 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[lng+npts] = xval + Memd[lat+npts] = yval + Memi[lineno+npts] = lnpts + npts = npts + 1 + if (npts >= bufsize) { + bufsize = bufsize + DEF_BUFSIZE + call realloc (lng, bufsize, TY_DOUBLE) + call realloc (lat, bufsize, TY_DOUBLE) + call realloc (x, bufsize, TY_REAL) + call realloc (y, bufsize, TY_REAL) + call realloc (lineno, bufsize, TY_INT) + } + } + + # Compute the reference point and convert to standard coordinates. + if (npts > 0) { + if (IS_INDEFD(lngref)) + tlngref = asumd (Memd[lng], npts) / npts + else + tlngref = lngref + if (IS_INDEFD(latref)) + tlatref = asumd (Memd[lat], npts) / npts + else + tlatref = latref + call salloc (tx, npts, TY_DOUBLE) + call salloc (ty, npts, TY_DOUBLE) + call rg_celtostd (projection, Memd[lng], Memd[lat], Memd[tx], + Memd[ty], npts, tlngref, tlatref, lngunits, latunits) + call amulkd (Memd[tx], 3600.0d0, Memd[tx], npts) + call amulkd (Memd[ty], 3600.0d0, Memd[ty], npts) + call achtdr (Memd[tx], Memr[x], npts) + call achtdr (Memd[ty], Memr[y], npts) + } else { + tlngref = lngref + tlatref = latref + } + + call sfree (sp) + + return (npts) +end + + +# RG_PLLCOLUMNS -- Print the column descriptions in the output file. + +procedure rg_pllcolumns (ofd) + +int ofd #I the output file descriptor + +begin + call fprintf (ofd, "# Column definitions\n") + call fprintf (ofd, + "# Column 1: Reference Ra / Longitude coordinate\n") + call fprintf (ofd, + "# Column 2: Reference Dec / Latitude coordinate\n") + call fprintf (ofd, "# Column 3: Input X coordinate\n") + call fprintf (ofd, "# Column 4: Input Y 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/imcoords/src/t_hpctran.x b/pkg/images/imcoords/src/t_hpctran.x new file mode 100644 index 00000000..aa398186 --- /dev/null +++ b/pkg/images/imcoords/src/t_hpctran.x @@ -0,0 +1,136 @@ +include <math.h> + +define DIRS "|ang2row|row2ang|" +define ANG2PIX 1 +define PIX2ANG 2 + +define CUNITS "|hourdegree|degrees|radians|" +define H 1 +define D 2 +define R 3 + +define MTYPES "|nest|ring|" +define NEST 1 +define RING 2 + + +# T_HPCTRAN -- Convert between HEALPix rows and spherical coordinates. +# +# It is up to the user to know the coordinate and map type; e.g. +# galactic/nested, equatorial/ring. However, the use can use +# whatever units for the coordinate type; e.g. hours/degrees, radians. +# +# The HEALPix row is 1 indexed to be consistent with IRAF conventions. +# This row can be used to access the map data with TTOOLS tasks. + +procedure t_hpctran () + +int dir # Direction (ang2row|row2ang) +int row # HEALpix map row (1 indexed) +double lng # RA/longitude +double lat # DEC/latitude +int nside # Resolution parameter +int cunits # Coordinate units +int mtype # HEALpix map type + +char str[10] + +int clgeti(), clgwrd() +double clgetd() +errchk ang2row, row2ang + +begin + # Get parameters. + dir = clgwrd ("direction", str, 10, DIRS) + nside = clgeti ("nside") + cunits = clgwrd ("cunits", str, 10, CUNITS) + mtype = clgwrd ("maptype", str, 10, MTYPES) + + switch (dir) { + case ANG2PIX: + lng = clgetd ("lng") + lat = clgetd ("lat") + switch (cunits) { + case 0: + call error (1, "Unknown coordinate units") + case H: + lng = lng * 15D0 + case R: + lng = RADTODEG(lng) + lat = RADTODEG(lat) + } + + call ang2row (row, lng, lat, mtype, nside) + + call clputi ("row", row) + case PIX2ANG: + row = clgeti ("row") + + call row2ang (row, lng, lat, mtype, nside) + + switch (cunits) { + case 0: + call error (1, "Unknown coordinate units") + case H: + lng = lng / 15D0 + case R: + lng = DEGTORAD(lng) + lat = DEGTORAD(lat) + } + + call clputd ("lng", lng) + call clputd ("lat", lat) + } + + # Output the map row. + call printf ("%d %g %g\n") + call pargi (row) + call pargd (lng) + call pargd (lat) +end + + +# TEST_HEALPIX2 -- Test routine as in the HEALPix distribution. + +procedure test_healpix2 () + +double theta, phi +int nside +int ipix, npix, dpix, ip1 + +begin + + call printf("Starting C Healpix pixel routines test\n") + + nside = 1024 + dpix = 23 + + # Find the number of pixels in the full map + npix = 12*nside*nside + call printf("Number of pixels in full map: %d\n") + call pargi (npix) + + call printf("dpix: %d\n") + call pargi (dpix) + call printf("Nest -> ang -> Ring -> ang -> Nest\n") +# call printf("Nest -> ang -> Nest\n") +# call printf("Ring -> ang -> Ring\n") + for (ipix = 0; ipix < npix; ipix = ipix + dpix) { + call pix2ang_nest(nside, ipix, theta, phi) + call ang2pix_ring(nside, theta, phi, ip1) + call pix2ang_ring(nside, ip1, theta, phi) + call ang2pix_nest(nside, theta, phi, ip1) +# call pix2ang_ring(nside, ipix, theta, phi) +# call ang2pix_ring(nside, theta, phi, ip1) + if (ip1 != ipix) { + call printf("Error: %d %d %d\n") + call pargi (nside) + call pargi (ipix) + call pargi (ip1) + } + } + + call printf("%d\n") + call pargi (nside) + call printf("test completed\n\n") +end diff --git a/pkg/images/imcoords/src/t_imcctran.x b/pkg/images/imcoords/src/t_imcctran.x new file mode 100644 index 00000000..4729a85d --- /dev/null +++ b/pkg/images/imcoords/src/t_imcctran.x @@ -0,0 +1,922 @@ +include <fset.h> +include <imhdr.h> +include <math.h> +include <mwset.h> +include <math/gsurfit.h> +include <pkg/skywcs.h> + +procedure t_imcctran () + +double tilng, tilat, tolng, tolat, xscale, yscale, xrot, yrot, xrms, yrms +double olongpole, olatpole, nlongpole, nlatpole +pointer sp, imtemplate, insystem, outsystem, image, str +pointer im, mwin, cooin, mwout, cooout, ctin, ctout +pointer r, w, cd, ltm, ltv, iltm, nr, ncd, jr +pointer ix, iy, ox, oy, ilng, ilat, olng, olat +int imlist, nxgrid, nygrid, npts, instat, outstat, ndim, fitstat, axbits +bool uselp, verbose, update, usecd + +double rg_rmsdiff() +pointer immap(), rg_xytoxy(), mw_newcopy() +int fstati(), imtopen(), imtgetim(), sk_decim(), sk_decwcs(), mw_stati() +int clgeti(), sk_stati(), rg_cdfit() +bool clgetb(), rg_longpole() + +begin + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate working space. + call smark (sp) + call salloc (imtemplate, SZ_FNAME, TY_CHAR) + call salloc (insystem, SZ_FNAME, TY_CHAR) + call salloc (outsystem, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the list of images and output coordinate system. + call clgstr ("image", Memc[imtemplate], SZ_FNAME) + call clgstr ("outsystem", Memc[outsystem], SZ_FNAME) + + # Get the remaining parameters. + nxgrid = clgeti ("nx") + nygrid = clgeti ("ny") + npts = nxgrid * nygrid + uselp = clgetb ("longpole") + verbose = clgetb ("verbose") + update = clgetb ("update") + + # Loop over the list of images + imlist = imtopen (Memc[imtemplate]) + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # Open the input image after removing any section notation. + call imgimage (Memc[image], Memc[image], SZ_FNAME) + if (update) + im = immap (Memc[image], READ_WRITE, 0) + else + im = immap (Memc[image], READ_ONLY, 0) + if (verbose) { + call printf ("INPUT IMAGE: %s\n") + call pargstr (Memc[image]) + } + + # Create the input system name. + call sprintf (Memc[insystem], SZ_FNAME, "%s logical") + call pargstr (Memc[image]) + + # Open the input image coordinate system. + instat = sk_decim (im, "logical", mwin, cooin) + if (verbose) { + if (instat == ERR || mwin == NULL) + call printf ("Error decoding the input coordinate system\n") + call sk_iiprint ("Insystem", Memc[insystem], mwin, cooin) + } + if (instat == ERR || mwin == NULL) { + if (mwin != NULL) + call mw_close (mwin) + #call mfree (cooin, TY_STRUCT) + call sk_close (cooin) + call imunmap (im) + next + } + + # Open the output coordinate system. + outstat = sk_decwcs (Memc[outsystem], mwout, cooout, cooin) + if (verbose) { + if (outstat == ERR || mwout != NULL) + call printf ( + "Error decoding the output coordinate system\n") + call sk_iiprint ("Outsystem", Memc[outsystem], mwout, cooout) + } + if (outstat == ERR || mwout != NULL) { + if (mwout != NULL) + call mw_close (mwout) + #call mfree (cooout, TY_STRUCT) + call sk_close (cooout) + call sfree (sp) + return + } + + # Get the dimensionality of the wcs. + ndim = mw_stati (mwin, MW_NPHYSDIM) + + # Allocate working memory for the vectors and matrices. + call malloc (r, ndim, TY_DOUBLE) + call malloc (w, ndim, TY_DOUBLE) + call malloc (cd, ndim * ndim, TY_DOUBLE) + call malloc (ltm, ndim * ndim, TY_DOUBLE) + call malloc (ltv, ndim, TY_DOUBLE) + call malloc (iltm, ndim * ndim, TY_DOUBLE) + call malloc (nr, ndim, TY_DOUBLE) + call malloc (jr, ndim, TY_DOUBLE) + call malloc (ncd, ndim * ndim, TY_DOUBLE) + + # Allocate working memory for the grid points. + call malloc (ix, npts, TY_DOUBLE) + call malloc (iy, npts, TY_DOUBLE) + call malloc (ilng, npts, TY_DOUBLE) + call malloc (ilat, npts, TY_DOUBLE) + call malloc (ox, npts, TY_DOUBLE) + call malloc (oy, npts, TY_DOUBLE) + call malloc (olng, npts, TY_DOUBLE) + call malloc (olat, npts, TY_DOUBLE) + + # Compute the original logical to world transformation. + call mw_gltermd (mwin, Memd[ltm], Memd[ltv], ndim) + call mw_gwtermd (mwin, Memd[r], Memd[w], Memd[cd], ndim) + call mwvmuld (Memd[ltm], Memd[r], Memd[nr], ndim) + call aaddd (Memd[nr], Memd[ltv], Memd[nr], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call mwmmuld (Memd[cd], Memd[iltm], Memd[ncd], ndim) + + # Compute the logical and world coordinates of the input image + # grid points. + call rg_rxyl (Memd[ix], Memd[iy], nxgrid, nygrid, 1.0d0, + double(sk_stati(cooin, S_NLNGAX)), 1.0d0, + double(sk_stati(cooin, S_NLATAX))) + ctin = rg_xytoxy (mwin, Memd[ix], Memd[iy], Memd[ilng], Memd[ilat], + npts, "logical", "world", sk_stati (cooin, S_XLAX), + sk_stati (cooin, S_YLAX)) + + # Transfrom the input image grid points to the new world coordinate + # system. + call rg_lltransform (cooin, cooout, Memd[ilng], Memd[ilat], + Memd[olng], Memd[olat], npts) + + # Get the reference point. + if (sk_stati(cooin, S_PLNGAX) < sk_stati(cooin, S_PLATAX)) { + tilng = Memd[w+sk_stati(cooin,S_PLNGAX)-1] + tilat = Memd[w+sk_stati(cooin,S_PLATAX)-1] + } else { + tilng = Memd[w+sk_stati(cooin,S_PLATAX)-1] + tilat = Memd[w+sk_stati(cooin,S_PLNGAX)-1] + } + + # Compute the value of longpole and latpole required to transform + # the coordinate system. + usecd = rg_longpole (mwin, cooin, cooout, tilng, tilat, olongpole, + olatpole, nlongpole, nlatpole) + if (uselp) + usecd = false + + # Output the current image wcs. + if (verbose && ! update) { + call printf ("\n") + call rg_wcsshow (mwin, "Current", Memd[ltv], Memd[ltm], Memd[w], + Memd[nr], Memd[ncd], ndim, olongpole, olatpole) + } + + # Compute the new world coordinates of the reference point and + # update the reference point vector. + call rg_lltransform (cooin, cooout, tilng, tilat, tolng, tolat, 1) + if (sk_stati(cooout, S_PLNGAX) < sk_stati(cooout, S_PLATAX)) { + Memd[w+sk_stati(cooout,S_PLNGAX)-1] = tolng + Memd[w+sk_stati(cooout,S_PLATAX)-1] = tolat + } else { + Memd[w+sk_stati(cooout,S_PLNGAX)-1] = tolat + Memd[w+sk_stati(cooout,S_PLATAX)-1] = tolng + } + + # Initialize the output transfrom. + mwout = mw_newcopy (mwin) + + # Set the terms. + call mw_swtermd (mwout, Memd[r], Memd[w], Memd[cd], ndim) + + if (usecd) { + + # Compute the new x and y values. + ctout = rg_xytoxy (mwout, Memd[olng], Memd[olat], Memd[ox], + Memd[oy], npts, "world", "logical", sk_stati (cooout, + S_XLAX), sk_stati (cooout, S_YLAX)) + + # Subtract off the origin and compute the coordinate system + # rotation angle and scale factor. + call asubkd (Memd[ix], Memd[nr+sk_stati(cooin, S_XLAX)-1], + Memd[ix], npts) + call asubkd (Memd[iy], Memd[nr+sk_stati(cooin, S_YLAX)-1], + Memd[iy], npts) + call asubkd (Memd[ox], Memd[nr+sk_stati(cooout, S_XLAX)-1], + Memd[ox], npts) + call asubkd (Memd[oy], Memd[nr+sk_stati(cooout, S_YLAX)-1], + Memd[oy], npts) + fitstat = rg_cdfit (Memd[ix], Memd[iy], Memd[ox], Memd[oy], + npts, xscale, yscale, xrot, yrot) + + } else { + + ctout = NULL + xscale = 1.0d0 + yscale = 1.0d0 + xrot = 0.0d0 + yrot = 0.0d0 + fitstat = OK + } + + if (fitstat == OK) { + + # Modify the cd matrix. + if (usecd) { + + axbits = 2 ** (sk_stati (cooout, S_XLAX) - 1) + + 2 ** (sk_stati (cooout, S_YLAX) - 1) + call rg_mwxyrot (mwout, xscale, yscale, xrot, yrot, + Memd[ncd], Memd[cd], ndim, axbits) + call mwmmuld (Memd[cd], Memd[ltm], Memd[ncd], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call asubd (Memd[nr], Memd[ltv], Memd[r], ndim) + call mwvmuld (Memd[iltm], Memd[r], Memd[jr], ndim) + call mw_swtermd (mwout, Memd[jr], Memd[w], Memd[ncd], ndim) + + # Modify longpole and latpole. + } else { + call sprintf (Memc[str], SZ_LINE, "%g") + call pargd (nlongpole) + #call eprintf ("longpole='%s'\n") + #call pargstr (Memc[str]) + call mw_swattrs (mwout, sk_stati(cooout, S_PLNGAX), + "longpole", Memc[str]) + call sprintf (Memc[str], SZ_LINE, "%g") + call pargd (nlatpole) + #call eprintf ("latpole='%s'\n") + #call pargstr (Memc[str]) + call mw_swattrs (mwout, sk_stati(cooout, S_PLATAX), + "latpole", Memc[str]) + call amovd (Memd[ncd], Memd[cd], ndim * ndim) + } + + # Compute and print the goodness of fit estimate. + if (verbose) { + if (ctout != NULL) + call mw_ctfree (ctout) + ctout = rg_xytoxy (mwout, Memd[olng], Memd[olat], + Memd[ox], Memd[oy], npts, "world", "logical", + sk_stati (cooout, S_XLAX), sk_stati (cooout, S_YLAX)) + if (usecd) { + call aaddkd (Memd[ix], Memd[nr+sk_stati(cooout, + S_XLAX)-1], Memd[ix], npts) + call aaddkd (Memd[iy], Memd[nr+sk_stati(cooout, + S_YLAX)-1], Memd[iy], npts) + } + xrms = rg_rmsdiff (Memd[ox], Memd[ix], npts) + yrms = rg_rmsdiff (Memd[oy], Memd[iy], npts) + } + + # Recompute and store the new wcs if update is enabled. + if (update) { + call sk_saveim (cooout, mwout, im) + call mw_saveim (mwout, im) + } else if (verbose) { + if (usecd) + call rg_wcsshow (mwin, "New", Memd[ltv], Memd[ltm], + Memd[w], Memd[nr], Memd[cd], ndim, olongpole, + olatpole) + else + call rg_wcsshow (mwin, "New", Memd[ltv], Memd[ltm], + Memd[w], Memd[nr], Memd[cd], ndim, nlongpole, + nlatpole) + } + + if (verbose) { + call printf ( + "Crval%d,%d: %h, %h -> %h, %h dd:mm:ss.s\n") + call pargi (sk_stati(cooout,S_PLNGAX)) + call pargi (sk_stati(cooout,S_PLATAX)) + call pargd (tilng) + call pargd (tilat) + call pargd (tolng) + call pargd (tolat) + call printf (" Scaling: Xmag: %0.6f Ymag: %0.6f ") + call pargd (xscale) + call pargd (yscale) + call printf ("Xrot: %0.3f Yrot: %0.3f degrees\n") + call pargd (xrot) + call pargd (yrot) + call printf ( + " Rms: X fit: %0.7g pixels Y fit: %0.7g pixels\n") + call pargd (xrms) + call pargd (yrms) + call printf ("\n") + } + + } else + call printf ("Error fitting the scaling factors angle\n") + + # Free the memory. + call mfree (r, TY_DOUBLE) + call mfree (w, TY_DOUBLE) + call mfree (cd, TY_DOUBLE) + call mfree (ncd, TY_DOUBLE) + call mfree (nr, TY_DOUBLE) + call mfree (jr, TY_DOUBLE) + call mfree (ltm, TY_DOUBLE) + call mfree (ltv, TY_DOUBLE) + call mfree (iltm, TY_DOUBLE) + + call mfree (ix, TY_DOUBLE) + call mfree (iy, TY_DOUBLE) + call mfree (ilng, TY_DOUBLE) + call mfree (ilat, TY_DOUBLE) + call mfree (ox, TY_DOUBLE) + call mfree (oy, TY_DOUBLE) + call mfree (olng, TY_DOUBLE) + call mfree (olat, TY_DOUBLE) + + # Clean up various data stuctures. + if (mwin != NULL) + call mw_close (mwin) + call sk_close (cooin) + if (mwout != NULL) + call mw_close (mwout) + call sk_ctypeim (cooout, im) + call sk_close (cooout) + call imunmap (im) + } + + call imtclose (imlist) + + call sfree (sp) +end + + +# RG_WCSSHOW -- Print a quick summary of the current wcs. + +procedure rg_wcsshow (mwin, label, ltv, ltm, w, r, cd, ndim, longpole, latpole) + +pointer mwin #I pointer to the current wcs +char label[ARB] #I name of the input label +double ltv[ARB] #I the lterm offsets +double ltm[ndim,ARB] #I the lterm rotation matrix +double w[ARB] #I the fits crval parameters +double r[ARB] #I the fits crpix parameters +double cd[ndim,ARB] #I the fits rotation matrix +int ndim #I the dimension of the wcs +double longpole #I the longpole value assumed +double latpole #I the latpole value assumed + +int i,j +pointer sp, str +errchk mw_gwattrs() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Print the image name and current wcs. + call printf ("%s wcs\n") + call pargstr (label) + + # Print the axis banner. + call printf (" Axis ") + do i = 1, ndim { + call printf ("%10d ") + call pargi (i) + } + call printf ("\n") + + # Print the crval parameters. + call printf (" Crval ") + do i = 1, ndim { + call printf ("%10.4f ") + call pargd (w[i]) + } + call printf ("\n") + + # Print the crpix parameters. + call printf (" Crpix ") + do i = 1, ndim { + call printf ("%10.2f ") + call pargd (r[i]) + } + call printf ("\n") + + # Print the cd matrix. + do i = 1, ndim { + call printf (" Cd %d ") + call pargi (i) + do j = 1, ndim { + call printf ("%10.4g ") + call pargd (cd[j,i]) + } + call printf ("\n") + } + + # Print longpole / latpole + call printf (" Poles ") + call printf ("%10.4f %10.4f\n") + call pargd (longpole) + call pargd (latpole) + + call printf ("\n") + + call sfree (sp) +end + + +# RG_LONGPOLE -- Compute the value of longpole and latpole required to +# transform the input celestial coordinate system to the output celestial +# coordinate system, and determine whether this mode of transformation +# is required for the specified projection. + +bool procedure rg_longpole (mwin, incoo, outcoo, ilng, ilat, ilngpole, + ilatpole, olngpole, olatpole) + +pointer mwin #I the input image coordinate system descriptor +pointer incoo #I the input celestial coordinate system descriptor +pointer outcoo #I the output celestial coordinate system descriptor +double ilng #I the input celestial ra / longitude coordinate (deg) +double ilat #I the input celestial dec / latitude coordinate (deg) +double ilngpole #O the input system longpole value (deg) +double ilatpole #O the input system latpole value (deg) +double olngpole #O the output system longpole value (deg) +double olatpole #O the output system latpole value (deg) + +double tilngpole, tilatpole, thetaa, theta0, tilng, tilat, tilngp, tilatp +double ntilng, ntilat +pointer sp, str +int i, projection, ptype +bool usecd +int sk_stati(), rg_wrdstr(), strdic(), ctod() +errchk mw_gwattrs() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the projection type + projection = sk_stati (incoo, S_WTYPE) + if (projection <= 0) + projection = WTYPE_LIN + if (rg_wrdstr (projection, Memc[str], SZ_FNAME, + PTYPE_LIST) != projection) + call strcpy ("z", Memc[str], SZ_FNAME) + ptype = strdic (Memc[str], Memc[str], SZ_FNAME, PTYPE_NAMES) + if (ptype <= 0) + ptype = PTYPE_ZEN + + # Get the input value of longpole if any. + iferr { + call mw_gwattrs (mwin, 1, "longpole", Memc[str], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mwin, 2, "longpole", Memc[str], SZ_LINE) + } then { + tilngpole = INDEFD + } else { + i = 1 + if (ctod (Memc[str], i, tilngpole) <= 0) + tilngpole = INDEFD + } + } else { + i = 1 + if (ctod (Memc[str], i, tilngpole) <= 0) + tilngpole = INDEFD + } + ilngpole = tilngpole + + # Get the input value of latpole if any. + iferr { + call mw_gwattrs (mwin, 1, "latpole", Memc[str], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mwin, 2, "latpole", Memc[str], SZ_LINE) + } then { + tilatpole = INDEFD + } else { + i = 1 + if (ctod (Memc[str], i, tilatpole) <= 0) + tilatpole = INDEFD + } + } else { + i = 1 + if (ctod (Memc[str], i, tilatpole) <= 0) + tilatpole = INDEFD + } + ilatpole = tilatpole + + # Get the input value of thetaa if any. + iferr { + call mw_gwattrs (mwin, 1, "projp1", Memc[str], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mwin, 2, "projp1", Memc[str], SZ_LINE) + } then { + thetaa = INDEFD + } else { + i = 1 + if (ctod (Memc[str], i, thetaa) <= 0) + thetaa = INDEFD + } + } else { + i = 1 + if (ctod (Memc[str], i, thetaa) <= 0) + thetaa = INDEFD + } + + # Determine theta0. + switch (ptype) { + case PTYPE_ZEN: + theta0 = DHALFPI + usecd = true + case PTYPE_CYL: + theta0 = 0.0d0 + usecd = false + case PTYPE_CON: + if (IS_INDEFD(thetaa)) + call error (0, "Invalid conic projection parameter thetaa") + else + theta0 = DDEGTORAD(thetaa) + usecd = false + case PTYPE_EXP: + theta0 = DHALFPI + usecd = false + #usecd = true + } + + # Convert the input coordinates to radians. + tilng = DDEGTORAD (ilng) + tilat = DDEGTORAD (ilat) + + # Determine the appropriate value of longpole and convert to radians. + if (IS_INDEFD(tilngpole)) { + if (tilat < theta0) + tilngpole = DPI + else + tilngpole = 0.0d0 + } else + tilngpole = DDEGTORAD (tilngpole) + if (! IS_INDEFD(tilatpole)) + tilatpole = DDEGTORAD (tilatpole) + + # Compute the celestial coordinates of the pole in the old system + # and latpole. + switch (ptype) { + case PTYPE_ZEN, PTYPE_EXP: + tilngp = tilng + tilatp = DHALFPI - tilat + default: + call rg_cnpole (tilng, tilat, theta0, tilngpole, tilatpole, + tilngp, tilatp) + } + #call eprintf ("%0.5f %0.5f %0.5f %0.5f %0.5f %0.5f %0.5f\n") + #call pargd (DRADTODEG(tilng)) + #call pargd (DRADTODEG(tilat)) + #call pargd (DRADTODEG(theta0)) + #call pargd (DRADTODEG(tilngpole)) + #if (IS_INDEFD(tilatpole)) + #call pargd (INDEFD) + #else + #call pargd (DRADTODEG(tilatpole)) + #call pargd (DRADTODEG(tilngp)) + #call pargd (DRADTODEG(tilatp)) + + # Compute the celestial coordinates in the old celestial coordinate + # system of the pole of the new coordinate system. Note that + # because the original coordinate system is a sky coordinate + # system that the input and output coordinate units are degrees. + + call rg_lltransform (outcoo, incoo, 0.0d0, 90.0d0, ntilng, ntilat, 1) + #call eprintf ("%0.5f %0.5f\n") + #call pargd (ntilng) + #call pargd (ntilat) + + # Compute the new longpole and latpole. + call rg_celtonat (DDEGTORAD(ntilng), DDEGTORAD(ntilat), tilngp, tilatp, + tilngpole, olngpole, olatpole) + olngpole = DRADTODEG(olngpole) + olatpole = DRADTODEG(olatpole) + + call sfree (sp) + + return (usecd) +end + + +# RG_CNPOLE -- Give the celestial coordinates of the reference point, the +# native latitude of the reference point, and the native longitude +# of the celestial pole, compute the celestial coordinates of the native +# pole. + +procedure rg_cnpole (ra, dec, theta0, longp, latp, rap, decp) + +double ra #I the reference point ra / longitude in radians +double dec #I the reference point dec / latitude in radians +double theta0 #I the native latitude of the reference point in radians +double longp #I the native longpole of the celestial pole in radians +double latp #I the native latitude of the celestial pole in radians +double rap #O the ra of native pole in radians (Euler angle 1) +double decp #O the codec of native pole in radians (Euler angle 2) + +double clat0, slat0, cphip, sphip, cthe0, sthe0, x, y, z, u, v, latp1, latp2 +double tol, maxlat, tlatp +data tol /1.0d-10/ + +begin + clat0 = cos (dec) + slat0 = sin (dec) + cphip = cos (longp) + sphip = sin (longp) + cthe0 = cos (theta0) + sthe0 = sin (theta0) + x = cthe0 * cphip + y = sthe0 + z = sqrt (x * x + y * y) + + if (z == 0.0d0) { + + if (slat0 != 0.0d0) + call error (0, "Invalid projection parameters") + + if (IS_INDEFD(latp)) + call error (0, "Undefined latpole value") + + tlatp = latp + + } else { + + if (abs (slat0 / z) > 1.0d0) + call error (0, "Invalid projection parameters") + + u = atan2 (y, x) + v = acos (slat0 / z) + + latp1 = u + v + if (latp1 > DPI) + latp1 = latp1 - DTWOPI + else if (latp1 < -DPI) + latp1 = latp1 + DTWOPI + + latp2 = u - v + if (latp2 > DPI) + latp2 = latp2 - DTWOPI + else if (latp2 < -DPI) + latp2 = latp2 + DTWOPI + + if (IS_INDEFD(latp)) + maxlat = 999.0d0 + else + maxlat = latp + if (abs(maxlat - latp1) < abs(maxlat - latp2)) { + if (abs(latp1) < (DHALFPI + tol)) + tlatp = latp1 + else + tlatp = latp2 + } else { + if (abs(latp2) < (DHALFPI + tol)) + tlatp = latp2 + else + tlatp = latp1 + } + } + decp = DHALFPI - tlatp + + # Determine the celestial longitude of the native pole. + z = cos (tlatp) * clat0 + if (abs(z) < tol) { + if (abs(clat0) < tol) { + rap = ra + decp = DHALFPI - theta0 + } else if (tlatp > 0.0d0) { + rap = ra + longp - DPI + decp = 0.0d0 + } else if (tlatp < 0.0d0) { + rap = ra - longp + decp = DPI + } + } else { + x = (sthe0 - sin (tlatp) * slat0) / z + y = sphip * cthe0 / clat0 + if (x == 0.0d0 && y == 0.0d0) + call error (0, "Invalid projection parameters") + rap = ra - atan2 (y,x) + } + if (ra >= 0.0d0) { + if (rap < 0.0d0) + rap = rap + DTWOPI + } else { + if (rap > 0.0d0) + rap = rap - DTWOPI + } +end + + +# RG_CELTONAT - Convert celestial to native coordinates given the input Euler +# angles coordinates of the native pole and the longitude of the celestial pole. + +procedure rg_celtonat (ra, dec, rap, decp, longpole, phi, theta) + +double ra #I input ra/longitude +double dec #I input ra/longitude +double rap #I input euler angle 1 (rap) +double decp #I input euler angle 2 (90-latp) +double longpole #I input euler angle 3 (longpole) +double phi #O output phi +double theta #O output theta + +double x, y, z, dphi + +begin + x = sin (dec) * sin (decp) - cos (dec) * cos (decp) * cos (ra - rap) + if (abs(x) < 1.0d-5) + x = -cos (dec + decp) + cos (dec) * cos(decp) * (1.0d0 - + cos (ra - rap)) + y = -cos (dec) * sin (ra - rap) + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y,x) + else + dphi = ra - rap - DPI + phi = longpole + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + if (mod (ra - rap, DPI) == 0.0d0) { + theta = dec + cos (ra - rap) * decp + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sin (dec) * cos (decp) + cos (dec) * sin(decp) * cos (ra - rap) + if (abs(z) > 0.99d0) + theta = sign (acos(sqrt (x*x + y*y)), z) + else + theta = asin (z) + } +end + + +# RG_CDFIT -- Compute the cd matrix and shift vector required to realign +# the transformed coordinate systems. + +int procedure rg_cdfit (xref, yref, xin, yin, npts, xscale, yscale, xrot, yrot) + +double xref[ARB] #I the input x reference vector +double yref[ARB] #I the input y reference vector +double xin[ARB] #I the input x vector +double yin[ARB] #I the input y vector +int npts #I the number of points +double xscale, yscale #O the x and y scale factors +double xrot #O the rotation angle in degrees +double yrot #O the rotation angle in degrees + +int fitstat +double xshift, yshift +pointer sp, wts +int rg_ffit() + +begin + call smark (sp) + call salloc (wts, npts, TY_DOUBLE) + call amovkd (1.0d0, Memd[wts], npts) + + fitstat = rg_ffit (xref, yref, xin, yin, Memd[wts], npts, + xshift, yshift, xscale, yscale, xrot, yrot) + if (fitstat == ERR) { + xrot = INDEFD + yrot = INDEFD + xscale = INDEFD + yscale = INDEFD + } + + call sfree (sp) + return (fitstat) +end + + +# RG_FFIT -- Compute the x and y shift, th x and y scale, and the x and y +# rotation angle required to match one set of coordinates to another. + +int procedure rg_ffit (xref, yref, xin, yin, wts, npts, xshift, yshift, + xmag, ymag, xrot, yrot) + +double xref[ARB] #I reference image x values +double yref[ARB] #I reference image y values +double xin[ARB] #I input image x values +double yin[ARB] #I input image y values +double wts[ARB] #I array of weights +int npts #I number of points +double xshift, yshift #O the x and y shifts +double xmag, ymag #O the x and y scale factors +double xrot, yrot #O the rotation angles + +double xmin, xmax, ymin, ymax +int xier, yier, ier +pointer sx1, sy1 + +begin + # Compute the data limits. + call alimd (xref, npts, xmin, xmax) + call alimd (yref, npts, ymin, ymax) + + # Compute the x fit. + call dgsinit (sx1, GS_POLYNOMIAL, 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsfit (sx1, xref, yref, xin, wts, npts, WTS_USER, xier) + + # Compute the y fit. + call dgsinit (sy1, GS_POLYNOMIAL, 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsfit (sy1, xref, yref, yin, wts, npts, WTS_USER, yier) + + # Compute the geometric parameters. + if (xier != OK || yier != OK) { + xshift = INDEFD + yshift = INDEFD + xmag = INDEFD + ymag = INDEFD + xrot = INDEFD + yrot = INDEFD + ier = ERR + } else { + call geo_lcoeffd (sx1, sy1, xshift, yshift, xmag, ymag, xrot, yrot) + ier = OK + } + + call dgsfree (sx1) + call dgsfree (sy1) + return (ier) +end + + +define CDIN icd[$1,$2] +define CDOUT ocd[$1,$2] + +# RG_MWXYROT -- Scale and rotate the CD matrix by specifying the x and y scale +# factors in dimensionless units and the rotation angle in degrees. Since only +# x and y scale factors and one rotation angle can be specified, this routine +# is useful only useful for a 2D transformation + +procedure rg_mwxyrot(mw, xmag, ymag, xtheta, ytheta, icd, ocd, ndim, axbits) + +pointer mw #I pointer to MWCS descriptor +double xmag, ymag #I the x and y scaling factors +double xtheta #I the x rotation angle, degrees +double ytheta #I the y rotation angle, degrees +double icd[ndim,ARB] #U the input CD matrix +double ocd[ndim,ARB] #U the output CD matrix +int ndim #I dimensions of the CD matrix +int axbits #I bitflags defining axes to be rotated + +double d_thetax, d_thetay, costx, sintx, costy, sinty +int axis[IM_MAXDIM], naxes, ax1, ax2, axmap +int mw_stati() +errchk syserr + +begin + # Convert axis bitflags to axis list and get the two axes. + call mw_gaxlist (mw, axbits, axis, naxes) + axmap = mw_stati (mw, MW_USEAXMAP) + call mw_seti (mw, MW_USEAXMAP, NO) + ax1 = axis[1] + ax2 = axis[2] + + # Rotate the CD matrix. + d_thetax = DEGTORAD(xtheta) + d_thetay = DEGTORAD(ytheta) + costx = cos (d_thetax) + sintx = sin (d_thetax) + costy = cos (d_thetay) + sinty = sin (d_thetay) + call amovd (icd, ocd, ndim * ndim) + + CDOUT(ax1,ax1) = xmag * costx * CDIN(ax1,ax1) - + xmag * sintx * CDIN(ax2,ax1) + CDOUT(ax2,ax1) = ymag * sinty * CDIN(ax1,ax1) + + ymag * costy * CDIN(ax2,ax1) + CDOUT(ax1,ax2) = xmag * costx * CDIN(ax1,ax2) - + xmag * sintx * CDIN(ax2,ax2) + CDOUT(ax2,ax2) = ymag * sinty * CDIN(ax1,ax2) + + ymag * costy * CDIN(ax2,ax2) + + call mw_seti (mw, MW_USEAXMAP, axmap) +end + + +# RG_RMSDIFF -- Compute the standard deviation of the difference between 2 +# vectors + +double procedure rg_rmsdiff (a, b, npts) + +double a[ARB] #I the first input vector +double b[ARB] #I the second input vector +int npts #I the number of points + +int i +double sum, rms + +begin + sum = 0.0d0 + do i = 1, npts + sum = sum + (a[i] - b[i]) ** 2 + + if (npts <= 1) + rms = INDEFD + else + rms = sqrt (sum / (npts - 1)) + + return (rms) +end + diff --git a/pkg/images/imcoords/src/t_skyctran.x b/pkg/images/imcoords/src/t_skyctran.x new file mode 100644 index 00000000..05a7e824 --- /dev/null +++ b/pkg/images/imcoords/src/t_skyctran.x @@ -0,0 +1,221 @@ +include <fset.h> +include <pkg/skywcs.h> + +procedure t_skyctran() + +bool verbose, transform, first_file +int inlist, outlist, linlist, loutlist, lngcolumn, latcolumn, infd, outfd +int ilngunits, ilatunits, olngunits, olatunits, min_sigdigits, optype +int instat, outstat, nilng, nilat, plngcolumn, platcolumn, pxcolumn +int rvcolumn +double ilngmin, ilngmax, ilatmin, ilatmax +int fstati() +pointer sp, inname, outname, insystem, outsystem, olngformat, olatformat +pointer ilngformat, ilatformat, str, mwin, mwout, cooin, cooout + +bool clgetb(), streq() +double clgetd() +int clpopnu(), clplen(), clgfil(), open(), sk_decwcs() +int clgeti(), clgwrd(), sk_stati() +errchk clgwrd() + +begin + call smark (sp) + call salloc (inname, SZ_FNAME, TY_CHAR) + call salloc (outname, SZ_FNAME, TY_CHAR) + call salloc (insystem, SZ_FNAME, TY_CHAR) + call salloc (outsystem, SZ_FNAME, TY_CHAR) + call salloc (ilngformat, SZ_FNAME, TY_CHAR) + call salloc (ilatformat, SZ_FNAME, TY_CHAR) + call salloc (olngformat, SZ_FNAME, TY_CHAR) + call salloc (olatformat, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Open the input and output file lists. + inlist = clpopnu ("input") + linlist = clplen (inlist) + outlist = clpopnu ("output") + loutlist = clplen (outlist) + call clgstr ("insystem", Memc[insystem], SZ_FNAME) + call clgstr ("outsystem", Memc[outsystem], SZ_FNAME) + transform = clgetb ("transform") + + # Fetch the file formatting parameters. + lngcolumn = clgeti ("lngcolumn") + latcolumn = clgeti ("latcolumn") + plngcolumn = clgeti ("plngcolumn") + platcolumn = clgeti ("platcolumn") + pxcolumn = clgeti ("pxcolumn") + rvcolumn = clgeti ("rvcolumn") + ilngmin = clgetd ("ilngmin") + ilngmax = clgetd ("ilngmax") + ilatmin = clgetd ("ilatmin") + ilatmax = clgetd ("ilatmax") + nilng = clgeti ("nilng") + nilat = clgeti ("nilat") + iferr (ilngunits = clgwrd ("ilngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + ilngunits = 0 + iferr (ilatunits = clgwrd ("ilatunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + ilatunits = 0 + call clgstr ("ilngformat", Memc[ilngformat], SZ_FNAME) + call clgstr ("ilatformat", Memc[ilatformat], SZ_FNAME) + + iferr (olngunits = clgwrd ("olngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + olngunits = 0 + iferr (olatunits = clgwrd ("olatunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + olatunits = 0 + call clgstr ("olngformat", Memc[olngformat], SZ_FNAME) + call clgstr ("olatformat", Memc[olatformat], SZ_FNAME) + #min_sigdigits = clgeti ("min_sigdigits") + min_sigdigits = 7 + verbose = clgetb ("verbose") + + # Test the length of the input coordinate list. + if (linlist < 1) + call error (0, "The input coordinate file list is empty") + if (loutlist < 1) + call error (0, "The output coordinate file list is empty") + if (loutlist > 1 && loutlist != linlist) + call error (0, + "The number of input and output files are not the same") + + # Determine the input coordinate system. + instat = sk_decwcs (Memc[insystem], mwin, cooin, NULL) + + # Determine the output coordinate system. + outstat = sk_decwcs (Memc[outsystem], mwout, cooout, NULL) + + # Loop over the input files. + first_file = true + while (clgfil (inlist, Memc[inname], SZ_FNAME) != EOF) { + + # Open the input coordinate file. The string "imcursor" is + # reserved for the image display cursor. + if (streq (Memc[inname], "imcursor") && mwin != NULL) { + infd = NULL + optype = sk_stati (cooin, S_PIXTYPE) + call sk_seti (cooin, S_PIXTYPE, PIXTYPE_TV) + } else if (streq (Memc[inname], "grid")) { + optype = sk_stati (cooin, S_PIXTYPE) + infd = NULL + } else + infd = open (Memc[inname], READ_ONLY, TEXT_FILE) + + # Open the output coordinate file. + if (clgfil (outlist, Memc[outname], SZ_FNAME) != EOF) { + outfd = open (Memc[outname], NEW_FILE, TEXT_FILE) + if (streq (Memc[outname], "STDOUT") || outfd == STDOUT) + call fseti (outfd, F_FLUSHNL, YES) + call fprintf (outfd, "\n") + if (instat == ERR) + call fprintf (outfd, + "# Error decoding the input coordinate system\n") + call sk_iiwrite (outfd, "Insystem", Memc[insystem], mwin, + cooin) + if (outstat == ERR) + call fprintf (outfd, + "# Error decoding the output coordinate system\n") + call sk_iiwrite (outfd, "Outsystem", Memc[outsystem], mwout, + cooout) + } + + # Print information about the input and output coordinate system + # and the input and output files to the standard output. + if (verbose && outfd != STDOUT) { + if (first_file) { + call printf ("\n") + if (instat == ERR) + call printf ( + "Error decoding the input coordinate system\n") + call sk_iiprint ("Insystem", Memc[insystem], mwin, cooin) + if (outstat == ERR) + call printf ( + "Error decoding the output coordinate system\n") + call sk_iiprint ("Outsystem", Memc[outsystem], mwout, + cooout) + call printf ("\n") + } + call printf ("Input file: %s Output file: %s\n") + call pargstr (Memc[inname]) + call pargstr (Memc[outname]) + call flush (STDOUT) + } + + + # Print the input and output file name banner. + call fprintf (outfd, "\n# Input file: %s Output file: %s\n") + call pargstr (Memc[inname]) + call pargstr (Memc[outname]) + call fprintf (outfd, "\n") + + # Transform the coordinate list. + if (infd == NULL) { + if (streq ("imcursor", Memc[inname])) + call sk_curtran (outfd, mwin, mwout, cooin, cooout, + olngunits, olatunits, Memc[olngformat], + Memc[olatformat], transform) + else if (instat == ERR || outstat == ERR) + call sk_grcopy (outfd, cooin, cooout, ilngmin, ilngmax, + nilng, ilatmin, ilatmax, nilat, ilngunits, + ilatunits, olngunits, olatunits, Memc[ilngformat], + Memc[ilatformat], Memc[olngformat], + Memc[olatformat], transform) + else + call sk_grtran (outfd, mwin, mwout, cooin, cooout, + ilngmin, ilngmax, nilng, ilatmin, ilatmax, nilat, + ilngunits, ilatunits, olngunits, olatunits, + Memc[ilngformat], Memc[ilatformat], Memc[olngformat], + Memc[olatformat], transform) + } else { + if (infd == STDIN && fstati(STDIN, F_REDIR) == NO) + call sk_ttytran (infd, outfd, mwin, mwout, cooin, cooout, + ilngunits, ilatunits, olngunits, olatunits, + Memc[olngformat], Memc[olatformat]) + else if (instat == ERR || outstat == ERR) + call sk_copytran (infd, outfd, lngcolumn, latcolumn, + transform) + else + call sk_listran (infd, outfd, mwin, mwout, cooin, cooout, + lngcolumn, latcolumn, plngcolumn, platcolumn, + pxcolumn, rvcolumn, ilngunits, ilatunits, olngunits, + olatunits, Memc[olngformat], Memc[olatformat], + min_sigdigits, transform) + } + + # Close the output coordinate file. + if (linlist == loutlist) + call close (outfd) + + # Close the input coordinate file. + if (infd != NULL) + call close (infd) + else + call sk_seti (cooin, S_PIXTYPE, optype) + + first_file = false + } + + # Close the image wcs if one was opened. + if (loutlist < linlist) + call close (outfd) + if (mwin != NULL) + call mw_close (mwin) + if (mwout != NULL) + call mw_close (mwout) + #call mfree (cooin, TY_STRUCT) + call sk_close (cooin) + #call mfree (cooout, TY_STRUCT) + call sk_close (cooout) + + # Close up the lists. + call clpcls (inlist) + call clpcls (outlist) + + call sfree (sp) +end + + diff --git a/pkg/images/imcoords/src/t_starfind.x b/pkg/images/imcoords/src/t_starfind.x new file mode 100644 index 00000000..6288ea15 --- /dev/null +++ b/pkg/images/imcoords/src/t_starfind.x @@ -0,0 +1,224 @@ +include <fset.h> + +# T_STARFIND -- Automatically detect objects in an image given the full- +# width half-maximum of the image point spread function and a detection +# threshold using a modified version of the daofind algorithm. + +procedure t_starfind () + +int imlist, olist, limlist, lolist, boundary, verbose +int stat, root, out, nxblock, nyblock +pointer sp, image, output, outfname, str, wcs, wxformat, wyformat +pointer im, sf +real constant + +bool clgetb() +int imtopenp(), clpopnu(), imtlen(), clplen(), clgwrd(), btoi(), open() +int clgeti(), imtgetim(), clgfil(), fnldir(), strncmp(), strlen() +pointer immap() +real clgetr() + +begin + # Flush STDOUT on a new line. + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate working space. + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (outfname, SZ_FNAME, TY_CHAR) + call salloc (wcs, SZ_FNAME, TY_CHAR) + call salloc (wxformat, SZ_FNAME, TY_CHAR) + call salloc (wyformat, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Open the image and output file lists. + imlist = imtopenp ("image") + limlist = imtlen (imlist) + olist = clpopnu ("output") + lolist = clplen (olist) + + # Test the input and output file list. + if (lolist > 1 && lolist != limlist) { + call imtclose (imlist) + call clpcls (olist) + call sfree (sp) + call error (0, "Imcompatible image and output list lengths") + } + + # Get the algorithm parameters. + call sf_gpars (sf) + + # Get the wcs paramaters. + call clgstr ("wcs", Memc[wcs], SZ_FNAME) + call clgstr ("wxformat", Memc[wxformat], SZ_FNAME) + call clgstr ("wyformat", Memc[wyformat], SZ_FNAME) + + # Get the image blocking boundary extensions parameters. + boundary = clgwrd ("boundary", Memc[str], SZ_LINE, + ",constant,nearest,reflect,wrap,") + constant = clgetr ("constant") + nxblock = clgeti ("nxblock") + nyblock = clgeti ("nyblock") + + # Verbose mode ? + verbose = btoi (clgetb ("verbose")) + + # Loop over the images. + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # Open the input image. + im = immap (Memc[image], READ_ONLY, 0) + + # Get the output file name and open the file. + if (lolist == 0) { + call strcpy ("", Memc[outfname], SZ_FNAME) + out = NULL + } else { + stat = clgfil (olist, Memc[output], SZ_FNAME) + root = fnldir (Memc[output], Memc[outfname], SZ_FNAME) + if (strncmp ("default", Memc[output+root], 7) == 0 || root == + strlen (Memc[output])) { + call sf_outname (Memc[image], Memc[outfname], "obj", + Memc[outfname], SZ_FNAME) + lolist = limlist + } else if (stat != EOF) { + call strcpy (Memc[output], Memc[outfname], SZ_FNAME) + } else { + call sf_outname (Memc[image], Memc[outfname], "obj", + Memc[outfname], SZ_FNAME) + lolist = limlist + } + } + out = open (Memc[outfname], NEW_FILE, TEXT_FILE) + + # Find the stars in an image. + call sf_find (im, out, sf, nxblock, nyblock, Memc[wcs], + Memc[wxformat], Memc[wyformat], boundary, constant, + verbose) + + # Close images and files. + call imunmap (im) + call close (out) + + } + + + # Close lists. + call sf_free (sf) + call imtclose (imlist) + call clpcls (olist) + call sfree (sp) +end + + +# SF_OUTNAME -- Construct the output file name. If output is null or a +# directory, a name is constructed from the root of the image name and +# the extension. The disk is searched to avoid name collisions. + +procedure sf_outname (image, output, ext, name, maxch) + +char image[ARB] #I image name +char output[ARB] #I output directory or name +char ext[ARB] #I extension +char name[ARB] #O output name +int maxch #I maximum size of name + +int ndir, nimdir, clindex, clsize +pointer sp, root, str +int fnldir(), strlen() + +begin + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + ndir = fnldir (output, name, maxch) + if (strlen (output) == ndir) { + call imparse (image, Memc[root], SZ_FNAME, Memc[str], SZ_FNAME, + Memc[str], SZ_FNAME, clindex, clsize) + nimdir = fnldir (Memc[root], Memc[str], SZ_FNAME) + if (clindex >= 0) { + call sprintf (name[ndir+1], maxch, "%s%d.%s.*") + call pargstr (Memc[root+nimdir]) + call pargi (clindex) + call pargstr (ext) + } else { + call sprintf (name[ndir+1], maxch, "%s.%s.*") + call pargstr (Memc[root+nimdir]) + call pargstr (ext) + } + call sf_oversion (name, name, maxch) + } else + call strcpy (output, name, maxch) + + call sfree (sp) +end + + +## SF_IMROOT -- Fetch the root image name minus the directory specification +## and the section notation. The length of the root name is returned. +# +#int procedure sf_imroot (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 + + +# SF_OVERSION -- Compute the next available version number of a given file +# name template and output the new file name. + +procedure sf_oversion (template, filename, maxch) + +char template[ARB] #I name template +char filename[ARB] #O output name +int maxch #I maximum number of characters + +char period +int newversion, version, len +pointer sp, list, name +int fntgfnb() strldx(), ctoi(), fntopnb() + +begin + # Allocate temporary space + call smark (sp) + call salloc (name, maxch, TY_CHAR) + period = '.' + list = fntopnb (template, NO) + + # Loop over the names in the list searchng for the highest version. + newversion = 0 + while (fntgfnb (list, Memc[name], maxch) != EOF) { + len = strldx (period, Memc[name]) + len = len + 1 + if (ctoi (Memc[name], len, version) <= 0) + next + newversion = max (newversion, version) + } + + # Make new output file name. + len = strldx (period, template) + call strcpy (template, filename, len) + call sprintf (filename[len+1], maxch, "%d") + call pargi (newversion + 1) + + call fntclsb (list) + call sfree (sp) +end diff --git a/pkg/images/imcoords/src/t_wcsctran.x b/pkg/images/imcoords/src/t_wcsctran.x new file mode 100644 index 00000000..7459ec48 --- /dev/null +++ b/pkg/images/imcoords/src/t_wcsctran.x @@ -0,0 +1,643 @@ +include <imio.h> +include <fset.h> +include <ctype.h> +include <imhdr.h> +include <ctotok.h> +include <mwset.h> + +# Define some limits on the input file + +define MAX_FIELDS 100 # maximum number of fields in the list +define TABSIZE 8 # spacing of the tab stops + +# Define the supported units + +define WT_UNITSTR "|hours|native|" +define WT_UHOURS 1 +define WT_UNATIVE 2 + +define WT_WCSSTR "|logical|tv|physical|world|" +define WT_LOGICAL 1 +define WT_TV 2 +define WT_PHYSICAL 3 +define WT_WORLD 4 + +# Define the supported wcs. +# T_WCSCTRAN -- Transform a list of image coordinates from one coordinate +# system to another using world coordinate system information stored in +# the header of a reference image. + +procedure t_wcsctran() + +bool verbose +int i, csp, imlist,inlist, outlist, limlist, linlist, loutlist +int icl, ocl, ndim, wcsndim, ncolumns, nunits, inwcs, outwcs, min_sigdigits +pointer sp, image, columns, units, iwcs, owcs, fmtstr, fmtptrs +pointer str, name, im, mw, ct, tmp + +bool clgetb() +int imtopenp(), imtlen(), imtgetim(), fntopnb(), fntlenb(), fntgfnb() +int open(), mw_stati(), wt_getlabels(), ctoi(), strdic(), clgeti(), nscan() +int errget() +pointer immap(), mw_openim(), mw_sctran() +errchk mw_openim(), mw_gwattrs(), mw_sctran() + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (columns, IM_MAXDIM, TY_INT) + call salloc (units, IM_MAXDIM, TY_INT) + call salloc (iwcs, SZ_FNAME, TY_CHAR) + call salloc (owcs, SZ_FNAME, TY_CHAR) + call salloc (fmtstr, SZ_FNAME, TY_CHAR) + call salloc (fmtptrs, IM_MAXDIM, TY_POINTER) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (name, SZ_FNAME, TY_CHAR) + + # Get the input and output image and file lists. + imlist = imtopenp ("image") + limlist = imtlen (imlist) + call clgstr ("input", Memc[str], SZ_FNAME) + inlist = fntopnb (Memc[str], NO) + linlist = fntlenb (inlist) + call clgstr ("output", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) + call strcpy ("STDOUT", Memc[str], SZ_FNAME) + outlist = fntopnb (Memc[str], NO) + loutlist = fntlenb (outlist) + + # Get the input coordinate file format. + call clgstr ("columns", Memc[str], SZ_FNAME) + ncolumns = 0 + csp = 1 + while (wt_getlabels (Memc[str], csp, Memc[name], SZ_FNAME) != EOF) { + i = 1 + if (ctoi(Memc[name], i, Memi[columns+ncolumns]) <= 0) + break + ncolumns = ncolumns + 1 + } + + # Get the input coordinate units. Fill in any missing information + # with native units + call clgstr ("units", Memc[str], SZ_FNAME) + nunits = 0 + csp = 1 + while (wt_getlabels (Memc[str], csp, Memc[name], SZ_FNAME) != EOF) { + i = strdic (Memc[name], Memc[name], SZ_FNAME, WT_UNITSTR) + if (i <= 0) + break + Memi[units+nunits] = i + nunits = nunits + 1 + } + do i = nunits + 1, IM_MAXDIM + Memi[units+i-1] = WT_UNATIVE + + # Get the input and output transform. + call clgstr ("inwcs", Memc[iwcs], SZ_FNAME) + inwcs = strdic (Memc[iwcs], Memc[iwcs], SZ_FNAME, WT_WCSSTR) + call clgstr ("outwcs", Memc[owcs], SZ_FNAME) + outwcs = strdic (Memc[owcs], Memc[owcs], SZ_FNAME, WT_WCSSTR) + + # Get the format strings and minimum number of significant digits. + call clgstr ("formats", Memc[fmtstr], SZ_FNAME) + min_sigdigits = clgeti ("min_sigdigits") + + # Get the remaining parameters. + verbose = clgetb ("verbose") + + # Check that the image and output list lengths match. The number + # of input coordinate lists must be 1 or equal to the number of + # input images. + if (limlist < 1 || (linlist > 1 && linlist != limlist)) { + call imtclose (imlist) + call fntclsb (inlist) + call fntclsb (outlist) + call error (0, + "Incompatable image and input coordinate list lengths.") + } + + # Check that the image and output list lengths match. The number + # of output coordinate lists must be 1 or equal to the number of + # input images. + if (loutlist > 1 && loutlist != limlist) { + call imtclose (imlist) + call fntclsb (inlist) + call fntclsb (outlist) + call error (0, + "Incompatable image and output coordinate list lengths.") + } + + # Loop over the input images. + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # Open the input image. + im = immap (Memc[image], READ_ONLY, 0) + ndim = IM_NDIM(im) + + # Open the input coordinate file. + if (linlist <= 0) + icl = NULL + else if (fntgfnb (inlist, Memc[str], SZ_FNAME) != EOF) + icl = open (Memc[str], READ_ONLY, TEXT_FILE) + else + call seek (icl, BOF) + + # Open the output coordinate file. + if (fntgfnb (outlist, Memc[str], SZ_FNAME) != EOF) { + ocl = open (Memc[str], NEW_FILE, TEXT_FILE) + if (ocl == STDOUT) + call fseti (ocl, F_FLUSHNL, YES) + } + + # Print optional banner string. + if (verbose) { + call fprintf (ocl, "\n# Image: %s Wcsin: %s Wcsout: %s\n") + call pargstr (Memc[image]) + call pargstr (Memc[iwcs]) + call pargstr (Memc[owcs]) + } + + # Set up the coordinate transform. + mw = NULL + iferr { + + tmp = mw_openim (im); mw = tmp + + call mw_seti (mw, MW_USEAXMAP, NO) + if (inwcs == WT_TV && outwcs == WT_TV) + ct = mw_sctran (mw, "logical", "logical", 0) + else if (inwcs == WT_TV) + ct = mw_sctran (mw, "logical", Memc[owcs], 0) + else if (outwcs == WT_TV) + ct = mw_sctran (mw, Memc[iwcs], "logical", 0) + else + ct = mw_sctran (mw, Memc[iwcs], Memc[owcs], 0) + wcsndim = mw_stati (mw, MW_NPHYSDIM) + + if (ndim == 0) + ndim = wcsndim + + call sscan (Memc[fmtstr]) + do i = 1, IM_MAXDIM { + call malloc (Memi[fmtptrs+i-1], SZ_FNAME, TY_CHAR) + call gargwrd (Memc[Memi[fmtptrs+i-1]], SZ_FNAME) + if (nscan() != i || Memc[Memi[fmtptrs+i-1]] == EOS) { + if (outwcs == WT_WORLD) { + iferr (call mw_gwattrs (mw, i, "format", + Memc[Memi[fmtptrs+i-1]], SZ_FNAME)) + Memc[Memi[fmtptrs+i-1]] = EOS + } else + Memc[Memi[fmtptrs+i-1]] = EOS + } + } + + } then { + if (verbose) { + i = errget (Memc[str], SZ_LINE) + call fprintf (ocl, "# \tWarning: %s\n") + call pargstr (Memc[str]) + } + if (mw != NULL) + call mw_close (mw) + mw = NULL + ct = NULL + } + + # Check that the transform is valid. + if (ct == NULL) { + + # Skip the image if the transform is undefined. + if (verbose) { + call fprintf (ocl, + "# \tSkipping: Unable to compile requested transform\n") + } + + # For input or output tv coordinates the image must be 2D + } else if (ndim != 2 && (inwcs == WT_TV || outwcs == WT_TV)) { + + # Skip the image if the transform is undefined. + if (verbose) { + call fprintf (ocl, + "# \tSkipping: Image must be 2D for wcs type tv\n") + } + + # Check that the number of input columns is enough for images. + } else if ((ncolumns < ndim) || (ncolumns < wcsndim && inwcs != + WT_LOGICAL && inwcs != WT_TV)) { + + if (verbose) { + call fprintf (ocl, + "# \tSkipping: Too few input coordinate columns\n") + } + + } else { + + # Check the dimension of the wcs versus the dimension of the + # image and issue a warning if dimensional reduction has taken + # place. + if (wcsndim > ndim) { + if (verbose) { + call fprintf (ocl, + "# \tWarning: Image has been dimensionally reduced\n") + } + } + if (verbose) { + call fprintf (ocl, "\n") + } + + # Transform the coordinate file. + call wt_transform (im, icl, ocl, Memi[columns], Memi[units], + ndim, inwcs, outwcs, mw, ct, Memi[fmtptrs], wcsndim, + min_sigdigits) + + } + + # Free the format pointers. + do i = 1, IM_MAXDIM + call mfree (Memi[fmtptrs+i-1], TY_CHAR) + + # Close the input image. + if (mw != NULL) + call mw_close (mw) + call imunmap (im) + + # Close the input coordinate file if it is not going to be used. + if (linlist == limlist) + call close (icl) + + # Close the output coordinate file if it is not going to be + # appended to. + if (loutlist == limlist) + call close (ocl) + } + + # Close the input coordinate file + if (linlist > 0 && linlist < limlist) + call close (icl) + if (loutlist < limlist) + call close (ocl) + + call imtclose (imlist) + call fntclsb (inlist) + call fntclsb (outlist) + + call sfree (sp) +end + + +# WT_TRANSFORM -- Transform the input coordinates from the input coordinate +# system to the output coordinate system. + +procedure wt_transform (im, icl, ocl, columns, units, ndim, inwcs, outwcs, mw, + ct, fmtptrs, wcsndim, min_sigdigits) + +pointer im #I the input image descriptor +int icl #I the input coordinate file descriptor +int ocl #I the output coordinate file descriptor +int columns[ARB] #I the input coordinate columns +int units[ARB] #I the input coordinate units +int ndim #I the number of input coordinates +int inwcs #I the input wcs type +int outwcs #I the output wcs type +pointer mw #I the wcs descriptor +pointer ct #I the pointer to the compiled transformation +pointer fmtptrs[ARB] #I the array of format pointers +int wcsndim #I the dimensions of the wcs +int min_sigdigits #I the minimum number of significant digits + +int nline, ip, nread, nwrite, max_fields, nfields, offset +pointer sp, inbuf, linebuf, field_pos, outbuf, voff, vstep, paxno, laxno, incoo +pointer lincoo, outcoo, nsig +int getline(), li_get_numd() + +begin + # Allocate working space. + 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) + + call salloc (voff, wcsndim, TY_DOUBLE) + call salloc (vstep, wcsndim, TY_DOUBLE) + call salloc (paxno, wcsndim, TY_INT) + call salloc (laxno, wcsndim, TY_INT) + call salloc (incoo, wcsndim, TY_DOUBLE) + call salloc (lincoo, wcsndim, TY_DOUBLE) + call salloc (outcoo, wcsndim, TY_DOUBLE) + call salloc (nsig, wcsndim, TY_INT) + + call mw_gaxmap (mw, Memi[paxno], Memi[laxno], wcsndim) + call wt_laxmap (outwcs, Memi[paxno], wcsndim, Memi[laxno], ndim) + call wt_vmap (im, Memd[voff], Memd[vstep], ndim) + + # Compute the number of coordinates to be read and written. + if (inwcs == WT_LOGICAL && ndim < wcsndim) + nread = ndim + else + nread = wcsndim + if (outwcs == WT_LOGICAL && ndim < wcsndim) + nwrite = ndim + else + nwrite = wcsndim + call amovkd (INDEFD, Memd[outcoo], wcsndim) + + max_fields = MAX_FIELDS + for (nline = 1; getline (icl, Memc[inbuf]) != EOF; nline = nline + 1) { + + # Skip over leading white space. + for (ip = inbuf; IS_WHITE(Memc[ip]); ip = ip + 1) + ; + + # Pass on comment and blank lines unchanged. + if (Memc[ip] == '#') { + # Pass comment lines on to the output unchanged. + call putline (ocl, Memc[inbuf]) + next + } else if (Memc[ip] == '\n' || Memc[ip] == EOS) { + # Blank lines too. + call putline (ocl, 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) + + # Decode the coordinates checking for valid input. + call aclri (Memi[nsig], wcsndim) + do ip = 1, nread { + + if (columns[ip] > nfields) { + call fstats (icl, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("\tNot enough fields in file %s line %d\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (ocl, Memc[linebuf]) + break + } + + offset = Memi[field_pos+columns[ip]-1] + if (li_get_numd (Memc[linebuf+offset-1], + Memd[incoo+ip-1], Memi[nsig+ip-1]) == 0) { + call fstats (icl, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("\tBad value in file %s line %d column %d\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call pargi (ip) + call putline (ocl, Memc[linebuf]) + break + } + + if (IS_INDEFD(Memd[incoo+ip-1])) { + call fstats (icl, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("\tBad value in file %s line %d column %d\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call pargi (ip) + call putline (ocl, Memc[linebuf]) + break + } + + } + + # Skip to next line if too few fields were read. + if (ip <= nread) + next + + # Adjust the input coordinate units if necessary. + switch (inwcs) { + case WT_TV: + call wt_tvlogd (Memd[incoo], Memd[incoo], nread, Memd[voff], + Memd[vstep]) + case WT_WORLD: + call wt_cunits (Memd[incoo], units, nread) + default: + ; + } + + # Compute the transform. + call wt_ctrand (ct, Memd[incoo], Memd[lincoo], Memi[paxno], + Memd[outcoo], wcsndim, nread) + + # Adjust the output coordinate units if necessary. + switch (outwcs) { + case WT_TV: + call wt_logtvd (Memd[outcoo], Memd[outcoo], wcsndim, + Memi[laxno], Memd[voff], Memd[vstep]) + default: + ; + } + + # Create the output file line. + call rg_apack_lined (Memc[linebuf], Memc[outbuf], SZ_LINE, + Memi[field_pos], nfields, columns, nread, Memd[outcoo], + Memi[laxno], fmtptrs, Memi[nsig], nwrite, min_sigdigits) + + # Write out the reformatted output line. + call putline (ocl, Memc[outbuf]) + + } + + call sfree (sp) +end + + +# WT_LAXMAP (paxno, wcsndim, laxno, ndim) + +procedure wt_laxmap (outwcs, paxno, wcsndim, laxno, ndim) + +int outwcs #I the output wcs +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 (outwcs == WT_LOGICAL && 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 + + +# WT_VMAP -- Fetch the image i/o section map. Tecnically this routine +# violates a system interface and uses the internal definitions in +# the imio.h file. However this routine is required to support tv coordinates +# which are coordinates with respect to the current section, and not identical +# to physcial coordinates. + +procedure wt_vmap (im, voff, vstep, ndim) + +pointer im #I the input image descriptor +double voff[ARB] #O the array of offsets +double vstep[ARB] #O the array of step sizes +int ndim #I the number of dimensions + +int i, dim + +begin + do i = 1, ndim { + dim = IM_VMAP(im,i) + voff[i] = IM_VOFF(im,dim) + vstep[i] = IM_VSTEP(im,dim) + } +end + + +# WT_UNITS -- Correct the units of the input coordinates if necessary. + +procedure wt_cunits (incoo, units, ncoo) + +double incoo[ARB] #I the array of input coordinates +int units[ARB] #I the array of units +int ncoo #I the number of coordinates + +int i + +begin + do i = 1, ncoo { + switch (units[i]) { + case WT_UHOURS: + incoo[i] = 15.0d0 * incoo[i] + default: + ; + } + } +end + + +# WT_TVLOGD -- Linearly transform a vector of coordinates using an +# array of voffsets and scale factors. + +procedure wt_tvlogd (incoo, outcoo, ndim, voff, vstep) + +double incoo[ARB] #I array of input coordinates +double outcoo[ARB] #O array of output coordinates +int ndim #I number of coordinates +double voff[ARB] #I array of zero points +double vstep[ARB] #I array of scale factors + +int i + +begin + do i = 1, ndim + outcoo[i] = (incoo[i] - voff[i]) / vstep[i] +end + + +# WT_CTRAND -- Transform the coordinates. + +procedure wt_ctrand (ct, incoo, lincoo, paxno, outcoo, wcsndim, nread) + +pointer ct #I pointer to the compiled transform +double incoo[ARB] #I array of input coordinates +double lincoo[ARB] #U scratch array of input coordinates +int paxno[ARB] #I the physical axis map +double outcoo[ARB] #O array of output coordinates +int wcsndim #I the dimension of the wcs +int nread #I the number of input coordinates. + +int i + +begin + if (nread < wcsndim) { + do i = 1, wcsndim { + if (paxno[i] == 0) + lincoo[i] = 1.0d0 + else + lincoo[i] = incoo[paxno[i]] + } + if (ct == NULL) + call amovd (lincoo, outcoo, wcsndim) + else + call mw_ctrand (ct, lincoo, outcoo, wcsndim) + + } else { + if (ct == NULL) + call amovd (incoo, outcoo, wcsndim) + else + call mw_ctrand (ct, incoo, outcoo, wcsndim) + } + +end + + +# WT_LOGTVD -- Linearly transform a vector of coordinates using an +# array of voffsets and scale factors. + +procedure wt_logtvd (incoo, outcoo, wcsndim, laxno, voff, vstep) + +double incoo[ARB] #I array of input coordinates +double outcoo[ARB] #O array of output coordinates +int wcsndim #I number of coordinates +int laxno[ARB] #I the logical axis map +double voff[ARB] #I array of zero points +double vstep[ARB] #I array of scale factors + +int i + +begin + do i = 1, wcsndim { + if (laxno[i] != 0) + outcoo[laxno[i]] = (incoo[laxno[i]] * vstep[laxno[i]]) + + voff[laxno[i]] + } +end + + +# WT_GETLABELS -- Get the next label from a list of labels. + +int procedure wt_getlabels (list, ip, label, maxch) + +char list[ARB] #I list of labels +int ip #U pointer in to the list of labels +char label[ARB] #O the output label +int maxch #I maximum length of a column name + +int op, token +int ctotok(), strlen() + +begin + # Decode the column labels. + op = 1 + while (list[ip] != EOS) { + + token = ctotok (list, ip, label[op], maxch) + if (label[op] == EOS) + next + if ((token == TOK_UNKNOWN) || (token == TOK_CHARCON)) + break + if ((token == TOK_PUNCTUATION) && (label[op] == ',')) { + if (op == 1) + next + else + break + } + + op = op + strlen (label[op]) + break + } + + label[op] = EOS + if ((list[ip] == EOS) && (op == 1)) + return (EOF) + else + return (op - 1) +end + diff --git a/pkg/images/imcoords/src/t_wcsedit.x b/pkg/images/imcoords/src/t_wcsedit.x new file mode 100644 index 00000000..51d44992 --- /dev/null +++ b/pkg/images/imcoords/src/t_wcsedit.x @@ -0,0 +1,792 @@ +include <fset.h> +include <imhdr.h> +include <mwset.h> + +define HELPFILE "imcoords$src/wcsedit.key" + +define WCSCMDS ",?,show,update,quit," +define WCS_HELP 1 +define WCS_SHOW 2 +define WCS_UPDATE 3 +define WCS_QUIT 4 + +define WCSPARS ",CRVAL,CRPIX,CD,LTV,LTM,WTYPE,AXTYPE,UNITS,LABEL,FORMAT," +define WCS_CRVAL 1 +define WCS_CRPIX 2 +define WCS_CD 3 +define WCS_LTV 4 +define WCS_LTM 5 +define WCS_WTYPE 6 +define WCS_AXTYPE 7 +define WCS_UNITS 8 +define WCS_LABEL 9 +define WCS_FORMAT 10 + +procedure t_wcsedit () + +bool interactive, verbose, update, install +int wcsdim, parno, naxes1, naxes2, ndim +pointer sp, imtemplate, image, parameter, ax1list, ax2list, axes1, axes2 +pointer value, wcs, system +pointer imlist, im, mwim, r, w, cd, ltm, ltv, iltm, nr, ncd +bool clgetb(), streq(), wcs_iedit() +int clgeti(), fstati(), wcs_decode_parno(), wcs_decode_axlist(), imtgetim() +int mw_stati() +pointer imtopen(), immap(), mw_openim(), mw_open() +errchk mw_newsystem() + +begin + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate working space. + call smark (sp) + call salloc (imtemplate, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (parameter, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (ax1list, SZ_FNAME, TY_CHAR) + call salloc (ax2list, SZ_FNAME, TY_CHAR) + call salloc (axes1, IM_MAXDIM, TY_INT) + call salloc (axes2, IM_MAXDIM, TY_INT) + call salloc (wcs, SZ_FNAME, TY_CHAR) + call salloc (system, SZ_FNAME, TY_CHAR) + + # Get the list of images, parameter to be edited, axes lists, + # and new parameter value. + call clgstr ("image", Memc[imtemplate], SZ_FNAME) + interactive = clgetb ("interactive") + + if (! interactive) { + + # Get and check the wcs parameter to be edited. + call clgstr ("parameter", Memc[parameter], SZ_FNAME) + parno = wcs_decode_parno (Memc[parameter], SZ_FNAME) + if (parno <= 0) { + call printf ("%s is not a legal WCS parameter\n") + call pargstr (Memc[parameter]) + call sfree (sp) + return + } + + # Get the new parameter value. + call clgstr ("value", Memc[value], SZ_FNAME) + + # Get the axes for which the parameter is to be edited. + call clgstr ("axes1", Memc[ax1list], SZ_FNAME) + if (parno == WCS_CD || parno == WCS_LTM) + call clgstr ("axes2", Memc[ax2list], SZ_FNAME) + else + Memc[ax2list] = EOS + + # Print any axis decoding error messages. + if (wcs_decode_axlist (parno, Memc[ax1list], Memc[ax2list], + IM_MAXDIM, Memi[axes1], naxes1, Memi[axes2], naxes2) == ERR) { + if (naxes1 <= 0) { + call printf ("Error decoding axes1 list\n") + } else if ((Memi[axes1] < 1) || (Memi[axes1+naxes1-1] > + IM_MAXDIM)) { + call printf ("The axes1 values must be >= 1 and <= %d\n") + call pargi (IM_MAXDIM) + } else if (naxes2 == 0) { + call printf ("Error decoding axes2 list\n") + } else if ((Memi[axes2] < 1) || (Memi[axes2+naxes2-1] > + IM_MAXDIM)) { + call printf ("The axes2 values must be >= 1 and <= %d\n") + call pargi (IM_MAXDIM) + } + call sfree (sp) + return + } + } + + # Get the remaining parameters. + call clgstr ("wcs", Memc[wcs], SZ_FNAME) + wcsdim = clgeti ("wcsdim") + verbose = clgetb ("verbose") + update = clgetb ("update") + + # Loop over the list of images + imlist = imtopen (Memc[imtemplate]) + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # Remove any image section. + call imgimage (Memc[image], Memc[image], SZ_FNAME) + + # Open the image and the wcs. + iferr (im = immap (Memc[image], READ_WRITE, 0)) { + im = immap (Memc[image], NEW_IMAGE, 0) + IM_NDIM(im) = 0 + ndim = wcsdim + mwim = mw_open (NULL, ndim) + call mw_newsystem (mwim, Memc[wcs], ndim) + } else { + mwim = mw_openim (im) + iferr (call mw_ssystem (mwim, Memc[wcs])) { + call mw_close (mwim) + ndim = IM_NDIM(im) + mwim = mw_open (NULL, ndim) + call mw_newsystem (mwim, Memc[wcs], ndim) + } else + ndim = mw_stati (mwim, MW_NPHYSDIM) + } + call mw_gsystem (mwim, Memc[system], SZ_FNAME) + + # Allocate working memory. + call malloc (r, ndim * ndim, TY_DOUBLE) + call malloc (w, ndim * ndim, TY_DOUBLE) + call malloc (cd, ndim * ndim, TY_DOUBLE) + call malloc (ltm, ndim * ndim, TY_DOUBLE) + call malloc (ltv, ndim, TY_DOUBLE) + call malloc (iltm, ndim * ndim, TY_DOUBLE) + call malloc (nr, ndim * ndim, TY_DOUBLE) + call malloc (ncd, ndim * ndim, TY_DOUBLE) + + # Compute the original world to logical transformation. + call mw_gwtermd (mwim, Memd[r], Memd[w], Memd[cd], ndim) + call mw_gltermd (mwim, Memd[ltm], Memd[ltv], ndim) + call mwvmuld (Memd[ltm], Memd[r], Memd[nr], ndim) + call aaddd (Memd[nr], Memd[ltv], Memd[nr], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call mwmmuld (Memd[cd], Memd[iltm], Memd[ncd], ndim) + + # Edit the wcs. + if (interactive) { + + install = wcs_iedit (mwim, Memc[image], Memc[system], + Memd[ltv], Memd[ltm], Memd[w], Memd[nr], Memd[ncd], + ndim, verbose) + + } else if (streq (Memc[wcs], "physical") || streq (Memc[wcs], + "world") || streq (Memc[wcs], Memc[system])) { + + install = false + if (Memi[axes1+naxes1-1] > ndim) { + call printf ("For image %s axes1 values must be <= %d\n") + call pargstr (Memc[image]) + call pargi (ndim) + } else if (Memi[axes2+max(1,naxes2)-1] > ndim) { + call printf ( + "For image %s axes1,2 values must be <= %d\n") + call pargstr (Memc[image]) + call pargi (ndim) + } else { + + call wcs_edit (mwim, parno, Memi[axes1], naxes1, + Memi[axes2], naxes2, Memc[value], Memd[ltv], + Memd[ltm], Memd[w], Memd[nr], Memd[ncd], ndim) + + if (verbose) + call wcs_show (mwim, Memc[image], Memc[system], + Memd[ltv], Memd[ltm], Memd[w], Memd[nr], + Memd[ncd], ndim) + + if (update) + install = true + } + + } else { + call printf ("Cannot find wcs %s for image %s\n") + call pargstr (Memc[wcs]) + call pargstr (Memc[image]) + } + + + # Recompute and store the new wcs if update is enabled. + if (install) { + call mw_sltermd (mwim, Memd[ltm], Memd[ltv], ndim) + call mwmmuld (Memd[ncd], Memd[ltm], Memd[cd], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call asubd (Memd[nr], Memd[ltv], Memd[r], ndim) + call mwvmuld (Memd[iltm], Memd[r], Memd[nr], ndim) + call mw_swtermd (mwim, Memd[nr], Memd[w], Memd[cd], ndim) + call mw_saveim (mwim, im) + } + + # Free the memory. + call mfree (r, TY_DOUBLE) + call mfree (w, TY_DOUBLE) + call mfree (cd, TY_DOUBLE) + call mfree (ncd, TY_DOUBLE) + call mfree (nr, TY_DOUBLE) + call mfree (ltm, TY_DOUBLE) + call mfree (ltv, TY_DOUBLE) + call mfree (iltm, TY_DOUBLE) + + call mw_close (mwim) + call imunmap (im) + } + + call imtclose (imlist) + call sfree (sp) +end + + +# WCS_IEDIT -- Interactively edit the wcs. + +bool procedure wcs_iedit (mwim, image, system, ltv, ltm, w, r, cd, ndim, + verbose) + +pointer mwim # pointer to the current wcs +char image[ARB] # input image name +char system[ARB] # wcs system name +double ltv[ARB] # the lterm offsets +double ltm[ndim,ARB] # the lterm rotation matrix +double w[ARB] # the fits crval parameters +double r[ARB] # the fits crpix parameters +double cd[ndim,ARB] # the fits rotation matrix +int ndim # the dimension of the wcs +bool verbose # verbose mode + +bool update +int cmd, parno, naxes1, naxes2 +pointer sp, parameter, value, ax1list, ax2list, axes1, axes2 +int clscan(), strdic(), nscan(), wcs_decode_parno(), wcs_decode_axlist() + +begin + # Allocate working memory. + call smark (sp) + call salloc (parameter, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (ax1list, SZ_FNAME, TY_CHAR) + call salloc (ax2list, SZ_FNAME, TY_CHAR) + call salloc (axes1, ndim, TY_INT) + call salloc (axes2, ndim, TY_INT) + + # Print the starting wcs. + if (verbose) + call wcs_show (mwim, image, system, ltv, ltm, w, r, cd, ndim) + + # Loop over the command stream. + update = false + while (clscan ("commands") != EOF) { + + # Get the command/parameter. + call gargwrd (Memc[parameter], SZ_FNAME) + if (nscan() < 1) + next + cmd = strdic (Memc[parameter], Memc[parameter], SZ_FNAME, WCSCMDS) + + switch (cmd) { + case WCS_HELP: + call pagefile (HELPFILE, "") + case WCS_SHOW: + call wcs_show (mwim, image, system, ltv, ltm, w, r, cd, ndim) + case WCS_UPDATE: + update = true + break + case WCS_QUIT: + update = false + break + default: + call gargwrd (Memc[value], SZ_FNAME) + call gargwrd (Memc[ax1list], SZ_FNAME) + call gargwrd (Memc[ax2list], SZ_FNAME) + parno = wcs_decode_parno (Memc[parameter], SZ_FNAME) + if (parno <= 0) { + call printf ("%s is not a legal WCS parameter\n") + call pargstr (Memc[parameter]) + } else if (nscan() < 2) { + call wcs_pshow (mwim, parno, image, system, ltv, ltm, w, + r, cd, ndim) + } else if (wcs_decode_axlist (parno, Memc[ax1list], + Memc[ax2list], IM_MAXDIM, Memi[axes1], naxes1, Memi[axes2], + naxes2) == OK) { + call wcs_edit (mwim, parno, Memi[axes1], naxes1, + Memi[axes2], naxes2, Memc[value], ltv, ltm, w, r, cd, + ndim) + if (verbose) + call wcs_pshow (mwim, parno, image, system, ltv, ltm, + w, r, cd, ndim) + } else if (naxes1 <= 0) { + call printf ("Error decoding axes1 list\n") + } else if ((Memi[axes1] < 1) || (Memi[axes1+naxes1-1] > ndim)) { + call printf ("The axes1 values must be >= 1 and <= %d\n") + call pargi (ndim) + } else if (naxes2 <= 0) { + call printf ("Error decoding axes2 list\n") + } else if ((Memi[axes2] < 1) || (Memi[axes2+naxes2-1] > ndim)) { + call printf ("The axes1 values must be >= 1 and <= %d\n") + call pargi (ndim) + } + } + } + + call sfree (sp) + + return (update) +end + + +# WCS_EDIT -- Edit the wcs. + +procedure wcs_edit (mwim, parameter, axis1, naxis1, axis2, naxis2, value, ltv, + ltm, w, r, cd, ndim) + +pointer mwim # pointer to the current wcs +int parameter # parameter to be changed +int axis1[ARB] # list of axes1 for which to change value +int naxis1 # number of axis for to change value +int axis2[ARB] # list of cross-term axes +int naxis2 # number of cross-term axes +char value[ARB] # new wcs parameter value +double ltv[ARB] # the lterm offsets +double ltm[ndim,ARB] # the lterm rotation matrix +double w[ARB] # the fits crval parameters +double r[ARB] # the fits crpix parameters +double cd[ndim,ARB] # the fits rotation matrix +int ndim # the dimension of the wcs + +double dval +int i, j, ip +int ctod() + +begin + ip = 1 + switch (parameter) { + case WCS_CRVAL: + if (ctod (value, ip, dval) > 0) { + do i = 1, naxis1 + w[axis1[i]] = dval + } + case WCS_CRPIX: + if (ctod (value, ip, dval) > 0) { + do i = 1, naxis1 + r[axis1[i]] = dval + } + case WCS_CD: + if (ctod (value, ip, dval) > 0) { + if (naxis2 == 0) { + do i = 1, naxis1 + cd[axis1[i],axis1[i]] = dval + } else { + do i = 1, naxis1 + do j = 1, naxis2 + cd[axis2[j],axis1[i]] = dval + } + } + case WCS_LTV: + if (ctod (value, ip, dval) > 0) { + do i = 1, naxis1 + ltv[axis1[i]] = dval + } + case WCS_LTM: + if (ctod (value, ip, dval) > 0) { + if (naxis2 == 0) { + do i = 1, naxis1 + ltm[axis1[i],axis1[i]] = dval + } else { + do i = 1, naxis1 + do j = 1, naxis2 + ltm[axis1[i],axis2[j]] = dval + } + } + case WCS_WTYPE: + do i = 1, naxis1 { + call mw_swtype (mwim, axis1[i], 1, value, "") + call mw_swattrs (mwim, axis1[i], "wtype", value) + } + case WCS_AXTYPE: + do i = 1, naxis1 + call mw_swattrs (mwim, axis1[i], "axtype", value) + case WCS_UNITS: + do i = 1, naxis1 + call mw_swattrs (mwim, axis1[i], "units", value) + case WCS_LABEL: + do i = 1, naxis1 + call mw_swattrs (mwim, axis1[i], "label", value) + case WCS_FORMAT: + do i = 1, naxis1 + call mw_swattrs (mwim, axis1[i], "format", value) + default: + ; + } +end + + +# WCS_SHOW -- Print a quick summary of the current wcs. + +procedure wcs_show (mwim, image, system, ltv, ltm, w, r, cd, ndim) + +pointer mwim # pointer to the current wcs +char image[ARB] # name of the imput image +char system[ARB] # name of the input wcs +double ltv[ARB] # the lterm offsets +double ltm[ndim,ARB] # the lterm rotation matrix +double w[ARB] # the fits crval parameters +double r[ARB] # the fits crpix parameters +double cd[ndim,ARB] # the fits rotation matrix +int ndim # the dimension of the wcs + +int i,j +pointer sp, str +errchk mw_gwattrs() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Print the image name and current wcs. + call printf ("\nIMAGE: %s CURRENT WCS: %s\n") + call pargstr (image) + call pargstr (system) + + # Print the axis banner. + call printf (" AXIS ") + do i = 1, ndim { + call printf ("%8d ") + call pargi (i) + } + call printf ("\n") + + # Print the crval parameters. + call printf (" CRVAL ") + do i = 1, ndim { + call printf ("%8g ") + call pargd (w[i]) + } + call printf ("\n") + + # Print the crpix parameters. + call printf (" CRPIX ") + do i = 1, ndim { + call printf ("%8g ") + call pargd (r[i]) + } + call printf ("\n") + + # Print the cd matrix. + do i = 1, ndim { + call printf (" CD %d ") + call pargi (i) + do j = 1, ndim { + call printf ("%8g ") + call pargd (cd[j,i]) + } + call printf ("\n") + } + + # Print the ltv parameters. + call printf (" LTV ") + do i = 1, ndim { + call printf ("%8g ") + call pargd (ltv[i]) + } + call printf ("\n") + + # Print the ltm matrix. + do i = 1, ndim { + call printf (" LTM %d ") + call pargi (i) + do j = 1, ndim { + call printf ("%8g ") + call pargd (ltm[i,j]) + } + call printf ("\n") + } + + # Print the transformation type. + call printf (" WTYPE ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "wtype", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the axis type. + call printf (" AXTYPE ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "axtype", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the units. + call printf (" UNITS ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "units", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the label. + call printf (" LABEL ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "label", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the format. + call printf (" FORMAT ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "format", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + call printf ("\n") + + call sfree (sp) +end + + +# WCS_PSHOW -- Print the current values of a specific parameter. + +procedure wcs_pshow (mwim, parno, image, system, ltv, ltm, w, r, cd, ndim) + +pointer mwim # pointer to the current wcs +int parno # print the parameter number +char image[ARB] # name of the imput image +char system[ARB] # name of the input wcs +double ltv[ARB] # the lterm offsets +double ltm[ndim,ARB] # the lterm rotation matrix +double w[ARB] # the fits crval parameters +double r[ARB] # the fits crpix parameters +double cd[ndim,ARB] # the fits rotation matrix +int ndim # the dimension of the wcs + +int i,j +pointer sp, str +errchk mw_gwattrs() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Print the image name and current wcs. + call printf ("\nIMAGE: %s CURRENT WCS: %s\n") + call pargstr (image) + call pargstr (system) + + # Print the axis banner. + call printf (" AXIS ") + do i = 1, ndim { + call printf ("%8d ") + call pargi (i) + } + call printf ("\n") + + switch (parno) { + # Print the crval parameters. + case WCS_CRVAL: + call printf (" CRVAL ") + do i = 1, ndim { + call printf ("%8g ") + call pargd (w[i]) + } + call printf ("\n") + + # Print the crpix parameters. + case WCS_CRPIX: + call printf (" CRPIX ") + do i = 1, ndim { + call printf ("%8g ") + call pargd (r[i]) + } + call printf ("\n") + + # Print the cd matrix. + case WCS_CD: + do i = 1, ndim { + call printf (" CD %d ") + call pargi (i) + do j = 1, ndim { + call printf ("%8g ") + call pargd (cd[j,i]) + } + call printf ("\n") + } + + # Print the ltv parameters. + case WCS_LTV: + call printf (" LTV ") + do i = 1, ndim { + call printf ("%8g ") + call pargd (ltv[i]) + } + call printf ("\n") + + # Print the ltm matrix. + case WCS_LTM: + do i = 1, ndim { + call printf (" LTM %d ") + call pargi (i) + do j = 1, ndim { + call printf ("%8g ") + call pargd (ltm[i,j]) + } + call printf ("\n") + } + + # Print the transformation type. + case WCS_WTYPE: + call printf (" WTYPE ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "wtype", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the axis type. + case WCS_AXTYPE: + call printf (" AXTYPE ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "axtype", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the units. + case WCS_UNITS: + call printf (" UNITS ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "units", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the label. + case WCS_LABEL: + call printf (" LABEL ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "label", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the format. + case WCS_FORMAT: + call printf (" FORMAT ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "format", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + default: + call printf ("Unknown WCS parameter\n") + } + call printf ("\n") + + call sfree (sp) +end + + +# WCS_DECODE_PARNO -- Decode the WCS parameter + +int procedure wcs_decode_parno (parameter, maxch) + +char parameter[ARB] # parameter name +int maxch # maximum length of parameter name + +int parno +int strdic() + +begin + # Get and check the wcs parameter to be edited. + call strupr (parameter) + parno = strdic (parameter, parameter, maxch, WCSPARS) + if (parno <= 0) + return (ERR) + else + return (parno) +end + + +# WCS_DECODE_AXES -- Decode the axes lists. + +int procedure wcs_decode_axlist (parno, ax1list, ax2list, max_naxes, axes1, + naxes1, axes2, naxes2) + +int parno # parameter to be edited +char ax1list[ARB] # principal axes list +char ax2list[ARB] # secondary axes list +int max_naxes # maximum number of axes to decode +int axes1[ARB] # list of principal axes to be edited +int naxes1 # number of principal axes to be edited +int axes2[ARB] # list of secondary axes to be edited +int naxes2 # number of secondary axes to be edited + +int wcs_getaxes() + +begin + naxes1 = wcs_getaxes (ax1list, axes1, max_naxes) + if (naxes1 <= 0 || naxes1 > max_naxes) + return (ERR) + else if ((axes1[1] < 1) || (axes1[naxes1] > max_naxes)) + return (ERR) + + # Get the second list of axes. + if ((parno == WCS_CD) || (parno == WCS_LTM)) { + naxes2 = wcs_getaxes (ax2list, axes2, max_naxes) + if (ax2list[1] == EOS) + return (OK) + else if (naxes2 == 0) + return (ERR) + else if ((axes2[1] < 0) || (axes2[naxes2] > max_naxes)) + return (ERR) + } else { + naxes2 = naxes1 + call amovi (axes1, axes2, naxes1) + } + + return (OK) +end + + +define MAX_NRANGES 10 + +# WCS_GETAXES -- Decode the input axis list. + +int procedure wcs_getaxes (axlist, axes, max_naxes) + +char axlist[ARB] # the axis list to be decoded +int axes[ARB] # the output decode axes +int max_naxes # the maximum number of output axes + +int naxes, axis, ranges[3,MAX_NRANGES+1] +int decode_ranges(), get_next_number() + +begin + # Clear the axes array. + call aclri (axes, max_naxes) + + # Check for a blank string. + if (axlist[1] == EOS) + return (0) + + # Check for an illegal axis list string. + if (decode_ranges (axlist, ranges, MAX_NRANGES, naxes) == ERR) + return (0) + + naxes = 0 + axis = 0 + while ((naxes < max_naxes) && (get_next_number (ranges, axis) != EOF)) { + naxes = naxes + 1 + axes[naxes] = axis + } + + return (naxes) +end diff --git a/pkg/images/imcoords/src/t_wcsreset.x b/pkg/images/imcoords/src/t_wcsreset.x new file mode 100644 index 00000000..d7c24f27 --- /dev/null +++ b/pkg/images/imcoords/src/t_wcsreset.x @@ -0,0 +1,142 @@ +include <error.h> +include <imhdr.h> +include <mwset.h> + +# T_WCSRESET -- Initialize the image wcs. The user can initialize the +# pre-defined "physical" or "world" coodinate systems, or a named +# user world coordinate system, for example the "multipsec" world +# coordinate system. If the image does not have a previously defined wcs +# then wcsreset will create the identify wcs. + +procedure t_wcsreset () + +bool verbose +int ndim +pointer sp, imnamelist, image, wcs, system +pointer r, w, cd, ncd, nr, ltv, iltm, ltm +pointer imlist, im, mwim, mw +bool clgetb(), streq() +int imtgetim(), mw_stati() +pointer imtopen(), immap(), mw_openim(), mw_open() +errchk mw_openim() + +begin + # Allocate working space. + call smark (sp) + call salloc (imnamelist, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (wcs, SZ_FNAME, TY_CHAR) + call salloc (system, SZ_FNAME, TY_CHAR) + + # Get the parameters. + call clgstr ("image", Memc[imnamelist], SZ_FNAME) + call clgstr ("wcs", Memc[wcs], SZ_FNAME) + verbose = clgetb ("verbose") + + # Loop through the list of images. + imlist = imtopen (Memc[imnamelist]) + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # Remove any image section. + call imgimage (Memc[image], Memc[image], SZ_FNAME) + + # Open the image. + im = immap (Memc[image], READ_WRITE, 0) + iferr { + if (verbose) { + call printf ("Initializing wcs %s for image %s\n") + call pargstr (Memc[wcs]) + call pargstr (Memc[image]) + } + mwim = mw_openim (im) + } then { + mwim = NULL + } else { + call mw_gsystem (mwim, Memc[system], SZ_FNAME) + } + + # Reset the lterm only if the wcs is "physical". + if (streq (Memc[wcs], "physical") && mwim != NULL) { + + # Allocate space for the transforms. + ndim = mw_stati (mwim, MW_NPHYSDIM) + call malloc (r, ndim * ndim, TY_DOUBLE) + call malloc (w, ndim * ndim, TY_DOUBLE) + call malloc (cd, ndim * ndim, TY_DOUBLE) + call malloc (ltm, ndim * ndim, TY_DOUBLE) + call malloc (ltv, ndim, TY_DOUBLE) + call malloc (iltm, ndim * ndim, TY_DOUBLE) + call malloc (nr, ndim * ndim, TY_DOUBLE) + call malloc (ncd, ndim * ndim, TY_DOUBLE) + + call mw_gwtermd (mwim, Memd[r], Memd[w], Memd[cd], ndim) + call mw_gltermd (mwim, Memd[ltm], Memd[ltv], ndim) + call mwvmuld (Memd[ltm], Memd[r], Memd[nr], ndim) + call aaddd (Memd[nr], Memd[ltv], Memd[nr], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call mwmmuld (Memd[cd], Memd[iltm], Memd[ncd], ndim) + call mw_swtermd (mwim, Memd[nr], Memd[w], Memd[ncd], ndim) + call wcs_terminit (Memd[ltm], Memd[ltv], ndim) + call mw_sltermd (mwim, Memd[ltm], Memd[ltv], ndim) + call mw_saveim (mwim, im) + + # Free the space. + call mfree (r, TY_DOUBLE) + call mfree (w, TY_DOUBLE) + call mfree (cd, TY_DOUBLE) + call mfree (ncd, TY_DOUBLE) + call mfree (nr, TY_DOUBLE) + call mfree (ltm, TY_DOUBLE) + call mfree (ltv, TY_DOUBLE) + call mfree (iltm, TY_DOUBLE) + + # Cannot replace physical system for unknown world system. + } else if (streq (Memc[wcs], "physical") && mwim == NULL) { + if (verbose) { + call printf ("\tCannot initialize wcs %s for image %s\n") + call pargstr (Memc[wcs]) + call pargstr (Memc[image]) + } + } else if (streq (Memc[wcs], "world") || streq (Memc[wcs], + Memc[system])) { + + ndim = IM_NDIM(im) + mw = mw_open (NULL, ndim) + call mw_saveim (mw, im) + call mw_close (mw) + + # The named wcs is not present. + } else { + call eprintf ("\tCannot find wcs %s\n") + call pargstr (Memc[wcs]) + } + + if (mwim != NULL) + call mw_close (mwim) + + call imunmap (im) + + } + + call imtclose (imlist) + + call sfree (sp) +end + + +# WCS_TERMINIT -- Initialize the shift term and rotation matrix. + +procedure wcs_terminit (ltm, ltv, ndim) + +double ltm[ndim,ndim] # the rotation matrix +double ltv[ndim] # the shift vector +int ndim # the number of dimensions + +int i + +begin + call aclrd (ltm, ndim * ndim) + do i = 1, ndim + ltm[i,i] = 1.0d0 + call aclrd (ltv, ndim) +end diff --git a/pkg/images/imcoords/src/ttycur.key b/pkg/images/imcoords/src/ttycur.key new file mode 100644 index 00000000..f91b2185 --- /dev/null +++ b/pkg/images/imcoords/src/ttycur.key @@ -0,0 +1,49 @@ + INTERACTIVE KEYSTROKE COMMANDS + +The following commands must be terminated by a carriage return. + +? Print help +: Execute colon command +data Measure object +q Exit task + + + VALID DATA STRING + +x/ra/long y/dec/lat [pmra pmdec [parallax radial velocity]] + +... x/ra/long y/dec/lat must be in pixels or the input units +... pmra and pmdec must be in " / year +... parallax must be in " +... radial velocity must be in km / sec + + COLON COMMANDS + +The following commands must be terminated by a carriage return. + +:show Show the input and output coordinate systems +:isystem [string] Show / set the input coordinate system +:osystem [string] Show / set the output coordinate system +:iunits [string string] Show / set the input coordinate units +:ounits [string string] Show / set the output coordinate units +:oformat [string string] Show / set the output coordinate format + + VALID INPUT AND OUTPUT COORDINATE SYSTEMS + +image [logical/tv/physical/world] +equinox [epoch] +noefk4 [equinox [epoch]] +fk4 [equinox [epoch]] +fk5 [equinox [epoch]] +icrs [equinox [epoch]] +apparent epoch +ecliptic epoch +galactic [epoch] +supergalactic [epoch] + + VALID INPUT AND OUTPUT CELESTIAL COORDINATE UNITS + AND THEIR DEFAULT FORMATS + +hours %12.3h +degrees %12.2h +radians %13.7g diff --git a/pkg/images/imcoords/src/wcsedit.key b/pkg/images/imcoords/src/wcsedit.key new file mode 100644 index 00000000..61d98ceb --- /dev/null +++ b/pkg/images/imcoords/src/wcsedit.key @@ -0,0 +1,24 @@ + WCSEDIT COMMANDS + + BASIC COMMANDS + + +? Print the WCSEDIT commands +show Print out the current WCS +update Quit WCSEDIT and update the image WCS +quit Quit WCSEDIT without updating the image wcs + + + PARAMETER DISPLAY AND EDITING COMMANDS + +crval [value axes1] Show/set the FITS crval parameter(s) +crpix [value axes1] Show/set the FITS crpix parameter(s) +cd [value axes1 [axes2]] Show/set the FITS cd parameter(s) +ltv [value axes1] Show/set the IRAF ltv parameter(s) +ltm [value axes1 [axes2]] Show/set the IRAF ltm parameter(s) +wtype [value axes1] Show/set the FITS/IRAF axes transform(s) +axtype [value axes1] Show/set the FITS/IRAF axis type(s) +units [value axes1] Show/set the IRAF axes units(s) +label [value axes1] Show/set the IRAF axes label(s) +format [value axes1] Show/set the IRAF axes coordinate format(s) + diff --git a/pkg/images/imcoords/src/x_starfind.x b/pkg/images/imcoords/src/x_starfind.x new file mode 100644 index 00000000..865a795d --- /dev/null +++ b/pkg/images/imcoords/src/x_starfind.x @@ -0,0 +1 @@ +task starfind = t_starfind |