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 /noao/astcat/src | |
download | iraf-osx-40e5a5811c6ffce9b0974e93cdd927cbcf60c157.tar.gz |
Repatch (from linux) of OSX IRAF
Diffstat (limited to 'noao/astcat/src')
79 files changed, 15061 insertions, 0 deletions
diff --git a/noao/astcat/src/acatpars.par b/noao/astcat/src/acatpars.par new file mode 100644 index 00000000..45735023 --- /dev/null +++ b/noao/astcat/src/acatpars.par @@ -0,0 +1,65 @@ +# The AICATPARS parameter file + +# The input catalog format parameter set. + +# Global parameters. The only global parameter at present is the +# input catalog celestial coordinate system parameter icatsystem. +# This is overridden by the contents of the icoosystem field. + +# Standard column / field definitions ... +# +# The column / field definitions are strings containing the following +# quantities in the case of type = text files. +# +# "column [units [format]]". +# +# The column is a required quantity. A column value of 0 means that the +# standard column is not present in the input catalog. If absent +# the units and format fields default to reasonable expected values. +# +# In the case of type = btext files the column / field definitions have +# the following format. +# +# "coloffset colsize [units [format]]" +# +# The coloffset and colsize are required quantities. An offset of 0 means +# that the standard column is not present in the input catalog. If absent +# The units and format fields default to reasonable expected values. + +ftype,s,h,"stext","|stext|btext|",,"The file format type" +csystem,s,h,"J2000",,,"The catalog coordinate system" + +id,s,h,"",,,"The id field" + +ra,s,h,"1 hours",,,"The ra / longitude field" +dec,s,h,"2 degrees",,,"The dec / latitude field" +era,s,h,"",,,"The ra / longitude error field" +edec,s,h,"",,,"The dec / latitude error field" + +pmra,s,h,"",,,"The ra / longitude proper motion field" +pmdec,s,h,"",,,"The dec / latitude proper motion field" +epmra,s,h,"",,,"The ra / longitude proper motion error field" +epmdec,s,h,"",,,"The dec / latitude proper motion error field" + +catsystem,s,h,"",,,"The catalog coordinate system field" +equinox,s,h,"",,,"The epoch of the equinox field" +epoch,s,h,"",,,"The epoch of the observation field" + +px,s,h,"",,,"The parallax field" +rv,s,h,"",,,"The radial velocity field" +epx,s,h,"",,,"The parallax error field" +erv,s,h,"",,,"The radial error velocity field" + +mag,s,h,"",,,"The magnitude field(s)" +color,s,h,"",,,"The color indices field(s)" +emag,s,h,"",,,"The magnitude error field(s)" +ecolor,s,h,"",,,"The color indices error field(s)" + +xp,s,h,"",,,"The predicted x coordinate field" +yp,s,h,"",,,"The predicted y coordinate field" +xc,s,h,"",,,"The measured x coordinate field" +yc,s,h,"",,,"The measured y coordinate field" +exc,s,h,"",,,"The measured x coordinate error field" +eyc,s,h,"",,,"The measured y coordinate error field" +imag,s,h,"",,,"The instrumental magnitude field(s)" +eimag,s,h,"",,,"The instrumental magnitude error field(s)" diff --git a/noao/astcat/src/aclist.par b/noao/astcat/src/aclist.par new file mode 100644 index 00000000..72e0ca61 --- /dev/null +++ b/noao/astcat/src/aclist.par @@ -0,0 +1,6 @@ +# The ACLIST parameter file. + +catalogs,s,a,"*",,,"The astrometric catalog(s)" +verbose,b,h,no,,,"Print verbose messages ?" +catdb,s,h,)_.catdb,,,"The astrometric catalog configuration file" +mode,s,h,"ql",,, diff --git a/noao/astcat/src/acqctest.par b/noao/astcat/src/acqctest.par new file mode 100644 index 00000000..1cd24e81 --- /dev/null +++ b/noao/astcat/src/acqctest.par @@ -0,0 +1,6 @@ +record,s,a,"usno2@noao",,,"Database record name" +ra,s,a,"12:12:12.00",,,"Ra in hours" +dec,s,a,"+12:12:12.0",,,"Dec in degrees" +width,r,a,10.0,,,Width in minutes +database,f,h,")_.catdb",,,"Catalog database file" +mode,s,h,"ql",,, diff --git a/noao/astcat/src/acqftest.par b/noao/astcat/src/acqftest.par new file mode 100644 index 00000000..e036a263 --- /dev/null +++ b/noao/astcat/src/acqftest.par @@ -0,0 +1,5 @@ +textfile,f,a,"",,,"Input astrometry text file" +record,s,a,"text",,,"Database record name" +database,s,h,")_.catdb",,,"The catalog database" +acatpars,pset,h,,,,"The catalog description parameter set" +mode,s,h,"ql",,, diff --git a/noao/astcat/src/acqitest.par b/noao/astcat/src/acqitest.par new file mode 100644 index 00000000..4acc90f2 --- /dev/null +++ b/noao/astcat/src/acqitest.par @@ -0,0 +1,7 @@ +record,s,a,"dss2@cadc",,,"Database record name" +image,s,a,"",,,"Output image name" +ra,s,a,"12:12:12.00",,,"Ra in hours" +dec,s,a,"+12:12:12.0",,,"Dec in degrees" +width,r,a,10.0,,,Width in minutes +database,f,a,")_.imdb",,,"Surveys database file" +mode,s,h,"ql",,, diff --git a/noao/astcat/src/adumpcat.par b/noao/astcat/src/adumpcat.par new file mode 100644 index 00000000..c508cc78 --- /dev/null +++ b/noao/astcat/src/adumpcat.par @@ -0,0 +1,7 @@ +catalog,s,a,"",,,"The astrometric catalog" +output,s,a,"",,,"The query results file" +ra,s,a,"00:00:00.0",,,"The field center ra / longitude" +dec,s,a,"+00:00:00",,,"The field center dec / latitude" +size,s,a,15.0,,,"The field size" +catdb,s,h,")_.catdb",,,"The catalog configuration file" +mode,s,h,"ql",,, diff --git a/noao/astcat/src/adumpim.par b/noao/astcat/src/adumpim.par new file mode 100644 index 00000000..9be409a1 --- /dev/null +++ b/noao/astcat/src/adumpim.par @@ -0,0 +1,7 @@ +imsurvey,s,a,dss2@cadc,,,"The input image survey" +output,s,a,"",,,"The output image" +ra,s,a,"00:00:00.0",,,"The field center ra / longitude" +dec,s,a,"+00:00:00",,,"The field center dec / latitude" +size,s,a,15.0,,,"The field size" +imdb,s,h,")_.imdb",,,"The image survey configuration file" +mode,s,h,"ql",,, diff --git a/noao/astcat/src/afiltcat.par b/noao/astcat/src/afiltcat.par new file mode 100644 index 00000000..025c8d41 --- /dev/null +++ b/noao/astcat/src/afiltcat.par @@ -0,0 +1,27 @@ +# The AFILTCAT parameter file. + +# The input and output catalog parameters. + +input,s,a,"",,,"The input catalogs(s)" +output,s,a,"",,,"The output catalogs(s)" +acatpars,pset,h,"",,,"The default catalog format parameters" + +# The astrometric catalog parameters. + +catalogs,s,h,filename@noao,,,"The input astrometric catalog" + +# The output catalog filtering parameters. + +standard,b,h,yes,,,Output a standard catalog ? +filter,b,h,yes,,,"Filter the output catalog ?" +afiltpars,pset,h,"",,,The catalog filtering parameters + +# The taskmode parameters + +update,b,h,no,,,"Update algorithm parameters at task termination ?" +verbose,b,h,yes,,,"Print task status messages ?" + +# The task configuration parameters. +catdb,s,h,)_.catdb,,,"The astrometric catalog configuration file" + +mode,s,h,"ql",,, diff --git a/noao/astcat/src/afiltpars.par b/noao/astcat/src/afiltpars.par new file mode 100644 index 00000000..fb89f814 --- /dev/null +++ b/noao/astcat/src/afiltpars.par @@ -0,0 +1,36 @@ +# The AFILTPARS parameter set. + +# Standard filtering options. Default is to select all fields in all records. + +# Sorting options. + +fsort,s,h,"",,,"The sort field or expression" +freverse,b,h,no,,,"Sort in descending order ?" + +# Record selection options. + +fexpr,s,h,"yes",,,"The record selection expression" + +# The output field parameters. + +fields,s,h,"f[*]",,,"The list of output fields and field expressions" +fnames,s,h,"",,,"The new field names list" +fntypes,s,h,"",,,"The new field datatype list" +fnunits,s,h,"",,,"The new field units list" +fnformats,s,h,"",,,"The new field format list" + +# Coordinate transformation options. + +fosystem,s,h,"",,,"The filtered output celestial coordinate system" +fira,s,h,"ra",,,"Field containing the ra / longitude" +fidec,s,h,"dec",,,"Field containing the dec / latitude" +foraunits,s,h,"",,,"The filtered output ra / longitude units" +fodecunits,s,h,"",,, "The filtered ouput dec / latitude units" +foraformat,s,h,"",,,"The filtered output ra / longitude format" +fodecformat,s,h,"",,,"The filtered output dec / latitude format" +fixp,s,h,"xp",,,"Field containing the predicted x coordinate" +fiyp,s,h,"yp",,,"Field containing the predicted y coordinate" +fixc,s,h,"xc",,,"Field containing the centered x coordinate" +fiyc,s,h,"yc",,,"Field containing the centered y coordinate" +foxformat,s,h,"%10.3f",,,"The filtered output x coordinate format" +foyformat,s,h,"%10.3f",,,"The filtered output y coordinate format" diff --git a/noao/astcat/src/agetcat.par b/noao/astcat/src/agetcat.par new file mode 100644 index 00000000..f118ee3d --- /dev/null +++ b/noao/astcat/src/agetcat.par @@ -0,0 +1,28 @@ +# The AGETCAT parameter file. + +# The field center parameters. + +regions,s,a,"pars",,,"The regions list (pars,file,images)" +output,s,a,"default",,,"The output astrometry file(s)" +aregpars,pset,h,"",,,"The default field center parameters" + +# The astrometric catalog parameters. + +catalogs,s,h,)_.catalogs,,,"The astrometric catalog(s)" + +# The output catalog filtering parameters. + +standard,b,h,yes,,,Output a standard astrometry file ? +filter,b,h,no,,,"Filter the output astrometry file ?" +afiltpars,pset,h,"",,,The astrometry file filtering parameters + +# The task mode parameters + +update,b,h,no,,,"Update algorithm parameters at task termination ?" +verbose,b,h,yes,,,"Print task messages ?" + +# The task configuration parameters. + +catdb,s,h,)_.catdb,,,"The astrometric catalog configuration file" + +mode,s,h,"ql",,, diff --git a/noao/astcat/src/agetcat/atcatinit.x b/noao/astcat/src/agetcat/atcatinit.x new file mode 100644 index 00000000..04e9dff6 --- /dev/null +++ b/noao/astcat/src/agetcat/atcatinit.x @@ -0,0 +1,167 @@ + +# AT_AGINIT -- Inititialize the AGETCAT task structure. + +procedure at_aginit (at) + +pointer at #O the pointer to the astrometry descriptor + +begin + # Initialize the astrometry structure. + call at_ainit (at) + + # Initialize the i/o structure. + call at_ioinit (at) + + # Initialize the region definition structure. + call at_rcinit (at) + + # Initialize the filtering / selection structure. + call at_fsinit (at) +end + + +# AT_AGFREE -- Free the AGETCAT task structure. + +procedure at_agfree (at) + +pointer at #U the pointer to the astrometry descriptor + +begin + # Free the filtering / selection structure. + call at_fsfree (at) + + # Free the field center structure. + call at_rcfree (at) + + # Free the i/o structure + call at_iofree (at) + + # Free the astrometry structure. + call at_afree (at) +end + + +# AT_AFINIT -- Inititialize the AFILTCAT task structure. + +procedure at_afinit (at) + +pointer at #O the pointer to the astrometry descriptor + +begin + # Initialize the astrometry structure. + call at_ainit (at) + + # Initialize the i/o structure. + call at_ioinit (at) + + # Initialize the filtering / selection structure. + call at_fsinit (at) +end + + +# AT_AFFREE -- Free the AFILTCAT task structure. + +procedure at_affree (at) + +pointer at #U the pointer to the astrometry descriptor + +begin + # Free the filtering / selection structure. + call at_fsfree (at) + + # Free the i/o structure + call at_iofree (at) + + # Free the astrometry structure. + call at_afree (at) +end + + +# AT_AIGINIT -- Inititialize the agetim task structure. + +procedure at_aiginit (at) + +pointer at #O the pointer to the astrometry descriptor + +begin + # Initialize the astrometry structure. + call at_ainit (at) + + # Initialize the i/o structure. + call at_ioinit (at) + + # Initialize the region definition structure. + call at_rcinit (at) + + # Initialize the default wcs structure. + #call at_wcinit (at) + + # Initialize the default image data structure. + #call at_iminit (at) +end + + +# AT_AIGFREE -- Free the agetim task structure. + +procedure at_aigfree (at) + +pointer at #U the pointer to the astrometry descriptor + +begin + # Free the default image data structure. + #call at_imfree (at) + + # Free the default wcs structure. + #call at_wcfree (at) + + # Free the field center structure. + call at_rcfree (at) + + # Free the i/o structure + call at_iofree (at) + + # Free the astrometry structure. + call at_afree (at) +end + + +# AT_AHINIT -- Inititialize the AHEDIT task structure. + +procedure at_ahinit (at) + +pointer at #O the pointer to the astrometry descriptor + +begin + # Initialize the astrometry structure. + call at_ainit (at) + + # Initialize the i/o structure. + call at_ioinit (at) + + # Initialize the default wcs structure. + call at_wcinit (at) + + # Initialize the default image data structure. + call at_iminit (at) +end + + +# AT_AHFREE -- Free the AHEDIT task structure. + +procedure at_ahfree (at) + +pointer at #U the pointer to the astrometry descriptor + +begin + # Free the default image data structure. + call at_imfree (at) + + # Free the default wcs structure. + call at_wcfree (at) + + # Free the i/o structure + call at_iofree (at) + + # Free the astrometry structure. + call at_afree (at) +end diff --git a/noao/astcat/src/agetcat/atfcat.x b/noao/astcat/src/agetcat/atfcat.x new file mode 100644 index 00000000..b2265688 --- /dev/null +++ b/noao/astcat/src/agetcat/atfcat.x @@ -0,0 +1,1986 @@ +include <ctotok.h> +include <ctype.h> +include <evvexpr.h> +include <imhdr.h> +include <pkg/cq.h> +include <pkg/skywcs.h> +include "../../lib/astrom.h" +include "../../lib/acatalog.h" + +############################################################################## + +# Create a small data structure to describe the field list. Decide whether +# this should be part of the main astrometry package structure later ... + +define FL_FLENGTH 12 + +define FL_NEXPR Memi[$1] # The number of input expressions +define FL_NFIELDS Memi[$1+1] # The number of output fields + +# The field list decription +define FL_FLIST Memi[$1+2] # The list of field expressions +define FL_FRANGES Memi[$1+3] # The list of field ranges + +# New quantities to be written in the header (could be a symbol table ...) +define FL_FNAMES Memi[$1+4] # The list of field names +define FL_FOFFSETS Memi[$1+5] # The list of field offsets +define FL_FSIZES Memi[$1+6] # The list of field sizes +define FL_FTYPES Memi[$1+7] # The list of field types +define FL_FUNITS Memi[$1+8] # The list of field units +define FL_FFMTS Memi[$1+9] # The list of field formats + +# Useful constants +define FL_MAX_NEXPR 20 +define FL_MAX_NFIELDS 100 +define FL_SZ_EXPR SZ_LINE + +############################################################################## + +# AT_WIFILRECS -- Filter and write the output catalog. + +procedure at_wifilrecs (fd, im, at, res, standard) + +int fd #I the output file descriptor +pointer im #I the associated input image descriptor +pointer at #I the astrometry package descriptor +pointer res #I results descriptor +bool standard #I write a standard catalog header + +double raval, decval, oraval, odecval, iraval, idecval, xpval, ypval +pointer sp, sexpr, sfield, record, raname, decname, sindex +pointer flist, o, catcoo, outcoo, imcoo, mwim, ct +int i, nlines, nrecs, rafield, decfield, xpfield, ypfield, xcfield, ycfield +pointer at_flinit(), evvexpr(), locpr(), mw_sctran() +int at_wfcathdr(), cq_rstati(), at_srtcat(), at_flnexpr(), cq_grecord() +int cq_setrecord(), at_wcathdr(), at_mkrecord(), cq_gvald() +bool streq() +extern at_getop() + +int nchars + +begin + call smark (sp) + call salloc (sexpr, FL_SZ_EXPR, TY_CHAR) + call salloc (sfield, FL_SZ_EXPR, TY_CHAR) + call salloc (record, SZ_LINE, TY_CHAR) + call salloc (raname, FL_SZ_EXPR, TY_CHAR) + call salloc (decname, FL_SZ_EXPR, TY_CHAR) + + # Initialize the catalog, output, and image coordinate systems. + # and set up the image world to logical coordinate transformation. + call at_cowcs (at, res, im, catcoo, outcoo, imcoo, mwim) + if (imcoo != NULL) + ct = mw_sctran (mwim, "world", "logical", 03B) + + # Determine whether it is necessary to reformat. + call at_stats (at, FIELDS, Memc[record], SZ_LINE) + if (streq (Memc[record], "f[*]") && outcoo == NULL) { + + # The field list is NULL. + flist = NULL + + # Write the filtered catalog header. + if (standard) + nlines = at_wcathdr (fd, res) + + # Coordinate fields are not modified. + rafield = 0 + decfield = 0 + xpfield = 0 + ypfield = 0 + xcfield = 0 + ycfield = 0 + + } else { + + # Decode the output field list. + flist = at_flinit (at, res) + + # Write the filtered catalog header. + if (standard) + nlines = at_wfcathdr (fd, at, res, flist) + + # Get the offsets for the ra, dec, xp, yp, xc, and yc output fields. + call at_coofields (at, res, flist, Memc[raname], Memc[decname], + rafield, decfield, xpfield, ypfield, xcfield, ycfield) + if (outcoo == NULL) { + rafield = 0 + decfield = 0 + } + if (imcoo == NULL) { + xpfield = 0 + ypfield = 0 + } + xcfield = 0 + ycfield = 0 + } + + # Compute the sort index. + nrecs = cq_rstati (res, CQRNRECS) + call malloc (sindex, nrecs, TY_INT) + nrecs = at_srtcat (at, res, Memi[sindex], nrecs) + + # Get the selection expression and replace generic selection expression + # field names with their catalog equivalents. + call at_stats (at, FEXPR, Memc[sexpr], FL_SZ_EXPR) + i = 1 + if (at_flnexpr (res, Memc[sexpr], i, Memc[sfield], FL_SZ_EXPR) == EOF) + Memc[sfield] = EOS + + # Loop over the sorted records. Note that any reference to + # coordinates in the selection expression refers to the original + # not the transformed coordinates. + + o = NULL + do i = 1, nrecs { + + # Reject every record. + if (streq (Memc[sfield], "no")) + next + + # Evaluate the selection expression. + if (! streq (Memc[sfield], "yes")) { + if (cq_setrecord (res, Memi[sindex+i-1]) != Memi[sindex+i-1]) + next + if (o != NULL) + call evvfree (o) + o = evvexpr (Memc[sfield], locpr (at_getop), res, 0, res, 0) + if (O_TYPE(o) != TY_BOOL) + next + if (O_VALI(o) == NO) + next + } + + # Write the record. + if (flist == NULL) { + + # Copy the record. + nchars = cq_grecord (res, Memc[record], SZ_LINE, + Memi[sindex+i-1]) + + } else { + + # Get the ra and dec fields. + raval = INDEFD + decval = INDEFD + if (outcoo != NULL || imcoo != NULL) { + if (cq_gvald (res, Memi[sindex+i-1], Memc[raname], + raval) <= 0) + raval = INDEFD + if (cq_gvald (res, Memi[sindex+i-1], Memc[decname], + decval) <= 0) + decval = INDEFD + } + + # Transform the catalog coordinates to the output coordinate + # system. + oraval = INDEFD + odecval = INDEFD + if (outcoo != NULL && (rafield > 0 || decfield > 0)) { + if (! IS_INDEFD(raval) && ! IS_INDEFD(decval)) + call sk_ultran (catcoo, outcoo, raval, decval, oraval, + odecval, 1) + } + + # Transform the catalog coordinates to the image coordinate + # system and then to the image pixel coordinate system. + xpval = INDEFD + ypval = INDEFD + if (imcoo != NULL && (xpfield > 0 || ypfield > 0)) { + if (! IS_INDEFD(raval) && ! IS_INDEFD(decval)) { + call sk_ultran (catcoo, imcoo, raval, decval, iraval, + idecval, 1) + call mw_c2trand (ct, iraval, idecval, xpval, ypval) + if (xpval < 0.5d0 || xpval > (IM_LEN(im,1)+0.5d0) || + ypval < 0.5d0 || ypval > (IM_LEN(im,2)+0.5d0)) + next + } else { + xpval = INDEFD + ypval = INDEFD + } + } + + # Reformat the record. + nchars = at_mkrecord (flist, res, Memc[record], SZ_LINE, + Memi[sindex+i-1], rafield, decfield, oraval, odecval, + xpfield, ypfield, xpval, ypval) + + } + + # Write the new record. + if (nchars > 0) { + call fprintf (fd, "%s") + call pargstr (Memc[record]) + } + } + + # Free the selection expression descriptor. + if (o != NULL) + call evvfree (o) + + # Free the catalog, output, and image coordinate system descriptors. + if (catcoo != NULL) + call sk_close (catcoo) + if (outcoo != NULL) + call sk_close (outcoo) + if (imcoo != NULL) + call sk_close (imcoo) + if (mwim != NULL) + call mw_close (mwim) + + # Free output field list. + if (flist != NULL) + call at_flfree (flist) + + # Free thesort index descriptor. + call mfree (sindex, TY_INT) + + call sfree (sp) +end + + +# AT_WFILRECS -- Filter and write the output catalog. + +procedure at_wfilrecs (fd, at, res, standard) + +int fd #I the output file descriptor +pointer at #I the astrometry package descriptor +pointer res #I results descriptor +bool standard #I write a standard catalog header + +double raval, decval, oraval, odecval, iraval, idecval, xpval, ypval +pointer sp, sexpr, sfield, record, raname, decname, sindex +pointer flist, o, catcoo, outcoo, imcoo, mwim, ct +int i, nlines, nrecs, rafield, decfield, xpfield, ypfield, xcfield, ycfield +pointer at_flinit(), evvexpr(), locpr(), mw_sctran() +int at_wfcathdr(), cq_rstati(), at_srtcat(), at_flnexpr(), cq_grecord() +int cq_setrecord(), at_wcathdr(), at_mkrecord(), cq_gvald() +bool streq() +extern at_getop() + +int nchars + +begin + call smark (sp) + call salloc (sexpr, FL_SZ_EXPR, TY_CHAR) + call salloc (sfield, FL_SZ_EXPR, TY_CHAR) + call salloc (record, SZ_LINE, TY_CHAR) + call salloc (raname, FL_SZ_EXPR, TY_CHAR) + call salloc (decname, FL_SZ_EXPR, TY_CHAR) + + # Initialize the catalog, output, and field coordinate systems + # and set up the image world to logical coordinate transformation. + call at_cowcs (at, res, NULL, catcoo, outcoo, imcoo, mwim) + if (imcoo != NULL) + ct = mw_sctran (mwim, "world", "logical", 03B) + + # Determine whether it is necessary to reformat. + call at_stats (at, FIELDS, Memc[record], SZ_LINE) + if (streq (Memc[record], "f[*]") && outcoo == NULL) { + + # The field list is NULL. + flist = NULL + + # Write the filtered catalog header. + if (standard) + nlines = at_wcathdr (fd, res) + + # Coordinate fields are not altered. + rafield = 0 + decfield = 0 + xpfield = 0 + ypfield = 0 + xcfield = 0 + ycfield = 0 + + } else { + + # Decode the output field list. + flist = at_flinit (at, res) + + # Write the filtered catalog header. + if (standard) + nlines = at_wfcathdr (fd, at, res, flist) + + # Get the offsets for the ra, dec, xp, yp, xc, and yc output fields. + call at_coofields (at, res, flist, Memc[raname], Memc[decname], + rafield, decfield, xpfield, ypfield, xcfield, ycfield) + if (outcoo == NULL) { + rafield = 0 + decfield = 0 + } + if (imcoo == NULL) { + xpfield = 0 + ypfield = 0 + } + xcfield = 0 + ycfield = 0 + } + + # Compute the sort index. + nrecs = cq_rstati (res, CQRNRECS) + call malloc (sindex, nrecs, TY_INT) + nrecs = at_srtcat (at, res, Memi[sindex], nrecs) + + # Get the selection expression and replace generic selection expression + # field names with their catalog equivalents. + call at_stats (at, FEXPR, Memc[sexpr], FL_SZ_EXPR) + i = 1 + if (at_flnexpr (res, Memc[sexpr], i, Memc[sfield], FL_SZ_EXPR) == EOF) + Memc[sfield] = EOS + + # Loop over the sorted records. Note that any reference to + # coordinates in the selection expression refers to the original + # not the transformed coordinates. + + o = NULL + do i = 1, nrecs { + + # Reject every record. + if (streq (Memc[sfield], "no")) + next + + # Evaluate the selection expression. + if (! streq (Memc[sfield], "yes")) { + if (cq_setrecord (res, Memi[sindex+i-1]) != Memi[sindex+i-1]) + next + if (o != NULL) + call evvfree (o) + o = evvexpr (Memc[sfield], locpr (at_getop), res, 0, res, 0) + if (O_TYPE(o) != TY_BOOL) + next + if (O_VALI(o) == NO) + next + } + + # Write the record. + if (flist == NULL) { + + # Copy the record. + nchars = cq_grecord (res, Memc[record], SZ_LINE, + Memi[sindex+i-1]) + + } else { + + # Get the ra and dec fields. + raval = INDEFD + decval = INDEFD + if (outcoo != NULL || imcoo != NULL) { + if (cq_gvald (res, Memi[sindex+i-1], Memc[raname], + raval) <= 0) + raval = INDEFD + if (cq_gvald (res, Memi[sindex+i-1], Memc[decname], + decval) <= 0) + decval = INDEFD + } + + # Transform the catalog coordinates to the output coordinate + # system. + oraval = INDEFD + odecval = INDEFD + if (outcoo != NULL && (rafield > 0 || decfield > 0)) { + if (! IS_INDEFD(raval) && ! IS_INDEFD(decval)) + call sk_ultran (catcoo, outcoo, raval, decval, oraval, + odecval, 1) + } + + # Transform the catalog coordinates to the image coordinate + # system and then to the image pixel coordinate system. + xpval = INDEFD + ypval = INDEFD + if (imcoo != NULL && (xpfield > 0 || ypfield > 0)) { + if (! IS_INDEFD(raval) && ! IS_INDEFD(decval)) { + call sk_ultran (catcoo, imcoo, raval, decval, iraval, + idecval, 1) + call mw_c2trand (ct, iraval, idecval, xpval, ypval) + } else { + xpval = INDEFD + ypval = INDEFD + } + } + + # Reformat the record. + nchars = at_mkrecord (flist, res, Memc[record], SZ_LINE, + Memi[sindex+i-1], rafield, decfield, oraval, odecval, + xpfield, ypfield, xpval, ypval) + + } + + # Write the new record. + if (nchars > 0) { + call fprintf (fd, "%s") + call pargstr (Memc[record]) + } + } + + # Free the selection expression descriptor. + if (o != NULL) + call evvfree (o) + + # Free the catalog, output, and field coordinate system descriptors. + if (catcoo != NULL) + call sk_close (catcoo) + if (outcoo != NULL) + call sk_close (outcoo) + if (imcoo != NULL) + call sk_close (imcoo) + if (mwim != NULL) + call mw_close (mwim) + + # Free output field list. + if (flist != NULL) + call at_flfree (flist) + + # Free thesort index descriptor. + call mfree (sindex, TY_INT) + + call sfree (sp) +end + + +# AT_FCATHDR -- Write the filtered catalog header + +int procedure at_wfcathdr (fd, at, res, fl) + +int fd #I the output file descriptor +pointer at #I the astrometry pacakge descriptor +pointer res #I the results descriptor descriptor +pointer fl #I the output field list descriptor + +pointer sp, catname, qpnames, qpvalues, qpunits, fname, fvalue, funits +int i, nlines, nfields +int cq_rstati(), at_wrdstr(), cq_hinfon() +char cq_itype() +bool streq(), strne() + +begin + nlines = 0 + + # Allocate working space. + call smark (sp) + call salloc (catname, SZ_FNAME, TY_CHAR) + call salloc (qpnames, SZ_LINE, TY_CHAR) + call salloc (qpvalues, SZ_LINE, TY_CHAR) + call salloc (qpunits, SZ_LINE, TY_CHAR) + call salloc (fname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (fvalue, CQ_SZ_QPVALUE, TY_CHAR) + call salloc (funits, CQ_SZ_QPUNITS, TY_CHAR) + + # Write the header banner. + call fprintf (fd, "# BEGIN CATALOG HEADER\n") + nlines = nlines + 1 + + # Write the catalog database and id. + call cq_rstats (res, CQRCATDB, Memc[catname], SZ_FNAME) + call fprintf (fd, "# catdb %s\n") + call pargstr (Memc[catname]) + nlines = nlines + 1 + call cq_rstats (res, CQRCATNAME, Memc[catname], SZ_FNAME) + call fprintf (fd, "# catname %s\n") + call pargstr (Memc[catname]) + nlines = nlines + 1 + + # Write out the query parameter names, values, and units used + # to generate the catalog. + call cq_rstats (res, CQRQPNAMES, Memc[qpnames], SZ_LINE) + call cq_rstats (res, CQRQPVALUES, Memc[qpvalues], SZ_LINE) + call cq_rstats (res, CQRQPUNITS, Memc[qpunits], SZ_LINE) + nfields = cq_rstati (res, CQRNQPARS) + call fprintf (fd, "# nquery %d\n") + call pargi (nfields) + nlines = nlines + 1 + do i = 1, nfields { + if (at_wrdstr (i, Memc[fname], CQ_SZ_QPNAME, Memc[qpnames]) != i) + ; + if (at_wrdstr (i, Memc[fvalue], CQ_SZ_QPVALUE, Memc[qpvalues]) != i) + ; + if (at_wrdstr (i, Memc[funits], CQ_SZ_QPUNITS, Memc[qpunits]) != i) + ; + call fprintf (fd, "# %s %s %s\n") + call pargstr (Memc[fname]) + call pargstr (Memc[fvalue]) + call pargstr (Memc[funits]) + nlines = nlines + 1 + } + + # Write out the results format type. + if (at_wrdstr (cq_rstati(res, CQRTYPE), Memc[fvalue], CQ_SZ_QPVALUE, + CQ_RTYPESTR) <= 0) + call strcpy ("stext", Memc[fvalue], CQ_SZ_QPVALUE) + call fprintf (fd, "# type %s\n") + call pargstr (Memc[fvalue]) + nlines = nlines + 1 + + # Write out the header parameters, + nfields = cq_rstati (res, CQNHEADER) + call fprintf (fd, "# nheader %d\n") + call pargi (nfields) + nlines = nlines + 1 + do i = 1, nfields { + if (cq_hinfon (res, i, Memc[fname], CQ_SZ_QPNAME, Memc[fvalue], + CQ_SZ_QPVALUE) != i) + next + + # Check for a changed coordinate system here + if (streq ("csystem", Memc[fname])) { + call at_stats (at, FOSYSTEM, Memc[qpvalues], SZ_LINE) + if (Memc[qpvalues] != EOS && strne (Memc[qpvalues], + Memc[fvalue])) + call strcpy (Memc[qpvalues], Memc[fvalue], CQ_SZ_QPVALUE) + } + + call fprintf (fd, "# %s %s\n") + call pargstr (Memc[fname]) + call pargstr (Memc[fvalue]) + nlines = nlines + 1 + } + + # Write out the field desription. + nfields = FL_NFIELDS(fl) + call fprintf (fd, "# nfields %d\n") + call pargi (nfields) + do i = 0, nfields - 1 { + call fprintf (fd, "# %s %d %d %c %s %s\n") + call pargstr (Memc[FL_FNAMES(fl)+i*(CQ_SZ_QPNAME+1)]) + call pargi (Memi[FL_FOFFSETS(fl)+i]) + call pargi (Memi[FL_FSIZES(fl)+i]) + call pargc (cq_itype (Memi[FL_FTYPES(fl)+i])) + call pargstr (Memc[FL_FUNITS(fl)+i*(CQ_SZ_QPUNITS+1)]) + call pargstr (Memc[FL_FFMTS(fl)+i*(CQ_SZ_QPFMTS+1)]) + nlines = nlines + 1 + } + + # Write the header trailer. + call fprintf (fd, "# END CATALOG HEADER\n#\n") + nlines = nlines + 1 + + call sfree (sp) + + return (nlines) +end + + +# AT_SRTCAT -- Sort the catalog on the user specified field. + +int procedure at_srtcat (at, res, sindex, max_nrecs) + +pointer at #I the astrometry package descriptor +pointer res #I results descriptor +int sindex[ARB] #O the output sort index +int max_nrecs #I the maximum number of records + +double dval +pointer sp, sexpr, sfield, sname, sval, darray, carray, o +int i, ip, nrecs, stype, snum, nchars, sz_carray +pointer evvexpr(), locpr() +int ctotok(), cq_fnumber(), cq_ftype(), cq_fname(), ctoi(), cq_gvald() +int cq_gvalc(), gstrcpy(), cq_setrecord(), at_flnexpr(), at_stati() +bool streq() +extern at_getop() + +begin + call smark (sp) + call salloc (sexpr, FL_SZ_EXPR, TY_CHAR) + call salloc (sfield, FL_SZ_EXPR, TY_CHAR) + call salloc (sname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (sval, SZ_LINE, TY_CHAR) + + # Get the sort expression. + call at_stats (at, FSORT, Memc[sexpr], FL_SZ_EXPR) + i = 1 + if (at_flnexpr (res, Memc[sexpr], i, Memc[sfield], FL_SZ_EXPR) == EOF) + Memc[sfield] = EOS + + # Return initialized index array if the sort expression is undefined. + if (Memc[sfield] == EOS) { + do i = 1, max_nrecs + sindex[i] = i + call sfree (sp) + return (max_nrecs) + } + + # Determine the type of sort. If sfield and sname are identical + # sort expression is a field, otherwise it is an expression which + # must be evaluated. + ip = 1 + if (ctotok (Memc[sfield], ip, Memc[sname], CQ_SZ_QPNAME) == + TOK_IDENTIFIER) + ; + + # Initialize the sort index array. + do i = 1, max_nrecs + sindex[i] = i + + # The sort expression is a simple field. + if (streq (Memc[sfield], Memc[sname])) { + + if (cq_fnumber (res, Memc[sfield]) > 0) { # Catalog field name + stype = cq_ftype (res, Memc[sfield]) + } else if (Memc[sfield] == 'f') { # Generic f# name + ip = 2 + if (ctoi (Memc[sfield], ip, snum) <= 0) + stype = INDEFI + else if (cq_fname (res, snum, Memc[sname], CQ_SZ_FNAME) <= 0) + stype = INDEFI + else + stype = cq_ftype (res, Memc[sname]) + } else { # Unknown name. + stype = INDEFI + } + + # Do the sort. + if (IS_INDEFI(stype)) { # Field is undecodable. + nrecs = max_nrecs + + } else if (stype == TY_CHAR) { # Character sort. + sz_carray = 10 * SZ_LINE + call malloc (carray, sz_carray, TY_CHAR) + ip = 1 + do i = 1, max_nrecs { + nchars = cq_gvalc (res, i, Memc[sname], Memc[sval], + SZ_LINE) + if (nchars > sz_carray - ip + 1) { + sz_carray = sz_carray + 10 * SZ_LINE + call realloc (carray, sz_carray, TY_CHAR) + } + sindex[i] = ip + ip = ip + gstrcpy (Memc[sval], Memc[carray+ip-1], nchars) + Memc[carray+ip-1] = EOS + ip = ip + 1 + } + call at_ssquick (Memc[carray], sindex, sindex, max_nrecs) + call mfree (carray, TY_CHAR) + nrecs = max_nrecs + + } else { # Numeric sort. + call malloc (darray, max_nrecs, TY_DOUBLE) + do i = 1, max_nrecs { + nchars = cq_gvald (res, i, Memc[sname], dval) + if (nchars <= 0) + Memd[darray+i-1] = INDEFD + else + Memd[darray+i-1] = dval + } + call at_qsortd (Memd[darray], sindex, sindex, max_nrecs) + call mfree (darray, TY_DOUBLE) + nrecs = max_nrecs + } + + # The sort field is an expression which must be evaluated. + } else { + + # Determine the data type of the output from the first record. + if (cq_setrecord (res, 1) != 1) + ; + o = evvexpr (Memc[sfield], locpr (at_getop), res, 0, res, 0) + stype = O_TYPE(o) + call evvfree (o) + + if (stype == 0) # Expression cannot be decoded. + nrecs = max_nrecs + else if (stype == TY_CHAR || stype == TY_BOOL) { + sz_carray = 10 * SZ_LINE + call malloc (carray, sz_carray, TY_CHAR) + ip = 1 + do i = 1, max_nrecs { + if (cq_setrecord (res, i) != i) + break + o = evvexpr (Memc[sfield], locpr (at_getop), res, 0, res, 0) + if (O_LEN(o) > sz_carray - ip + 1) { + sz_carray = sz_carray + 10 * SZ_LINE + call realloc (carray, sz_carray, TY_CHAR) + } + sindex[i] = ip + ip = ip + gstrcpy (O_VALC(o), Memc[carray+ip-1], O_LEN(o)) + Memc[carray+ip-1] = EOS + ip = ip + 1 + call evvfree (o) + } + + call at_ssquick (Memc[carray], sindex, sindex, max_nrecs) + call mfree (carray, TY_CHAR) + nrecs = max_nrecs + } else { + call malloc (darray, max_nrecs, TY_DOUBLE) + do i = 1, max_nrecs { + if (cq_setrecord (res, i) != i) + break + o = evvexpr (Memc[sfield], locpr (at_getop), res, 0, res, 0) + switch (O_TYPE(o)) { + case TY_SHORT: + dval = O_VALS(o) + case TY_INT: + dval = O_VALI(o) + case TY_LONG: + dval = O_VALL(o) + case TY_REAL: + dval = O_VALR(o) + case TY_DOUBLE: + dval = O_VALD(o) + default: + dval = INDEFD + } + Memd[darray+i-1] = dval + call evvfree (o) + } + call at_qsortd (Memd[darray], sindex, sindex, max_nrecs) + call mfree (darray, TY_DOUBLE) + nrecs = max_nrecs + } + + } + + # Flip the index array if the sense of the sort is reversed. + if (at_stati (at, FREVERSE) == YES) { + do i = 1, nrecs / 2 { + ip = sindex[i] + sindex[i] = sindex[nrecs-i+1] + sindex[nrecs-i+1] = ip + } + } + + call sfree (sp) + + return (nrecs) +end + + +# AT_COWCS -- Initialize the catalog and output coordinate system +# descriptors. + +procedure at_cowcs (at, res, im, catcoo, outcoo, imcoo, mwim) + +pointer at #I the astrometry package descriptor +pointer res #I the catalog results descriptor +pointer im #I the associated image descriptor +pointer catcoo #O the output catalog system descriptor +pointer outcoo #O the output output system descriptor +pointer imcoo #O the output image system descriptor +pointer mwim #O the output image mwcs descriptor + +pointer sp, csystem, cfield, fra, fdec, mw +int i, catstat, outstat, imstat +int cq_hinfo(), sk_decwcs(), strdic(), at_wrdstr(), sk_stati() +int at_stati(), sk_decim() + +begin + call smark (sp) + call salloc (csystem, SZ_LINE, TY_CHAR) + call salloc (cfield, SZ_LINE, TY_CHAR) + call salloc (fra, SZ_FNAME, TY_CHAR) + call salloc (fdec, SZ_FNAME, TY_CHAR) + + # Get the catalog system. + if (cq_hinfo (res, "csystem", Memc[csystem], SZ_LINE) <= 0) + call strcpy ("", Memc[csystem], SZ_LINE) + + # Open the catalog system. + catstat = sk_decwcs (Memc[csystem], mw, catcoo, NULL) + if (catstat == ERR || mw != NULL) { + #call eprintf ( + #"Error: Cannot decode the catalog coordinate system\n") + if (mw != NULL) + call mw_close (mw) + call sk_close (catcoo) + catcoo = NULL + imcoo = NULL + outcoo = NULL + call sfree (sp) + return + } + + + # Get and set the ra catalog coordinate units. + call at_stats (at, FIRA, Memc[fra], SZ_FNAME) + call cq_funits (res, Memc[fra], Memc[cfield], SZ_LINE) + i = strdic (Memc[cfield], Memc[cfield], SZ_LINE, SKY_LNG_UNITLIST) + if (i > 0) + call sk_seti (catcoo, S_NLNGUNITS, i) + + # Get and set the dec catalog coordinate units. + call at_stats (at, FIDEC, Memc[fdec], SZ_FNAME) + call cq_funits (res, Memc[fdec], Memc[cfield], SZ_LINE) + i = strdic (Memc[cfield], Memc[cfield], SZ_LINE, SKY_LAT_UNITLIST) + if (i > 0) + call sk_seti (catcoo, S_NLATUNITS, i) + + # Open the output coordinate system if the output coordinate system is + # different from the catalog coordinate system or the units are + # different. + call at_stats (at, FOSYSTEM, Memc[csystem], SZ_LINE) + if (Memc[csystem] != EOS || at_stati(at,FORAUNITS) > 0 || at_stati(at, + FODECUNITS) > 0) { + + if (Memc[csystem] == EOS) + outstat = sk_decwcs (Memc[csystem], mw, outcoo, catcoo) + else + outstat = sk_decwcs (Memc[csystem], mw, outcoo, NULL) + + if (outstat == ERR || mw != NULL) { + #call eprintf ( + #"Error: Cannot decode the output coordinate system\n") + if (mw != NULL) + call mw_close (mw) + call sk_close (outcoo) + outcoo = NULL + } else { + + # Set the output catalog ra units. + i = at_stati (at, FORAUNITS) + if (i <= 0) { + Memc[cfield] = EOS + } else if (at_wrdstr (i, Memc[cfield], SZ_LINE, + AT_RA_UNITS) <= 0) { + Memc[cfield] = EOS + } + if (Memc[cfield] == EOS) { + call sk_seti (outcoo, S_NLNGUNITS, sk_stati (catcoo, + S_NLNGUNITS)) + } else { + i = strdic (Memc[cfield], Memc[cfield], FL_SZ_EXPR, + SKY_LNG_UNITLIST) + if (i > 0) + call sk_seti (outcoo, S_NLNGUNITS, i) + else + call sk_seti (outcoo, S_NLNGUNITS, sk_stati(catcoo, + S_NLNGUNITS)) + } + + # Set the output catalog dec units. + i = at_stati (at, FODECUNITS) + if (i <= 0) { + Memc[cfield] = EOS + } else if (at_wrdstr (i, Memc[cfield], SZ_LINE, + AT_DEC_UNITS) <= 0) { + Memc[cfield] = EOS + } + if (Memc[cfield] == EOS) { + call sk_seti (outcoo, S_NLATUNITS, sk_stati (catcoo, + S_NLATUNITS)) + } else { + i = strdic (Memc[cfield], Memc[cfield], SZ_LINE, + SKY_LAT_UNITLIST) + if (i > 0) + call sk_seti (outcoo, S_NLATUNITS, i) + else + call sk_seti (outcoo, S_NLATUNITS, sk_stati(catcoo, + S_NLATUNITS)) + } + + } + } else { + outcoo = NULL + } + + # Open the image coordinate system. + if (im == NULL) { + imcoo = NULL + mwim = NULL + } else { + imstat = sk_decim (im, "logical", mwim, imcoo) + if (imstat == ERR || mwim == NULL) { + if (mwim != NULL) + call mw_close (mwim) + mwim = NULL + call sk_close (outcoo) + outcoo = NULL + } else { + call sk_seti (imcoo, S_NLNGUNITS, SKY_DEGREES) + call sk_seti (imcoo, S_NLATUNITS, SKY_DEGREES) + } + } + + call sfree (sp) +end + + +# AT_COOFIELDS -- Get the sequence number of the coordinate output fields. + +procedure at_coofields (at, res, flist, raname, decname, rafield, decfield, + xpfield, ypfield, xcfield, ycfield) + + +pointer at #I the astrometry package descriptor +pointer res #I the output results descriptor +pointer flist #I the output field list descriptor +char raname[ARB] #O the catalog ra name +char decname[ARB] #O the catalog dec name +int rafield #O the output ra field no +int decfield #O the output dec field no +int xpfield #O the output xp field no +int ypfield #O the output yp field no +int xcfield #O the output xp field no +int ycfield #O the output yp field no + +pointer sp, xpname, ypname, str +int i +int at_flnexpr(), cq_fnumber() +bool streq() + +begin + # Get working space. + call smark (sp) + call salloc (xpname, FL_SZ_EXPR, TY_CHAR) + call salloc (ypname, FL_SZ_EXPR, TY_CHAR) + call salloc (str, FL_SZ_EXPR, TY_CHAR) + + # Initialize. + rafield = 0 + decfield = 0 + xpfield = 0 + ypfield = 0 + xcfield = 0 + ycfield = 0 + + # Get the ra and dec field names. + call at_stats (at, FIRA, Memc[str], FL_SZ_EXPR) + i = 1 + if (at_flnexpr (res, Memc[str], i, raname, FL_SZ_EXPR) == EOF) + raname[1] = EOS + call at_stats (at, FIDEC, Memc[str], FL_SZ_EXPR) + i = 1 + if (at_flnexpr (res, Memc[str], i, decname, FL_SZ_EXPR) == EOF) + decname[1] = EOS + + # Get the predicted x and y field names. + call at_stats (at, FIXP, Memc[str], FL_SZ_EXPR) + i = 1 + if (at_flnexpr (res, Memc[str], i, Memc[xpname], FL_SZ_EXPR) == EOF) + Memc[xpname] = EOS + call at_stats (at, FIYP, Memc[str], FL_SZ_EXPR) + i = 1 + if (at_flnexpr (res, Memc[str], i, Memc[ypname], FL_SZ_EXPR) == EOF) + Memc[ypname] = EOS + + # Get the center x and y field names. Ignore this for now. + + # Check to see whether the field names are in the input catalog + # and whether at least one of them is in the output catalog. + if (cq_fnumber (res, raname) > 0 && cq_fnumber (res, decname) > 0) { + do i = 0, FL_NFIELDS(flist) - 1 { + if (streq (raname, Memc[FL_FNAMES(flist)+i* + (CQ_SZ_QPNAME+1)])) { + rafield = i + 1 + } else if (streq (decname, Memc[FL_FNAMES(flist)+i* + (CQ_SZ_QPNAME+1)])) { + decfield = i + 1 + } else if (streq (Memc[xpname], Memc[FL_FNAMES(flist)+i* + (CQ_SZ_QPNAME+1)])) { + xpfield = i + 1 + } else if (streq (Memc[ypname], Memc[FL_FNAMES(flist)+i* + (CQ_SZ_QPNAME+1)])) { + ypfield = i + 1 + } + #if (rafield > 0 && decfield > 0) + #break + } + } + + call sfree (sp) +end + + +# AT_MKRECORD -- Format the output catalog record. + +int procedure at_mkrecord (flist, res, record, maxch, recno, rafield, decfield, + raval, decval, xpfield, ypfield, xpval, ypval) + +pointer flist #I the output field list descriptor +pointer res #I the output results descriptor +char record[ARB] #O the output record +int maxch #I the maximum size of a record +int recno #I the current record number +int rafield #I the output ra field +int decfield #I the output dec field +double raval #I the input ra value +double decval #I the input dec value +int xpfield #I the output predicted x field +int ypfield #I the output predicted y field +double xpval #I the input predicted x value +double ypval #I the input predicted y value + +pointer sp, newval, eptr, rptr, o +int i, j, k, op, findex, nchars +pointer evvexpr(), locpr() +int gstrcpy(), cq_rstati(), cq_gvalc(), strlen() +extern at_getop() + +begin + call smark (sp) + call salloc (newval, SZ_LINE, TY_CHAR) + + # Initialize. + findex = 0 + op = 1 + record[op] = EOS + o = NULL + eptr = FL_FLIST(flist) + rptr = FL_FRANGES(flist) + + # Loop over the expressions. + do i = 1, FL_NEXPR(flist) { + + # The output field is an expression. + if (IS_INDEFI(Memi[rptr])) { + + # Evaluate the expression. + if (xpfield == (findex + 1)) { + call sprintf (Memc[newval], maxch, Memc[FL_FFMTS(flist)+ + findex * (CQ_SZ_QPFMTS + 1)]) + call pargd (xpval) + } else if (ypfield == (findex + 1)) { + call sprintf (Memc[newval], maxch, Memc[FL_FFMTS(flist)+ + findex * (CQ_SZ_QPFMTS + 1)]) + call pargd (ypval) + } else { + + if (o != NULL) + call evvfree (o) + o = evvexpr (Memc[eptr], locpr (at_getop), res, 0, res, 0) + + # Encode the expression in a string. + switch (O_TYPE(o)) { + case TY_CHAR: + call sprintf (Memc[newval], maxch, Memc[FL_FFMTS(flist)+ + findex * (CQ_SZ_QPFMTS + 1)]) + call pargstr (O_VALC(o)) + case TY_INT: + call sprintf (Memc[newval], maxch, Memc[FL_FFMTS(flist)+ + findex * (CQ_SZ_QPFMTS + 1)]) + call pargi (O_VALI(o)) + case TY_REAL: + call sprintf (Memc[newval], maxch, Memc[FL_FFMTS(flist)+ + findex * (CQ_SZ_QPFMTS + 1)]) + call pargr (O_VALR(o)) + case TY_DOUBLE: + call sprintf (Memc[newval], maxch, Memc[FL_FFMTS(flist)+ + findex * (CQ_SZ_QPFMTS + 1)]) + call pargd (O_VALD(o)) + default: + call sprintf (Memc[newval], maxch, Memc[FL_FFMTS(flist)+ + findex * (CQ_SZ_QPFMTS + 1)]) + call pargstr (O_VALC(o)) + } + } + + # Copy the string to the output record. + if (Memi[FL_FSIZES(flist)+findex] == 0) { + op = op + gstrcpy (" ", record[op], maxch - op + 1) + op = op + gstrcpy (Memc[newval], record[op], maxch - op + 1) + op = op + gstrcpy (" ", record[op], maxch - op + 1) + } else { + nchars = min (Memi[FL_FSIZES(flist)+findex], + strlen (Memc[newval])) + do k = 1, Memi[FL_FSIZES(flist)+findex] - nchars - 1 { + if (op > maxch) + break + record[op] = ' ' + op = op + 1 + } + op = op + gstrcpy (Memc[newval], record[op], min (nchars, + maxch - op + 1)) + op = op + gstrcpy (" ", record[op], maxch - op + 1) + } + + findex = findex + 1 + + # The field expression are input catalog columns. + } else if (Memi[rptr] >= 1 && Memi[rptr+1] <= cq_rstati (res, + CQNFIELDS)) { + + # Loop over the fields in each range. + do j = max (1, Memi[rptr]), min (Memi[rptr+1], cq_rstati(res, + CQNFIELDS)), Memi[rptr+2] { + + # Encode the record values. + if (rafield == (findex + 1)) { + call sprintf (Memc[newval], SZ_LINE, + Memc[FL_FFMTS(flist)+ findex * (CQ_SZ_QPFMTS + 1)]) + call pargd (raval) + nchars = strlen (Memc[newval]) + } else if (decfield == (findex + 1)) { + call sprintf (Memc[newval], SZ_LINE, + Memc[FL_FFMTS(flist)+ findex * (CQ_SZ_QPFMTS + 1)]) + call pargd (decval) + nchars = strlen (Memc[newval]) + } else if (xpfield == (findex + 1)) { + call sprintf (Memc[newval], SZ_LINE, + Memc[FL_FFMTS(flist)+ findex * (CQ_SZ_QPFMTS + 1)]) + call pargd (xpval) + nchars = strlen (Memc[newval]) + } else if (ypfield == (findex + 1)) { + call sprintf (Memc[newval], SZ_LINE, + Memc[FL_FFMTS(flist)+ findex * (CQ_SZ_QPFMTS + 1)]) + call pargd (ypval) + nchars = strlen (Memc[newval]) + } else { + nchars = cq_gvalc (res, recno, Memc[FL_FNAMES(flist)+ + findex*(CQ_SZ_QPNAME+1)], Memc[newval], SZ_LINE) + } + + # Copy the string to the output record. + if (Memi[FL_FSIZES(flist)+findex] == 0) { + if ((j == 1) && (! IS_WHITE(Memc[newval]))) + op = op + gstrcpy (" ", record[op], maxch - op + 1) + else if (rafield == (findex + 1) || decfield == + (findex + 1) || xpfield == (findex + 1) || + ypfield == (findex + 1)) + op = op + gstrcpy (" ", record[op], maxch - op + 1) + op = op + gstrcpy (Memc[newval], record[op], + maxch - op + 1) + if (rafield == (findex + 1) || decfield == + (findex + 1) || xpfield == (findex + 1) || + ypfield == (findex + 1)) + op = op + gstrcpy (" ", record[op], maxch - op + 1) + } else { + nchars = min (Memi[FL_FSIZES(flist)+findex], nchars) + do k = 1, Memi[FL_FSIZES(flist)+findex] - nchars - 1 { + if (op > maxch) + break + record[op] = ' ' + op = op + 1 + } + op = op + gstrcpy (Memc[newval], record[op], + min (nchars, maxch - op + 1)) + op = op + gstrcpy (" ", record[op], maxch - op + 1) + } + + findex = findex + 1 + } + } + + # Increment the expression and ranges pointers. + eptr = eptr + FL_SZ_EXPR + 1 + rptr = rptr + 3 + } + if (o != NULL) + call evvfree (o) + + # Append a newline and EOS to the data. + if (record[1] != EOS) { + record[op] = '\n' + record[op+1] = EOS + } + + call sfree (sp) + + return (op - 1) +end + + +# AT_NFLIST -- Add new fields to the current output field list and optionally +# specify the field names, field types, field units, and field formats. + +procedure at_nflist (at, nfields, nfnames, nftypes, nfunits, nformats, append) + +pointer at #I the astrometry package descriptors +int nfields #I the number of new fields +char nfnames[ARB] #I the new field names list +char nftypes[ARB] #I the new field types list +char nfunits[ARB] #I the new field units list +char nformats[ARB] #I the new field formats list +bool append #I append the new fields + +pointer sp, str1, str2 +int i, op1, op2 +int gstrcpy(), strlen + +begin + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + # Set the new output field expressions to INDEF and retrieve the + # original user fields value. + call at_stats (at, FIELDS, Memc[str1], SZ_LINE) + op1 = strlen (Memc[str1]) + op2 = 0 + do i = 1, nfields { + if (i == 1) { + op2 = op2 + gstrcpy ("INDEF", Memc[str2+op2], SZ_LINE - op2) + } else { + op2 = op2 + gstrcpy (",", Memc[str2+op2], SZ_LINE - op2) + op2 = op2 + gstrcpy ("INDEF", Memc[str2+op2], SZ_LINE - op2) + } + } + + # Construct the new output fields string. + if (append) { + op1 = op1 + gstrcpy (",", Memc[str1+op1], SZ_LINE - op1) + op1 = op1 + gstrcpy (Memc[str2], Memc[str1+op1], SZ_LINE - op1) + call at_sets (at, FIELDS, Memc[str1]) + } else { + op2 = op 2+ gstrcpy (",", Memc[str2+op2], SZ_LINE - op2) + op2 = op2 + gstrcpy (Memc[str1], Memc[str2+op2], SZ_LINE - op2) + call at_sets (at, FIELDS, Memc[str2]) + } + + # Construct the new field names. + call at_stats (at, FNAMES, Memc[str1], SZ_LINE) + op1 = strlen (Memc[str1]) + op2 = 0 + if (append) { + op1 = op1 + gstrcpy (",", Memc[str1+op1], SZ_LINE - op1) + op1 = op1 + gstrcpy (nfnames, Memc[str1+op1], SZ_LINE - op1) + call at_sets (at, FNAMES, Memc[str1]) + } else { + op2 = op2 + gstrcpy (nfnames, Memc[str2+op2], SZ_LINE - op2) + op2 = op2 + gstrcpy (",", Memc[str2+op2], SZ_LINE - op2) + op2 = op2 + gstrcpy (Memc[str1], Memc[str2+op2], SZ_LINE - op2) + call at_sets (at, FNAMES, Memc[str2]) + } + + # Construct the new field types. + call at_stats (at, FNTYPES, Memc[str1], SZ_LINE) + op1 = strlen (Memc[str1]) + op2 = 0 + if (append) { + op1 = op1 + gstrcpy (",", Memc[str1+op1], SZ_LINE - op1) + op1 = op1 + gstrcpy (nftypes, Memc[str1+op1], SZ_LINE - op1) + call at_sets (at, FNTYPES, Memc[str1]) + } else { + op2 = op2 + gstrcpy (nftypes, Memc[str2+op2], SZ_LINE - op2) + op2 = op2 + gstrcpy (",", Memc[str2+op2], SZ_LINE - op2) + op2 = op2 + gstrcpy (Memc[str1], Memc[str2+op2], SZ_LINE - op2) + call at_sets (at, FNTYPES, Memc[str2]) + } + + # Construct the new field units. + call at_stats (at, FNUNITS, Memc[str1], SZ_LINE) + op1 = strlen (Memc[str1]) + op2 = 0 + if (append) { + op1 = op1 + gstrcpy (",", Memc[str1+op1], SZ_LINE - op1) + op1 = op1 + gstrcpy (nfunits, Memc[str1+op1], SZ_LINE - op1) + call at_sets (at, FNUNITS, Memc[str1]) + } else { + op2 = op2 + gstrcpy (nfunits, Memc[str2+op2], SZ_LINE - op2) + op2 = op2 + gstrcpy (",", Memc[str2+op2], SZ_LINE - op2) + op2 = op2 + gstrcpy (Memc[str1], Memc[str2+op2], SZ_LINE - op2) + call at_sets (at, FNUNITS, Memc[str2]) + } + + # Construct the new field units. + call at_stats (at, FNFORMATS, Memc[str1], SZ_LINE) + op1 = strlen (Memc[str1]) + op2 = 0 + if (append) { + op1 = op1 + gstrcpy (",", Memc[str1+op1], SZ_LINE - op1) + op1 = op1 + gstrcpy (nformats, Memc[str1+op1], SZ_LINE - op1) + call at_sets (at, FNFORMATS, Memc[str1]) + } else { + op2 = op2 + gstrcpy (nformats, Memc[str2+op2], SZ_LINE - op2) + op2 = op2 + gstrcpy (",", Memc[str2+op2], SZ_LINE - op2) + op2 = op2 + gstrcpy (Memc[str1], Memc[str2+op2], SZ_LINE - op2) + call at_sets (at, FNFORMATS, Memc[str2]) + } + + call sfree (sp) +end + + +# AT_FLINIT -- Initialize the field list structure. This routines: 1) +# creates a list of fields, field ranges, and field expressions, 2) determines +# whether an output field is an input field or a field expression, and 3) +# assembles the information required to write a catalog header. + + +pointer procedure at_flinit (at, res) + +pointer at #I the astrometry package descriptor +pointer res #I results descriptor + +pointer sp, fields +pointer fl +int nexpr, nfields +int at_flelist(), at_flranges() + +begin + # Get some working space. + call smark (sp) + call salloc (fields, SZ_LINE, TY_CHAR) + + # Get the user field list. + call at_stats (at, FIELDS, Memc[fields], SZ_LINE) + + # Allocate the field list descriptor. + call calloc (fl, FL_FLENGTH, TY_STRUCT) + + # Create the field expression list. + nexpr = at_flelist (res, Memc[fields], fl) + if (nexpr > 0) { + + # Determine which individual fields are to be output. + nfields = at_flranges (res, fl) + + # Compile the new header info. + if (nfields > 0) + call at_flflist (at, res, fl) + } + + call sfree (sp) + + return (fl) +end + + +# AT_FLFREE -- Free the field list structure. + +procedure at_flfree (fl) + +pointer fl #I the field list descriptor + +begin + if (FL_FLIST(fl) != NULL) + call mfree (FL_FLIST(fl), TY_CHAR) + if (FL_FRANGES(fl) != NULL) + call mfree (FL_FRANGES(fl), TY_STRUCT) + + if (FL_FNAMES(fl) != NULL) + call mfree (FL_FNAMES(fl), TY_CHAR) + if (FL_FOFFSETS(fl) != NULL) + call mfree (FL_FOFFSETS(fl), TY_INT) + if (FL_FSIZES(fl) != NULL) + call mfree (FL_FSIZES(fl), TY_INT) + if (FL_FTYPES(fl) != NULL) + call mfree (FL_FTYPES(fl), TY_INT) + if (FL_FUNITS(fl) != NULL) + call mfree (FL_FUNITS(fl), TY_CHAR) + if (FL_FFMTS(fl) != NULL) + call mfree (FL_FFMTS(fl), TY_CHAR) + + call mfree (fl, TY_STRUCT) +end + + +# AT_FLELIST -- Create the expression list from the user field list. + +int procedure at_flelist (res, fields, fl) + +pointer res #I the results descriptor +char fields[ARB] #I the user field list +pointer fl #O the field list descriptor + +int i, ip, fp, nexpr +int at_flnexpr() + +begin + # Allocate space for the expression list. + call malloc (FL_FLIST(fl), FL_MAX_NEXPR * (FL_SZ_EXPR + 1), TY_CHAR) + + # Decode the user field list into a list of comma separated + # expressions. Expressions may be field names (e.g. "ra" or "f2"), + # field ranges (e.g. "f[*]" or "f[1-4]"), or field expressions + # (e.g. "f2 - f3" or "mag2 - mag1"). + + ip = 1 + fp = FL_FLIST(fl) + nexpr = 0 + do i = 1, FL_MAX_NEXPR { + if (at_flnexpr (res, fields, ip, Memc[fp], FL_SZ_EXPR) == EOF) + break + #call strlwr (Memc[fp]) + fp = fp + FL_SZ_EXPR + 1 + nexpr = nexpr + 1 + } + call realloc (FL_FLIST(fl), nexpr * (FL_SZ_EXPR + 1), TY_CHAR) + FL_NEXPR(fl) = nexpr + + return (nexpr) +end + + +# AT_FLNEXPR -- Get the next expression from an expression list. + +int procedure at_flnexpr (res, exprlist, ip, expr, maxch) + +pointer res #I pointer to the results descriptor +char exprlist[ARB] #I the input expression list +int ip #I pointer into the expression list +char expr[ARB] #O the output expression +int maxch #I maximum length of the output expression + +int ep, op, token, fnum +int ctotok(), strlen(), cq_fnumber(), ctoi(), cq_rstati(), cq_fname() + +begin + # Decode the column labels. + op = 1 + while (exprlist[ip] != EOS) { + + token = ctotok (exprlist, ip, expr[op], maxch) + if (expr[op] == EOS) + next + + if ((token == TOK_PUNCTUATION) && (expr[op] == ',')) { + if (op == 1) + next + else + break + } + + # Replace generic identifiers with their catalog equivalents. + if (token == TOK_IDENTIFIER) { + fnum = cq_fnumber (res, expr[op]) + if (fnum <= 0 && expr[op] == 'f') { + ep = 2 + if (ctoi (expr[op], ep, fnum) <= 0) + fnum = 0 + if (fnum < 1 || fnum > cq_rstati (res, CQRNRECS)) + fnum = 0 + if (fnum > 0) { + if (cq_fname (res, fnum, expr[op], maxch) != fnum) + ; + } + } + } + + + op = op + strlen (expr[op]) + } + + expr[op] = EOS + if ((exprlist[ip] == EOS) && (op == 1)) + return (EOF) + else + return (op - 1) +end + + +# AT_FLNITEM -- Get the next expression from an expression list. + +int procedure at_flnitem (itemlist, ip, item, maxch) + +char itemlist[ARB] #I the input item list +int ip #I pointer into the item list +char item[ARB] #O the output item +int maxch #I maximum length of the output item + +int op, token +int ctotok(), strlen() + +begin + # Decode the column labels. + op = 1 + while (itemlist[ip] != EOS) { + + token = ctotok (itemlist, ip, item[op], maxch) + if (item[op] == EOS) + next + + if ((token == TOK_PUNCTUATION) && (item[op] == ',')) { + if (op == 1) + next + else + break + } + + op = op + strlen (item[op]) + } + + item[op] = EOS + if ((itemlist[ip] == EOS) && (op == 1)) + return (EOF) + else + return (op - 1) +end + + +# AT_FLRANGES -- Get the field ranges for each output field. + +int procedure at_flranges (res, fl) + +pointer res #I the results descriptor +pointer fl #I the field list descriptor + +pointer sp, fname, fptr, rptr +int i, nin, nout, lindex, rindex, ip1, ip2, f1, f2 +char lbracket, rbracket +int cq_rstati(), strldx(), ctoi(), ctotok(), cq_fnumber() +bool streq() +data lbracket /'['/, rbracket /']'/ + +begin + # Allocate working space. + call smark (sp) + call salloc (fname, FL_SZ_EXPR, TY_CHAR) + + # Allocate space for the ranges list. + call calloc (FL_FRANGES(fl), 3 * FL_NEXPR(fl) + 1, TY_INT) + + # Initialize. + nin = cq_rstati (res, CQNFIELDS) + nout = 0 + + # Loop over the expressions. Fields which cannot be decoded + # have zero-valued range entries. Expression fields have INDEFI + # valued range entries. + fptr = FL_FLIST(fl) + rptr = FL_FRANGES(fl) + do i = 1, FL_NEXPR (fl) { + + lindex = strldx (lbracket, Memc[fptr]) + rindex = strldx (rbracket, Memc[fptr]) + ip1 = 1 + ip2 = lindex + 1 + + # Decode generic field ranges. + if (Memc[fptr] == 'f' && lindex == 2 && rindex > lindex) { + + # Find the range limits. + if (Memc[fptr+lindex] == '*') { + f1 = 1 + f2 = nin + } else { + if (ctoi (Memc[fptr], ip2, f1) <= 0) + f1 = 0 + else if (f1 < 1 || f1 > nin) + f1 = 0 + if (ctoi (Memc[fptr], ip2, f2) <= 0) + f2 = 0 + else + f2 = -f2 + if (f2 < 1 || f2 > nin) + f2 = 0 + } + + # Valid range. + if (f1 > 0 && f2 > f1) { + Memi[rptr] = f1 + Memi[rptr+1] = f2 + Memi[rptr+2] = 1 + nout = nout + f2 - f1 + 1 + + # Field cannot be decoded. + } else { + Memi[rptr] = 0 + Memi[rptr+1] = 0 + Memi[rptr+2] = 0 + } + + # Decode fields and expressions. + } else if (ctotok (Memc[fptr], ip1, Memc[fname], FL_SZ_EXPR) == + TOK_IDENTIFIER) { + + # Find the field number. + f1 = cq_fnumber (res, Memc[fptr]) + if (f1 <= 0 && streq (Memc[fptr], Memc[fname])) { + if (Memc[fptr] != 'f') + f1 = 0 + else { + f2 = 1 + if (ctoi (Memc[fptr+1], f2, f1) <= 0) + f1 = 0 + else if (f1 < 1 || f1 > nin) + f1 = 0 + } + } + + # Valid single field. + if (f1 > 0) { + Memi[rptr] = f1 + Memi[rptr+1] = f1 + Memi[rptr+2] = 1 + nout = nout + 1 + + # Field is an expression. + } else if (ctotok (Memc[fptr], ip1, Memc[fname], + FL_SZ_EXPR) != TOK_EOS) { + Memi[rptr] = INDEFI + Memi[rptr+1] = INDEFI + Memi[rptr+2] = INDEFI + nout = nout + 1 + + # Field cannot be decoded. + } else { + Memi[rptr] = 0 + Memi[rptr+1] = 0 + Memi[rptr+2] = 0 + } + + # What's left over is an expression field. + } else { + + Memi[rptr] = INDEFI + Memi[rptr+1] = INDEFI + Memi[rptr+2] = INDEFI + nout = nout + 1 + } + + fptr = fptr + FL_SZ_EXPR + 1 + rptr = rptr + 3 + } + + # Store the field counts. + FL_NFIELDS(fl) = nout + + call sfree (sp) + + return (nout) +end + + +# AT_FLFLIST -- Assemble the field header info for the new catalog. + +procedure at_flflist (at, res, fl) + +pointer at #I the astrometry package descriptor +pointer res #I the results descriptor +pointer fl #I the field list descriptor + +pointer sp, fnames, fntypes, fnunits, fnfmts, franame, fdecname, xpname +pointer ypname, xcname, ycname, str, rptr +int i, j, ip, nfields, fnp, ftp, fup, ffp, rtype, foffset, ival +int cq_rstati(), ctotok(), at_dtype(), ctoi(), cq_finfon() +int at_wrdstr(), at_stati(), at_flnitem() +bool streq(), strne() + +begin + # Get the number of output fields. + nfields = FL_NFIELDS(fl) + if (nfields <= 0) + return + + # Get some working space. + call smark (sp) + call salloc (fnames, SZ_LINE, TY_CHAR) + call salloc (fntypes, SZ_LINE, TY_CHAR) + call salloc (fnunits, SZ_LINE, TY_CHAR) + call salloc (fnfmts, SZ_LINE, TY_CHAR) + call salloc (franame, CQ_SZ_QPNAME, TY_CHAR) + call salloc (fdecname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (xpname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (ypname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (xcname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (ycname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Get the user parameters defining the names, types, units, and + # formats of the new fields. + call at_stats (at, FNAMES, Memc[fnames], SZ_LINE) + call at_stats (at, FNTYPES, Memc[fntypes], SZ_LINE) + call at_stats (at, FNUNITS, Memc[fnunits], SZ_LINE) + call at_stats (at, FNFORMATS, Memc[fnfmts], SZ_LINE) + fnp = 1 + ftp = 1 + fup = 1 + ffp = 1 + + # Get the special coordinate field names. + call at_stats (at, FIRA, Memc[franame], CQ_SZ_FNAME) + call at_stats (at, FIDEC, Memc[fdecname], CQ_SZ_FNAME) + call at_stats (at, FIXP, Memc[xpname], CQ_SZ_FNAME) + call at_stats (at, FIYP, Memc[ypname], CQ_SZ_FNAME) + call at_stats (at, FIXC, Memc[xcname], CQ_SZ_FNAME) + call at_stats (at, FIYC, Memc[ycname], CQ_SZ_FNAME) + + # Allocate space for the header field names, offsets, sizes, data + # types, units, and formats. + call calloc (FL_FNAMES(fl), nfields * (CQ_SZ_QPNAME + 1), TY_CHAR) + call calloc (FL_FOFFSETS(fl), nfields, TY_INT) + call calloc (FL_FSIZES(fl), nfields, TY_INT) + call calloc (FL_FTYPES(fl), nfields, TY_INT) + call calloc (FL_FUNITS(fl), nfields * (CQ_SZ_QPUNITS + 1), TY_CHAR) + call calloc (FL_FFMTS(fl), nfields * (CQ_SZ_QPFMTS + 1), TY_CHAR) + + # Get the output type. This is the same as the input type. + rtype = cq_rstati (res, CQRTYPE) + + # Loop over the ranges list. + nfields = 0 + foffset = 1 + rptr = FL_FRANGES(fl) + do i = 1, FL_NEXPR(fl) { + + # Skip non-decodable fields. + if (Memi[rptr] == 0) { + rptr = rptr + 3 + next + } + + # The field is an input catalog field. + if (! IS_INDEFI (Memi[rptr])) { + + do j = Memi[rptr], Memi[rptr+1] { + + # Get the field name, the field offset, size, data type, + # units and default format. + if (cq_finfon (res, j, Memc[FL_FNAMES(fl)+nfields* + (CQ_SZ_QPNAME+1)], CQ_SZ_QPNAME, Memi[FL_FOFFSETS(fl)+ + nfields], Memi[FL_FSIZES(fl)+nfields], + Memi[FL_FTYPES(fl)+nfields], + Memc[FL_FUNITS(fl)+nfields*(CQ_SZ_QPUNITS+1)], + CQ_SZ_QPUNITS, Memc[FL_FFMTS(fl)+nfields* + (CQ_SZ_QPFMTS+1)], CQ_SZ_QPFMTS) != j) + ; + + # Correct the field offset and field size. + switch (rtype) { + case CQ_STEXT: + Memi[FL_FOFFSETS(fl)+nfields] = nfields + 1 + Memi[FL_FSIZES(fl)+nfields] = 0 + case CQ_BTEXT: + Memi[FL_FOFFSETS(fl)+nfields] = foffset + foffset = foffset + Memi[FL_FSIZES(fl)+nfields] + default: + call error (0, "Unknown output catalog type") + ; + } + + # Correct for coordinate units and format transform here. + if (streq (Memc[franame], Memc[FL_FNAMES(fl)+ + nfields*(CQ_SZ_QPNAME+1)])) { + ival = at_stati (at, FORAUNITS) + if (ival <= 0) + Memc[str] = EOS + else if (at_wrdstr (ival, Memc[str], SZ_FNAME, + AT_RA_UNITS) <= 0) + Memc[str] = EOS + if (Memc[str] != EOS && strne (Memc[str], + Memc[FL_FUNITS(fl)+nfields*(CQ_SZ_QPUNITS+1)])) + call strcpy (Memc[str], Memc[FL_FUNITS(fl)+ + nfields*(CQ_SZ_QPUNITS+1)], CQ_SZ_QPUNITS) + call at_stats (at, FORAFORMAT, Memc[str], SZ_FNAME) + if (Memc[str] != EOS && strne (Memc[str], + Memc[FL_FFMTS(fl)+nfields*(CQ_SZ_QPFMTS+1)])) + call strcpy (Memc[str], Memc[FL_FFMTS(fl)+ + nfields*(CQ_SZ_QPFMTS+1)], CQ_SZ_QPFMTS) + } + if (streq (Memc[fdecname], Memc[FL_FNAMES(fl)+ + nfields*(CQ_SZ_QPNAME+1)])) { + ival = at_stati (at, FODECUNITS) + if (ival <= 0) + Memc[str] = EOS + else if (at_wrdstr (ival, Memc[str], SZ_FNAME, + AT_DEC_UNITS) <= 0) + Memc[str] = EOS + if (Memc[str] != EOS && strne (Memc[str], + Memc[FL_FUNITS(fl)+nfields*(CQ_SZ_QPUNITS+1)])) + call strcpy (Memc[str], Memc[FL_FUNITS(fl)+ + nfields*(CQ_SZ_QPUNITS+1)], CQ_SZ_QPUNITS) + call at_stats (at, FODECFORMAT, Memc[str], SZ_FNAME) + if (Memc[str] != EOS && strne (Memc[str], + Memc[FL_FFMTS(fl)+nfields*(CQ_SZ_QPFMTS+1)])) + call strcpy (Memc[str], Memc[FL_FFMTS(fl)+ + nfields*(CQ_SZ_QPFMTS+1)], CQ_SZ_QPFMTS) + } + + # Correct for pixel coordinate formats here. + if (streq (Memc[xpname], Memc[FL_FNAMES(fl)+ + nfields*(CQ_SZ_QPNAME+1)]) || streq (Memc[xcname], + Memc[FL_FNAMES(fl)+nfields*(CQ_SZ_QPNAME+1)])) { + call at_stats (at, FOXFORMAT, Memc[str], SZ_FNAME) + if (Memc[str] != EOS && strne (Memc[str], + Memc[FL_FFMTS(fl)+nfields*(CQ_SZ_QPFMTS+1)])) + call strcpy (Memc[str], Memc[FL_FFMTS(fl)+ + nfields*(CQ_SZ_QPFMTS+1)], CQ_SZ_QPFMTS) + } + if (streq (Memc[ypname], Memc[FL_FNAMES(fl)+ + nfields*(CQ_SZ_QPNAME+1)]) || streq (Memc[ycname], + Memc[FL_FNAMES(fl)+nfields*(CQ_SZ_QPNAME+1)])) { + call at_stats (at, FOYFORMAT, Memc[str], SZ_FNAME) + if (Memc[str] != EOS && strne (Memc[str], + Memc[FL_FFMTS(fl)+nfields*(CQ_SZ_QPFMTS+1)])) + call strcpy (Memc[str], Memc[FL_FFMTS(fl)+ + nfields*(CQ_SZ_QPFMTS+1)], CQ_SZ_QPFMTS) + } + + + nfields = nfields + 1 + } + + # This field is a new field. + } else { + + # Get the field names. The default is f#. + ip = 1 + if (at_flnitem (Memc[fnames], fnp, Memc[FL_FNAMES(fl)+ + nfields*(CQ_SZ_QPNAME+1)], CQ_SZ_QPNAME) == EOF) { + call sprintf (Memc[FL_FNAMES(fl)+nfields*(CQ_SZ_QPNAME+1)], + CQ_SZ_QPNAME, "f%d") + call pargi (nfields + 1) + } else if (ctotok (Memc[FL_FNAMES(fl)+nfields* + (CQ_SZ_QPNAME+1)], ip, Memc[FL_FNAMES(fl)+nfields* + (CQ_SZ_QPNAME+1)], CQ_SZ_QPNAME) != TOK_IDENTIFIER) { + call sprintf (Memc[FL_FNAMES(fl)+nfields*(CQ_SZ_QPNAME+1)], + CQ_SZ_QPNAME, "f%d") + call pargi (nfields + 1) + } + + # Get the data types. The default for now is type real. + ip = 1 + if (at_flnitem (Memc[fntypes], ftp, Memc[str], + SZ_FNAME) == EOF) { + Memi[FL_FTYPES(fl)+nfields] = TY_REAL + } else if (ctotok (Memc[str], ip, Memc[str], SZ_FNAME) != + TOK_IDENTIFIER) { + Memi[FL_FTYPES(fl)+nfields] = TY_REAL + } else { + #call strlwr (Memc[str]) + #Memi[FL_FTYPES(fl)+nfields] = cq_dtype(Memc[str]) + Memi[FL_FTYPES(fl)+nfields] = at_dtype(Memc[str]) + } + + # Get the data units. The default is INDEF. + ip = 1 + if (at_flnitem (Memc[fnunits], fup, Memc[FL_FUNITS(fl)+ + nfields*(CQ_SZ_QPUNITS+1)], CQ_SZ_QPUNITS) == EOF) { + call strcpy ("INDEF", Memc[FL_FUNITS(fl)+nfields* + (CQ_SZ_QPUNITS+1)], CQ_SZ_QPUNITS) + } else if (ctotok (Memc[FL_FUNITS(fl)+nfields* + (CQ_SZ_QPUNITS+1)], ip, Memc[FL_FUNITS(fl)+nfields* + (CQ_SZ_QPUNITS+1)], CQ_SZ_QPUNITS) != TOK_IDENTIFIER) { + call strcpy ("INDEF", Memc[FL_FUNITS(fl)+nfields* + (CQ_SZ_QPUNITS+1)], CQ_SZ_QPUNITS) + } + + # Get the data formats. The default is %10s, %10d, and %10g + # for character, integer, and floating data points respectively. + ip = 1 + if (at_flnitem (Memc[fnfmts], ffp, Memc[FL_FFMTS(fl)+nfields* + (CQ_SZ_QPFMTS+1)], CQ_SZ_QPFMTS) == EOF) { + switch (Memi[FL_FTYPES(fl)+nfields]) { + case TY_CHAR: + call strcpy ("%10s", Memc[FL_FFMTS(fl)+nfields* + (CQ_SZ_QPFMTS+1)], CQ_SZ_QPFMTS) + case TY_SHORT, TY_INT, TY_LONG: + call strcpy ("%10d", Memc[FL_FFMTS(fl)+nfields* + (CQ_SZ_QPFMTS+1)], CQ_SZ_QPFMTS) + case TY_REAL, TY_DOUBLE: + call strcpy ("%10g", Memc[FL_FFMTS(fl)+nfields* + (CQ_SZ_QPFMTS+1)], CQ_SZ_QPFMTS) + } + } else if (Memc[FL_FFMTS(fl)+nfields*(CQ_SZ_QPFMTS+1)] != '%') { + switch (Memi[FL_FTYPES(fl)+nfields*(CQ_SZ_QPFMTS+1)]) { + case TY_CHAR: + call strcpy ("%10s", Memc[FL_FFMTS(fl)+nfields* + (CQ_SZ_QPFMTS+1)], CQ_SZ_QPFMTS) + case TY_SHORT, TY_INT, TY_LONG: + call strcpy ("%10d", Memc[FL_FFMTS(fl)+nfields* + (CQ_SZ_QPFMTS+1)], CQ_SZ_QPFMTS) + case TY_REAL, TY_DOUBLE: + call strcpy ("%10g", Memc[FL_FFMTS(fl)+nfields* + (CQ_SZ_QPFMTS+1)], CQ_SZ_QPFMTS) + } + } + + # Correct for pixel coordinate formats here. + if (streq (Memc[xpname], Memc[FL_FNAMES(fl)+ + nfields*(CQ_SZ_QPNAME+1)]) || streq (Memc[xcname], + Memc[FL_FNAMES(fl)+nfields*(CQ_SZ_QPNAME+1)])) { + call at_stats (at, FOXFORMAT, Memc[str], SZ_FNAME) + if (Memc[str] != EOS && strne (Memc[str], + Memc[FL_FFMTS(fl)+nfields*(CQ_SZ_QPFMTS+1)])) + call strcpy (Memc[str], Memc[FL_FFMTS(fl)+ + nfields*(CQ_SZ_QPFMTS+1)], CQ_SZ_QPFMTS) + } + if (streq (Memc[ypname], Memc[FL_FNAMES(fl)+ + nfields*(CQ_SZ_QPNAME+1)]) || streq (Memc[ycname], + Memc[FL_FNAMES(fl)+nfields*(CQ_SZ_QPNAME+1)])) { + call at_stats (at, FOYFORMAT, Memc[str], SZ_FNAME) + if (Memc[str] != EOS && strne (Memc[str], + Memc[FL_FFMTS(fl)+nfields*(CQ_SZ_QPFMTS+1)])) + call strcpy (Memc[str], Memc[FL_FFMTS(fl)+ + nfields*(CQ_SZ_QPFMTS+1)], CQ_SZ_QPFMTS) + } + + # Get the field width. + ip = 2 + if (ctoi (Memc[FL_FFMTS(fl)+nfields*(CQ_SZ_QPFMTS+1)], ip, + ival) <= 0) + ival = 10 + else if (ival <= 0 || IS_INDEFI(ival)) + ival = 10 + + # Get the field offset and field size. Note the extra + # character added to the width ... + switch (rtype) { + case CQ_STEXT: + Memi[FL_FOFFSETS(fl)+nfields] = nfields + 1 + Memi[FL_FSIZES(fl)+nfields] = 0 + case CQ_BTEXT: + Memi[FL_FOFFSETS(fl)+nfields] = foffset + Memi[FL_FSIZES(fl)+nfields] = ival + 1 + foffset = foffset + Memi[FL_FSIZES(fl)+nfields] + default: + call error (0, "Unknown output catalog type") + } + + nfields = nfields + 1 + + } + + rptr = rptr + 3 + } + + call sfree (sp) +end + + +# AT_GETOP -- Fetch an operand from the data structure. + +procedure at_getop (res, operand, o) + +pointer res #I pointer to the data structure +char operand[ARB] #I name of operand to be returned +pointer o #I pointer to output operand + +pointer sp, fvalue +int fieldno, nchars +int cq_fnumber(), cq_ftype(), cq_gvald(), cq_gvali(), cq_gvalc() +int cq_rstati() + +begin + fieldno = cq_fnumber (res, operand) + if (fieldno <= 0) + call error (0, "Illegal operand in expression") + + switch (cq_ftype (res, operand)) { + + case TY_CHAR: + call smark (sp) + call salloc (fvalue, SZ_LINE, TY_CHAR) + nchars = cq_gvalc (res, cq_rstati(res, CQRECPTR), operand, + Memc[fvalue], SZ_LINE) + if (nchars <= 0) { + call strcpy ("INDEF", Memc[fvalue], 5) + nchars = 5 + } + O_TYPE(o) = TY_CHAR + O_LEN(o) = nchars + O_FLAGS(o) = O_FREEVAL + call malloc (O_VALP(o), nchars, TY_CHAR) + call strcpy (Memc[fvalue], O_VALC(o), nchars) + call sfree (sp) + + case TY_SHORT, TY_INT, TY_LONG: + O_TYPE(o) = TY_INT + O_LEN(o) = 0 + O_FLAGS(o) = 0 + nchars = cq_gvali (res, cq_rstati (res, CQRECPTR), operand, + O_VALI(o)) + + case TY_REAL, TY_DOUBLE: + O_TYPE(o) = TY_DOUBLE + O_LEN(o) = 0 + O_FLAGS(o) = 0 + nchars = cq_gvald (res, cq_rstati(res, CQRECPTR), operand, + O_VALD(o)) + + default: + call smark (sp) + call salloc (fvalue, SZ_LINE, TY_CHAR) + nchars = cq_gvalc (res, cq_rstati(res, CQRECPTR), operand, + Memc[fvalue], SZ_LINE) + if (nchars <= 0) { + call strcpy ("INDEF", Memc[fvalue], 5) + nchars = 5 + } + O_TYPE(o) = TY_CHAR + O_LEN(o) = nchars + O_FLAGS(o) = O_FREEVAL + call malloc (O_VALP(o), nchars, TY_CHAR) + call strcpy (Memc[fvalue], O_VALC(o), nchars) + call sfree (sp) + } +end diff --git a/noao/astcat/src/agetcat/athedit.x b/noao/astcat/src/agetcat/athedit.x new file mode 100644 index 00000000..73815db0 --- /dev/null +++ b/noao/astcat/src/agetcat/athedit.x @@ -0,0 +1,614 @@ +include "../../lib/astrom.h" +include "../../lib/aimpars.h" +include <pkg/cq.h> + + +# AT_HEDIT -- Add a set of standard keywords to the image header. + +procedure at_hedit (im, res, at, update, verbose) + +pointer im #I the input image descriptor +pointer res #I the image results descriptor +pointer at #I the astrometry package descriptor +bool update #I update the header ? +bool verbose #I verbose mode ? + +begin + if (res != NULL) + call at_dbkey (im, res, update, verbose) + if (at != NULL) + call at_parkey (im, at, update, verbose) +end + + +# AT_DBKEY -- Add a set of standard keywords required by astrometric +# reductions to the image header. New keywords will only be added if +# the keyword name is defined in the in the image survey database and the +# standard keyword does not already exist in the image header, or if the +# keyword has a default value in the image survey database. + +procedure at_dbkey (im, res, update, verbose) + +pointer im #I the input image descriptor +pointer res #I the image results descriptor +bool update #I update the header ? +bool verbose #I verbose mode ? + +pointer sp, kfield, kname, kvalue, kunits +int i, nkey, ktype +int cq_istati(), cq_kinfon(), imaccf(), at_akeyword() +bool streq() + +begin + call smark (sp) + call salloc (kfield, CQ_SZ_QPNAME, TY_CHAR) + call salloc (kname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (kvalue, CQ_SZ_QPVALUE, TY_CHAR) + call salloc (kunits, CQ_SZ_QPUNITS, TY_CHAR) + + # Loop over the keywords. + nkey = cq_istati (res, CQNIMPARS) + do i = 1, nkey { + + # Get the keyword information. + if (cq_kinfon (res, i, Memc[kfield], CQ_SZ_QPNAME, Memc[kname], + CQ_SZ_QPNAME, Memc[kvalue], CQ_SZ_QPVALUE, ktype, Memc[kunits], + CQ_SZ_QPUNITS) != i) + next + + # The keyword names is INDEF. + if (streq (Memc[kname], "INDEF")) { + + # Go to next keyword if the keyword value is also INDEF. + if (streq (Memc[kvalue], "INDEF")) + next + + # Add keyword with its default value if it does not exist. + if (imaccf (im, Memc[kfield]) == NO) { + if (at_akeyword (im, Memc[kfield], Memc[kvalue], ktype, + Memc[kunits], update) == OK) { + #if (update || verbose) { + if (verbose) { + call printf ( + " Adding survey keyword %s = %s to header\n") + call pargstr (Memc[kfield]) + call pargstr (Memc[kvalue]) + } + #} else if (update || verbose) { + } else if (verbose) { + call printf ( + " Error adding survey keyword %s to header\n") + call pargstr (Memc[kfield]) + } + #} else if (update || verbose) { + } else if (verbose) { + call printf ( + " Warning survey keyword %s already exists\n") + call pargstr (Memc[kfield]) + } + + # The keyword name is defined and it exists in the image. + } else if (imaccf (im, Memc[kname]) == YES) { + + # Add the new keyword with the old keyword value to the image + call imgstr (im, Memc[kname], Memc[kvalue], CQ_SZ_QPVALUE) + if (imaccf (im, Memc[kfield]) == NO) { + if (at_akeyword (im, Memc[kfield], Memc[kvalue], ktype, + Memc[kunits], update) == OK) { + #if (update || verbose) { + if (verbose) { + call printf ( + " Adding survey keyword %s = %s to header\n") + call pargstr (Memc[kfield]) + call pargstr (Memc[kvalue]) + } + #} else if (update || verbose) { + } else if (verbose) { + call printf ( + " Error adding survey keyword %s to header\n") + call pargstr (Memc[kfield]) + } + #} else if (update || verbose) { + } else if (verbose) { + call printf ( + " Warning survey keyword %s already exists\n") + call pargstr (Memc[kfield]) + } + + # The keywords names does not exist in the image. + #} else if (update || verbose) { + } else if (verbose) { + + call printf ( + " Warning survey keyword %s value %s does not exist\n") + call pargstr (Memc[kfield]) + call pargstr (Memc[kname]) + } + } + + call sfree (sp) +end + + +# AT_PARKEY -- Add a set of standard keywords required by astrometric +# reductions to the image header. New keywords will only be added if +# the keyword name is defined in default AIMPARS parameter file and the +# standard keyword does not already exist in the image header, or if the +# keyword has a default value in the AIMPARS parameter file. + +procedure at_parkey (im, at, update, verbose) + +pointer im #I the input image descriptor +pointer at #I the astrometry package descriptor +bool update #I update the header ? +bool verbose #I verbose mode ? + +double dval +real rval +pointer imst, sym, sp, kfield, kvalue +int i, key +double at_statd(), imgetd() +real at_statr(), imgetr() +pointer at_statp(), stfind() +int at_wrdstr(), imaccf() +bool streq() +errchk imgetd(), imgetr(), imgstr() + +begin + if (at_statp (at, PIMPARS) == NULL) + return + imst = at_statp (at, IMST) + if (imst == NULL) + return + + call smark (sp) + call salloc (kfield, SZ_FNAME, TY_CHAR) + call salloc (kvalue, SZ_FNAME, TY_CHAR) + + # Loop over the keywords. + do i = 1, AT_NIMFIELDS { + + # Get the parameter name. + key = at_wrdstr (i, Memc[kfield], SZ_FNAME, AT_IMFIELDS) + switch (key) { + case HDR_OBSERVAT: + sym = stfind (imst, Memc[kfield]) + if (sym != NULL) { + if (streq (AT_IMSTKVAL(sym), "INDEF")) + call at_stats (at, OBSERVAT, Memc[kvalue], SZ_FNAME) + else iferr (call imgstr (im, AT_IMSTKVAL(sym), + Memc[kvalue], SZ_FNAME)) + call at_stats (at, OBSERVAT, Memc[kvalue], SZ_FNAME) + } else + call at_stats (at, OBSERVAT, Memc[kvalue], SZ_FNAME) + + if (! streq (Memc[kvalue], "INDEF")) { + if (imaccf (im, Memc[kfield]) == YES) { + #if (update || verbose) { + if (verbose) { + call printf (" Keyword %s already exists\n") + call pargstr (Memc[kfield]) + } + } else { + if (update) + call imastr (im, Memc[kfield], Memc[kvalue]) + if (verbose) { + call printf ( + " Adding default keyword %s = %s to header\n") + call pargstr (Memc[kfield]) + call pargstr (Memc[kvalue]) + } + } + } + + case HDR_ESITELNG: + sym = stfind (imst, Memc[kfield]) + if (sym != NULL) { + if (streq (AT_IMSTKVAL(sym), "INDEF")) + dval = at_statd (at, ESITELNG) + else iferr (dval = imgetd (im, AT_IMSTKVAL(sym))) + dval = at_statd (at, ESITELNG) + } else + dval = at_statd (at, ESITELNG) + if (! IS_INDEFD(dval)) { + if (imaccf (im, Memc[kfield]) == YES) { + #if (update || verbose) { + if (verbose) { + call printf (" Keyword %s already exists\n") + call pargstr (Memc[kfield]) + } + } else { + if (update) + call imaddd (im, Memc[kfield], dval) + #if (update || verbose) { + if (verbose) { + call printf ( + " Adding default keyword %s = %h to header\n") + call pargstr (Memc[kfield]) + call pargd (dval) + } + } + } + + case HDR_ESITELAT: + sym = stfind (imst, Memc[kfield]) + if (sym != NULL) { + if (streq (AT_IMSTKVAL(sym), "INDEF")) + dval = at_statd (at, ESITELAT) + else iferr (dval = imgetd (im, AT_IMSTKVAL(sym))) + dval = at_statd (at, ESITELAT) + } else + dval = at_statd (at, ESITELAT) + if (! IS_INDEFD(dval)) { + if (imaccf (im, Memc[kfield]) == YES) { + #if (update || verbose) { + if (verbose) { + call printf (" Keyword %s already exists\n") + call pargstr (Memc[kfield]) + } + } else { + if (update) + call imaddd (im, Memc[kfield], dval) + #if (update || verbose) { + if (verbose) { + call printf ( + " Adding default keyword %s = %h to header\n") + call pargstr (Memc[kfield]) + call pargd (dval) + } + } + } + + case HDR_ESITEALT: + sym = stfind (imst, Memc[kfield]) + if (sym != NULL) { + if (streq (AT_IMSTKVAL(sym), "INDEF")) + rval = at_statr (at, ESITEALT) + else iferr (rval = imgetr (im, AT_IMSTKVAL(sym))) + rval = at_statr (at, ESITEALT) + } else + rval = at_statr (at, ESITEALT) + if (! IS_INDEFR(rval)) { + if (imaccf (im, Memc[kfield]) == YES) { + #if (update || verbose) { + if (verbose) { + call printf (" Keyword %s already exists\n") + call pargstr (Memc[kfield]) + } + } else { + if (update) + call imaddr (im, Memc[kfield], rval) + #if (update || verbose) { + if (verbose) { + call printf ( + " Adding default keyword %s = %0.1f to header\n") + call pargstr (Memc[kfield]) + call pargr (rval) + } + } + } + + case HDR_ESITETZ: + sym = stfind (imst, Memc[kfield]) + if (sym != NULL) { + if (streq (AT_IMSTKVAL(sym), "INDEF")) + rval = at_statr (at, ESITETZ) + else iferr (rval = imgetr (im, AT_IMSTKVAL(sym))) + rval = at_statr (at, ESITETZ) + } else + rval = at_statr (at, ESITETZ) + if (! IS_INDEFR(rval)) { + if (imaccf (im, Memc[kfield]) == YES) { + #if (update || verbose) { + if (verbose) { + call printf (" Keyword %s already exists\n") + call pargstr (Memc[kfield]) + } + } else { + if (update) + call imaddr (im, Memc[kfield], rval) + if (verbose) { + call printf ( + " Adding default keyword %s = %0.1f to header\n") + call pargstr (Memc[kfield]) + call pargr (rval) + } + } + } + + case HDR_EMJDOBS: + sym = stfind (imst, Memc[kfield]) + if (sym != NULL) { + if (streq (AT_IMSTKVAL(sym), "INDEF")) + dval = at_statd (at, EMJDOBS) + else iferr (dval = imgetd (im, AT_IMSTKVAL(sym))) + dval = at_statd (at, EMJDOBS) + } else + dval = at_statd (at, EMJDOBS) + if (! IS_INDEFD(dval)) { + if (imaccf (im, Memc[kfield]) == YES) { + #if (update || verbose) { + if (verbose) { + call printf (" Keyword %s already exists\n") + call pargstr (Memc[kfield]) + } + } else { + if (update) + call imaddd (im, Memc[kfield], dval) + #if (update || verbose) { + if (verbose) { + call printf ( + " Adding default keyword %s = %0.5f to header\n") + call pargstr (Memc[kfield]) + call pargd (dval) + } + } + } + + case HDR_EDATAMIN: + sym = stfind (imst, Memc[kfield]) + if (sym != NULL) { + if (streq (AT_IMSTKVAL(sym), "INDEF")) + rval = at_statr (at, EDATAMIN) + else iferr (rval = imgetr (im, AT_IMSTKVAL(sym))) + rval = at_statr (at, EDATAMIN) + } else + rval = at_statr (at, EDATAMIN) + if (! IS_INDEFR(rval)) { + if (imaccf (im, Memc[kfield]) == YES) { + #if (update || verbose) { + if (verbose) { + call printf (" Keyword %s already exists\n") + call pargstr (Memc[kfield]) + } + } else { + if (update) + call imaddr (im, Memc[kfield], rval) + #if (update || verbose) { + if (verbose) { + call printf ( + " Adding default keyword %s = %g to header\n") + call pargstr (Memc[kfield]) + call pargr (rval) + } + } + } + + case HDR_EDATAMAX: + sym = stfind (imst, Memc[kfield]) + if (sym != NULL) { + if (streq (AT_IMSTKVAL(sym), "INDEF")) + rval = at_statr (at, EDATAMAX) + else iferr (rval = imgetr (im, AT_IMSTKVAL(sym))) + rval = at_statr (at, EDATAMAX) + } else + rval = at_statr (at, EDATAMAX) + if (! IS_INDEFR(rval)) { + if (imaccf (im, Memc[kfield]) == YES) { + #if (update || verbose) { + if (verbose) { + call printf (" Keyword %s already exists\n") + call pargstr (Memc[kfield]) + } + } else { + if (update) + call imaddr (im, Memc[kfield], rval) + #if (update || verbose) { + if (verbose) { + call printf ( + " Adding default keyword %s = %g to image\n") + call pargstr (Memc[kfield]) + call pargr (rval) + } + } + } + + case HDR_EGAIN: + sym = stfind (imst, Memc[kfield]) + if (sym != NULL) { + if (streq (AT_IMSTKVAL(sym), "INDEF")) + rval = at_statr (at, EGAIN) + else iferr (rval = imgetr (im, AT_IMSTKVAL(sym))) + rval = at_statr (at, EGAIN) + } else + rval = at_statr (at, EGAIN) + if (! IS_INDEFR(rval)) { + if (imaccf (im, Memc[kfield]) == YES) { + #if (update || verbose) { + if (verbose) { + call printf (" Keyword %s already exists\n") + call pargstr (Memc[kfield]) + } + } else { + if (update) + call imaddr (im, Memc[kfield], rval) + #if (update || verbose) { + if (verbose) { + call printf ( + " Adding default keyword %s = %0.1f to image\n") + call pargstr (Memc[kfield]) + call pargr (rval) + } + } + } + + case HDR_ERDNOISE: + sym = stfind (imst, Memc[kfield]) + if (sym != NULL) { + if (streq (AT_IMSTKVAL(sym), "INDEF")) + rval = at_statr (at, ERDNOISE) + else iferr (rval = imgetr (im, AT_IMSTKVAL(sym))) + rval = at_statr (at, ERDNOISE) + } else + rval = at_statr (at, ERDNOISE) + if (! IS_INDEFR(rval)) { + if (imaccf (im, Memc[kfield]) == YES) { + #if (update || verbose) { + if (verbose) { + call printf (" Keyword %s already exists\n") + call pargstr (Memc[kfield]) + } + } else { + if (update) + call imaddr (im, Memc[kfield], rval) + #if (update || verbose) { + if (verbose) { + call printf ( + " Adding default keyword %s = %0.1f to image\n") + call pargstr (Memc[kfield]) + call pargr (rval) + } + } + } + + case HDR_EWAVLEN: + sym = stfind (imst, Memc[kfield]) + if (sym != NULL) { + if (streq (AT_IMSTKVAL(sym), "INDEF")) + rval = at_statr (at, EWAVLEN) + else iferr (rval = imgetr (im, AT_IMSTKVAL(sym))) + rval = at_statr (at, EWAVLEN) + } else + rval = at_statr (at, EWAVLEN) + if (! IS_INDEFR(rval)) { + if (imaccf (im, Memc[kfield]) == YES) { + #if (update || verbose) { + if (verbose) { + call printf (" Keyword %s already exists\n") + call pargstr (Memc[kfield]) + } + } else { + if (update) + call imaddr (im, Memc[kfield], rval) + #if (update || verbose) { + if (verbose) { + call printf ( + " Adding default keyword %s = %0.1f to header\n") + call pargstr (Memc[kfield]) + call pargr (rval) + } + } + } + + case HDR_ETEMP: + sym = stfind (imst, Memc[kfield]) + if (sym != NULL) { + if (streq (AT_IMSTKVAL(sym), "INDEF")) + rval = at_statr (at, ETEMP) + else iferr (rval = imgetr (im, AT_IMSTKVAL(sym))) + rval = at_statr (at, ETEMP) + } else + rval = at_statr (at, ETEMP) + if (! IS_INDEFR(rval)) { + if (imaccf (im, Memc[kfield]) == YES) { + #if (update || verbose) { + if (verbose) { + call printf (" Keyword %s already exists\n") + call pargstr (Memc[kfield]) + } + } else { + if (update) + call imaddr (im, Memc[kfield], rval) + #if (update || verbose) { + if (verbose) { + call printf ( + " Adding default keyword %s to image header\n") + call pargstr (Memc[kfield]) + call pargr (rval) + } + } + } + + case HDR_EPRESS: + sym = stfind (imst, Memc[kfield]) + if (sym != NULL) { + if (streq (AT_IMSTKVAL(sym), "INDEF")) + rval = at_statr (at, EPRESS) + else iferr (rval = imgetr (im, AT_IMSTKVAL(sym))) + rval = at_statr (at, EPRESS) + } else + rval = at_statr (at, EPRESS) + if (! IS_INDEFR(rval)) { + if (imaccf (im, Memc[kfield]) == YES) { + #if (update || verbose) { + if (verbose) { + call printf (" Keyword %s already exists\n") + call pargstr (Memc[kfield]) + } + } else { + if (update) + call imaddr (im, Memc[kfield], rval) + #if (update || verbose) { + if (verbose) { + call printf ( + " Adding default keyword %s = %g to header\n") + call pargstr (Memc[kfield]) + call pargr (rval) + } + } + } + + default: + ; + } + } + + call sfree (sp) +end + + +# AT_AKEYWORD -- Add a new keyword to the image header. Note that at present +# nothing is done with the units information although this may be used in the +# future. + +int procedure at_akeyword (im, kname, kvalue, ktype, kunits, update) + +pointer im #I the image descriptor +char kname[ARB] #I the image keyword name +char kvalue[ARB] #I the image keyword value +int ktype #I the image keyword data type +char kunits[ARB] #I the image keyword units (not used) +bool update #I actually update the header ? + +double dval +real rval +long lval +int ip, stat +int ctod(), ctor(), ctol() + +begin + stat = OK + + switch (ktype) { + + case TY_DOUBLE: + ip = 1 + if (ctod (kvalue, ip, dval) > 0) { + if (update) + call imaddd (im, kname, dval) + } else + stat = ERR + + case TY_REAL: + ip = 1 + if (ctor (kvalue, ip, rval) > 0) { + if (update) + call imaddr (im, kname, rval) + } else + stat = ERR + + case TY_LONG, TY_INT, TY_SHORT: + ip = 1 + if (ctol (kvalue, ip, lval) > 0) { + if (update) + call imaddl (im, kname, lval) + } else + stat = ERR + + default: + if (update) + call imastr (im, kname, kvalue) + } + + return (stat) +end diff --git a/noao/astcat/src/agetcat/atincat.x b/noao/astcat/src/agetcat/atincat.x new file mode 100644 index 00000000..1d0ce61e --- /dev/null +++ b/noao/astcat/src/agetcat/atincat.x @@ -0,0 +1,70 @@ +# AT_GAPARS -- Read in the algorithm parameters for the AGETCAT task. + +procedure at_gapars (at) + +pointer at #I the pointer to the main astrom structure + +begin + # Initialize the region parameters. + call at_grcpset ("aregpars", at) + + # Initialize the catalog filter / selection parameters. + call at_gfspset ("afiltpars", at) +end + + +# AT_FAPARS -- Read in the algorithm parameters for the AFILTCAT task. + +procedure at_fapars (at) + +pointer at #I the pointer to the main astrom structure + +begin + # Initialize the catalog filter / selection parameters. + call at_gfspset ("afiltpars", at) +end + + +# AT_GIAPARS -- Read in the algorithm parameters for the AGETIM task. + +procedure at_giapars (at) + +pointer at #I the pointer to the main astrom structure + +begin + # Initialize the region parameters. + call at_grcpset ("aregpars", at) + + # Initialize the default wcs parameters. + #call at_gwcpset ("awcspars", at) + + # Initialize the default image data parameters. + #call at_gimpset ("aimpars", at) +end + + +# AT_HAPARS -- Read in the algorithm parameters for the AHEDIT task. + +procedure at_hapars (at) + +pointer at #I the pointer to the main astrom structure + +begin + # Initialize the default wcs parameters. + call at_gwcpset ("awcspars", at) + + # Initialize the default image data parameters. + call at_gimpset ("aimpars", at) +end + + +# AT_IAPARS -- Read in the algorithm parameters for the AIMFIND task. + +procedure at_iapars (at) + +pointer at #I the pointer to the main astrom structure + +begin + # Initialize the catalog filter / selection parameters. + call at_gfspset ("afiltpars", at) +end diff --git a/noao/astcat/src/agetcat/atoutcat.x b/noao/astcat/src/agetcat/atoutcat.x new file mode 100644 index 00000000..a3215003 --- /dev/null +++ b/noao/astcat/src/agetcat/atoutcat.x @@ -0,0 +1,72 @@ + + +# AT_GPPARS -- Update the AGETCAT task algorithm parameter sets. + +procedure at_gppars (at) + +pointer at #I the pointer to the main astrom structure + +begin + # Update the region definition parameters. + call at_prcpset ("aregpars", at) + + # Update the catalog filtering parameters. + call at_pfspset ("afiltpars", at) +end + + +# AT_FPPARS -- Update the AFILTCAT task algorithm parameter sets. + +procedure at_fppars (at) + +pointer at #I the pointer to the main astrom structure + +begin + # Update the catalog filtering parameters. + call at_pfspset ("afiltpars", at) +end + + +# AT_GIPPARS -- Update the AGETIM task algorithm parameter sets. + +procedure at_gippars (at) + +pointer at #I the pointer to the main astrom structure + +begin + # Update the region definition parameters. + call at_prcpset ("aregpars", at) + + # Update the default wcs parameters. + #call at_pwcpset ("awcspars", at) + + # Update the default image data parameters. + #call at_pimpset ("aimpars", at) +end + + +# AT_HPPARS -- Update the AHEDIT task algorithm parameter sets. + +procedure at_hppars (at) + +pointer at #I the pointer to the main astrom structure + +begin + # Update the default wcs parameters. + call at_pwcpset ("awcspars", at) + + # Update the default image data parameters. + call at_pimpset ("aimpars", at) +end + + +# AT_IPPARS -- Update the AIMFIND task algorithm parameter sets. + +procedure at_ippars (at) + +pointer at #I the pointer to the main astrom structure + +begin + # Update the catalog filtering parameters. + call at_pfspset ("afiltpars", at) +end diff --git a/noao/astcat/src/agetcat/atrcquery.x b/noao/astcat/src/agetcat/atrcquery.x new file mode 100644 index 00000000..393f7b4c --- /dev/null +++ b/noao/astcat/src/agetcat/atrcquery.x @@ -0,0 +1,522 @@ +include <math.h> +include <pkg/cq.h> +include <pkg/skywcs.h> +include "../../lib/astrom.h" +include "../../lib/acatalog.h" + +# AT_RCQUERY -- Format the catalog query for the specified field using +# field data supplied by the user and stored in a symbol table and query +# information stored in the catalog database. + +int procedure at_rcquery (at, cq, fieldno) + +pointer at #I the astrometry pacakge descriptor +pointer cq #I the database descriptor +int fieldno #I the field number descriptor + +double ra, dec, width +pointer sp, qsystem, fsystem, qpname, qpvalue, qpunits, qpformats, raformats +pointer decformats, symbol, qcoo, fcoo, mw +int i, stat, parno, units, nqpars + +pointer stfind(), at_statp() +int sk_decwcs(), cq_nqpars(), cq_gqparn(), cq_sqpar(), strdic(), at_wrdstr() +int sk_stati() +bool streq() +errchk cq_fgwrd() + +begin + call smark (sp) + + # Allocate space for the coordinate system descriptions. + call salloc (qsystem, SZ_FNAME, TY_CHAR) + call salloc (fsystem, SZ_FNAME, TY_CHAR) + + # Fetch the field center symbol. + call sprintf (Memc[qsystem], SZ_FNAME, "%s%d") + call pargstr (DEF_RCST_ROOTNAME) + call pargi (fieldno) + symbol = stfind (at_statp(at, RCST), Memc[qsystem]) + if (symbol == NULL) { + call sfree (sp) + return (ERR) + } + + # Determine the query coordinate system. If the query coordinate system + # is undefined, set it to the current catalog coordinate system. If + # the catalog system is undefined set it to the global default. + iferr (call cq_fgwrd (cq, "qsystem", Memc[qsystem], SZ_FNAME)) { + iferr (call cq_fgwrd (cq, "csystem", Memc[qsystem], SZ_FNAME)) + call strcpy ("DEF_CATSYSTEM", Memc[qsystem], SZ_FNAME) + } + if (Memc[qsystem] == EOS || streq (Memc[qsystem], "INDEF")) + call strcpy ("DEF_CATSYSTEM", Memc[qsystem], SZ_FNAME) + + # Open the query coordinate system data structure. + stat = sk_decwcs (Memc[qsystem], mw, qcoo, NULL) + if (stat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + call sk_close (qcoo) + call sfree (sp) + return (ERR) + } + + # Determine the field center coordinate system. If the field center + # coordinate system is undefined, set it to the query coordinate + # system. + if (AT_RCSTSYSTEM(symbol) == EOS || streq (AT_RCSTSYSTEM(symbol), + "INDEF")) + call strcpy (Memc[qsystem], Memc[fsystem], SZ_FNAME) + else + call strcpy (AT_RCSTSYSTEM(symbol), Memc[fsystem], SZ_FNAME) + + # Open the field center coordinate system data structure. + stat = sk_decwcs (Memc[fsystem], mw, fcoo, NULL) + if (stat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + call sk_close (fcoo) + call sk_close (qcoo) + call sfree (sp) + return (ERR) + } + + # Allocate space for the query parameter description. + call salloc (qpname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (qpvalue, CQ_SZ_QPVALUE, TY_CHAR) + call salloc (qpunits, CQ_SZ_QPUNITS, TY_CHAR) + call salloc (qpformats, CQ_SZ_QPFMTS, TY_CHAR) + call salloc (raformats, CQ_SZ_QPFMTS, TY_CHAR) + call salloc (decformats, CQ_SZ_QPFMTS, TY_CHAR) + + # Loop through the query parameter list encoding the non-coordinate + # system parameters. + nqpars = cq_nqpars (cq) + do i = 1, nqpars { + + # Get the query parameter description. + if (cq_gqparn (cq, i, Memc[qpname], CQ_SZ_QPNAME, Memc[qpvalue], + CQ_SZ_QPVALUE, Memc[qpunits], CQ_SZ_QPUNITS, Memc[qpformats], + CQ_SZ_QPFMTS) != i) + next + + parno = strdic (Memc[qpname], Memc[qpname], CQ_SZ_QPNAME, + AT_QRCFIELDS) + if (parno <= 0) + next + + # Field center right ascension. Set the units and save the format + # for later use since we cannot perform the coordinate + # transformation until both ra and dec units are decoded. + switch (parno) { + case AT_QRCRA: + units = strdic (Memc[qpunits], Memc[qpunits], CQ_SZ_QPUNITS, + SKY_LNG_UNITLIST) + if (units > 0) + call sk_seti (qcoo, S_NLNGUNITS, units) + switch (AT_RCSTRAUNITS(symbol)) { + case AT_DEGREES: + units = SKY_DEGREES + case AT_RADIANS: + units = SKY_RADIANS + case AT_HOURS: + units = SKY_HOURS + default: + units = sk_stati (fcoo, S_NLNGUNITS) + } + call sk_seti (fcoo, S_NLNGUNITS, units) + + call strcpy (Memc[qpformats], Memc[raformats], CQ_SZ_QPFMTS) + + # Field center declination. Set the units and save the format + # for later use since we cannot perform the coordinate + # transformation until both ra and dec units are decoded. + case AT_QRCDEC: + units = strdic (Memc[qpunits], Memc[qpunits], CQ_SZ_QPUNITS, + SKY_LAT_UNITLIST) + if (units > 0) + call sk_seti (qcoo, S_NLATUNITS, units) + switch (AT_RCSTDECUNITS(symbol)) { + case AT_DEGREES: + units = SKY_DEGREES + case AT_RADIANS: + units = SKY_RADIANS + default: + units = sk_stati (fcoo, S_NLATUNITS) + } + call sk_seti (fcoo, S_NLATUNITS, units) + + call strcpy (Memc[qpformats], Memc[decformats], CQ_SZ_QPFMTS) + + # Width. Input units are minutes. Output units are minutes or + # degrees. + case AT_QRCWIDTH: + width = max (AT_RCSTRAWIDTH(symbol), AT_RCSTDECWIDTH(symbol)) + if (streq (Memc[qpunits], "degrees")) + width = width / 60.0d0 + call sprintf (Memc[qpvalue], CQ_SZ_QPVALUE, Memc[qpformats]) + call pargd (width) + if (cq_sqpar (cq, Memc[qpname], Memc[qpvalue]) != i) + ; + + # Radius. Input units are minutes. Output units are minutes or + # degrees. + case AT_QRCRADIUS: + width = max (AT_RCSTRAWIDTH(symbol), + AT_RCSTDECWIDTH(symbol)) / 2.0d0 + if (streq (Memc[qpunits], "degrees")) + width = width / 60.0d0 + call sprintf (Memc[qpvalue], CQ_SZ_QPVALUE, Memc[qpformats]) + call pargd (width) + if (cq_sqpar (cq, Memc[qpname], Memc[qpvalue]) != i) + ; + + # Half width. Input units are minutes. Output units are minutes or + # degrees. + case AT_QRCHWIDTH: + width = max (AT_RCSTRAWIDTH(symbol), + AT_RCSTDECWIDTH(symbol)) / 2.0d0 + if (streq (Memc[qpunits], "degrees")) + width = width / 60.0d0 + call sprintf (Memc[qpvalue], CQ_SZ_QPVALUE, Memc[qpformats]) + call pargd (width) + if (cq_sqpar (cq, Memc[qpname], Memc[qpvalue]) != i) + ; + + # Ra width. Input units are minutes. Output units are minutes or + # degrees. + case AT_QRCRAWIDTH: + width = AT_RCSTRAWIDTH(symbol) + if (streq (Memc[qpunits], "degrees")) + width = width / 60.0d0 + call sprintf (Memc[qpvalue], CQ_SZ_QPVALUE, Memc[qpformats]) + call pargd (width) + if (cq_sqpar (cq, Memc[qpname], Memc[qpvalue]) != i) + ; + + # Dec width. Input units are minutes. Output units are minutes or + # degrees. + case AT_QRCDECWIDTH: + width = AT_RCSTDECWIDTH(symbol) + if (streq (Memc[qpunits], "degrees")) + width = width / 60.0d0 + call sprintf (Memc[qpvalue], CQ_SZ_QPVALUE, Memc[qpformats]) + call pargd (width) + if (cq_sqpar (cq, Memc[qpname], Memc[qpvalue]) != i) + ; + + # Ra half width. Input units are minutes. Output units are minutes + # or degrees. + case AT_QRCRAHWIDTH: + width = AT_RCSTRAWIDTH(symbol) / 2.0 + if (streq (Memc[qpunits], "degrees")) + width = width / 60.0d0 + call sprintf (Memc[qpvalue], CQ_SZ_QPVALUE, Memc[qpformats]) + call pargd (width) + if (cq_sqpar (cq, Memc[qpname], Memc[qpvalue]) != i) + ; + + # Dec half width. Input units are minutes. Output units are minutes + # or degrees. + case AT_QRCDECHWIDTH: + width = AT_RCSTDECWIDTH(symbol) / 2.0 + if (streq (Memc[qpunits], "degrees")) + width = width / 60.0d0 + call sprintf (Memc[qpvalue], CQ_SZ_QPVALUE, Memc[qpformats]) + call pargd (width) + if (cq_sqpar (cq, Memc[qpname], Memc[qpvalue]) != i) + ; + + # X width. Input units are minutes. Output units are minutes + # or degrees. + case AT_QRCXWIDTH: + width = AT_RCSTRAWIDTH(symbol) + if (streq (Memc[qpunits], "degrees")) + width = width / 60.0d0 + call sprintf (Memc[qpvalue], CQ_SZ_QPVALUE, Memc[qpformats]) + call pargd (width) + if (cq_sqpar (cq, Memc[qpname], Memc[qpvalue]) != i) + ; + + # Y width. Input units are minutes. Output units are minutes + # or degrees. + case AT_QRCYWIDTH: + width = AT_RCSTDECWIDTH(symbol) + if (streq (Memc[qpunits], "degrees")) + width = width / 60.0d0 + call sprintf (Memc[qpvalue], CQ_SZ_QPVALUE, Memc[qpformats]) + call pargd (width) + if (cq_sqpar (cq, Memc[qpname], Memc[qpvalue]) != i) + ; + + # X half width. Input units are minutes. Output units are minutes + # or degrees. + case AT_QRCXHWIDTH: + width = AT_RCSTRAWIDTH(symbol) / 2.0 + if (streq (Memc[qpunits], "degrees")) + width = width / 60.0d0 + call sprintf (Memc[qpvalue], CQ_SZ_QPVALUE, Memc[qpformats]) + call pargd (width) + if (cq_sqpar (cq, Memc[qpname], Memc[qpvalue]) != i) + ; + + # Y half width. Input units are minutes. Output units are minutes + # or degrees. + case AT_QRCYHWIDTH: + width = AT_RCSTDECWIDTH(symbol) / 2.0 + if (streq (Memc[qpunits], "degrees")) + width = width / 60.0d0 + call sprintf (Memc[qpvalue], CQ_SZ_QPVALUE, Memc[qpformats]) + call pargd (width) + if (cq_sqpar (cq, Memc[qpname], Memc[qpvalue]) != i) + ; + + + } + + } + + # Transform the ra and dec from the field center coordinate system to + # the query coordinate system and reformat the query. + call sk_ultran (fcoo, qcoo, AT_RCSTRA(symbol), AT_RCSTDEC(symbol), ra, + dec, 1) + if (at_wrdstr (AT_QRCRA, Memc[qpname], CQ_SZ_QPNAME, + AT_QRCFIELDS) > 0) { + call sprintf (Memc[qpvalue], CQ_SZ_QPVALUE, Memc[raformats]) + call pargd (ra) + if (cq_sqpar (cq, Memc[qpname], Memc[qpvalue]) == 0) + ; + } + if (at_wrdstr (AT_QRCDEC, Memc[qpname], CQ_SZ_QPNAME, + AT_QRCFIELDS) > 0) { + call sprintf (Memc[qpvalue], CQ_SZ_QPVALUE, Memc[decformats]) + call pargd (dec) + if (cq_sqpar (cq, Memc[qpname], Memc[qpvalue]) == 0) + ; + } + + # Cleanup. + call sk_close (fcoo) + call sk_close (qcoo) + call sfree (sp) + + return (OK) +end + + +# AT_RCREGION -- Determine the region extraction parameters for the specified +# field using field data supplied by the user and stored in a symbol table and +# information stored in the catalog . + +int procedure at_rcregion (at, cres, fieldno, ra, dec, rawidth, decwidth) + +pointer at #I the astrometry pacakge descriptor +pointer cres #I the catalog results descriptor +int fieldno #I the field number descriptor +double ra #O the field center ra in degrees +double dec #O the field center dec in degrees +double rawidth #O the field ra width in degrees +double decwidth #O the field dec width in degrees + +pointer sp, qsystem, fsystem, raname, decname, raunits, decunits +pointer symbol, mw, qcoo, fcoo +int stat, units +pointer stfind(), at_statp() +int sk_decwcs(), cq_hinfo(), strdic(), sk_stati() +bool streq() +errchk at_stats() + +begin + call smark (sp) + + # Allocate space for the coordinate system descriptions. + call salloc (qsystem, SZ_FNAME, TY_CHAR) + call salloc (fsystem, SZ_FNAME, TY_CHAR) + call salloc (raname, CQ_SZ_FNAME, TY_CHAR) + call salloc (decname, CQ_SZ_FNAME, TY_CHAR) + call salloc (raunits, CQ_SZ_FNAME, TY_CHAR) + call salloc (decunits, CQ_SZ_FNAME, TY_CHAR) + + # Fetch the field center symbol. + call sprintf (Memc[qsystem], SZ_FNAME, "%s%d") + call pargstr (DEF_RCST_ROOTNAME) + call pargi (fieldno) + symbol = stfind (at_statp(at, RCST), Memc[qsystem]) + if (symbol == NULL) { + call sfree (sp) + return (ERR) + } + + # Set the query coordinate system to the catalog coordinate system. + # the catalog system is undefined set it to the global default. + if (cq_hinfo (cres, "csystem", Memc[qsystem], SZ_FNAME) <= 0) + Memc[qsystem] = EOS + if (Memc[qsystem] == EOS || streq (Memc[qsystem], "INDEF")) + call strcpy ("DEF_CATSYSTEM", Memc[qsystem], SZ_FNAME) + + # Open the query coordinate system data structure. + stat = sk_decwcs (Memc[qsystem], mw, qcoo, NULL) + if (stat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + call sk_close (qcoo) + call sfree (sp) + return (ERR) + } + + # Determine the field center coordinate system. If the field center + # coordinate system is undefined, set it to the query coordinate + # system. + if (AT_RCSTSYSTEM(symbol) == EOS || streq (AT_RCSTSYSTEM(symbol), + "INDEF")) + call strcpy (Memc[qsystem], Memc[fsystem], SZ_FNAME) + else + call strcpy (AT_RCSTSYSTEM(symbol), Memc[fsystem], SZ_FNAME) + + # Open the field center coordinate system data structure. + stat = sk_decwcs (Memc[fsystem], mw, fcoo, NULL) + if (stat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + call sk_close (fcoo) + call sk_close (qcoo) + call sfree (sp) + return (ERR) + } + + # Get the names of the columns containing ra and dec. + iferr (call at_stats (at, FIRA, Memc[raname], CQ_SZ_FNAME)) + call strcpy ("ra", Memc[raname], SZ_FNAME) + iferr (call at_stats (at, FIDEC, Memc[decname], CQ_SZ_FNAME)) + call strcpy ("dec", Memc[decname], SZ_FNAME) + + # Get the query ra units. + call cq_funits (cres, Memc[raname], Memc[raunits], CQ_SZ_FUNITS) + units = strdic (Memc[raunits], Memc[raunits], CQ_SZ_FUNITS, + SKY_LNG_UNITLIST) + if (units > 0) + call sk_seti (qcoo, S_NLNGUNITS, units) + else + units = sk_stati (qcoo, S_NLNGUNITS) + switch (AT_RCSTRAUNITS(symbol)) { + case AT_DEGREES: + units = SKY_DEGREES + case AT_RADIANS: + units = SKY_RADIANS + case AT_HOURS: + units = SKY_HOURS + default: + ; + } + call sk_seti (fcoo, S_NLNGUNITS, units) + + # Get the query dec units. + call cq_funits (cres, Memc[decname], Memc[decunits], CQ_SZ_FUNITS) + units = strdic (Memc[decunits], Memc[decunits], CQ_SZ_FUNITS, + SKY_LAT_UNITLIST) + if (units > 0) + call sk_seti (qcoo, S_NLATUNITS, units) + else + units = sk_stati (qcoo, S_NLATUNITS) + switch (AT_RCSTDECUNITS(symbol)) { + case AT_DEGREES: + units = SKY_DEGREES + case AT_RADIANS: + units = SKY_RADIANS + case AT_HOURS: + units = SKY_HOURS + default: + ; + } + call sk_seti (fcoo, S_NLATUNITS, units) + + # Transform the ra and dec from the field center coordinate system to + # the query coordinate system and convert the units to degrees. + call sk_ultran (fcoo, qcoo, AT_RCSTRA(symbol), AT_RCSTDEC(symbol), ra, + dec, 1) + + # Transform the ra, dec, and width parameters to degrees. + switch (sk_stati(qcoo, S_NLNGUNITS)) { + case SKY_HOURS: + ra = 15.0d0 * ra + case SKY_DEGREES: + ; + case SKY_RADIANS: + ra = DRADTODEG (ra) + default: + ; + } + switch (sk_stati(qcoo, S_NLATUNITS)) { + case SKY_HOURS: + dec = 15.0d0 * dec + case SKY_DEGREES: + ; + case SKY_RADIANS: + dec = DRADTODEG (dec) + default: + ; + } + rawidth = AT_RCSTRAWIDTH(symbol) / 60.0d0 + decwidth = AT_RCSTDECWIDTH(symbol) / 60.0d0 + + # Cleanup. + call sk_close (fcoo) + call sk_close (qcoo) + call sfree (sp) + + return (OK) +end + + +# AT_RCLIMITS -- Given the ra, dec, ra width, and dec width of the field +# compute the field corners. + +procedure at_rclimits (ra, dec, rawidth, decwidth, ra1, ra2, dec1, dec2) + +double ra #I the field center ra in degrees +double dec #I the field center dec in degrees +double rawidth #I the field ra width in degrees +double decwidth #I the field dec width in degrees +double ra1 #O lower ra limit in degrees +double ra2 #O upper ra limit in degrees +double dec1 #O lower dec limit in degrees +double dec2 #O upper dec limit in degrees + +double cosdec, dra + +begin + # Find the field corners. + dec1 = dec - 0.5d0 * decwidth + dec2 = dec + 0.5d0 * decwidth + if (dec1 <= -90.0d0) { + dec1 = -90.0d0 + dec2 = min (dec + 0.5d0 * decwidth, 90.0d0) + ra1 = 0.0d0 + ra2 = 360.0d0 + return + } else if (dec2 >= 90.0d0) { + dec2 = 90.0d0 + dec1 = max (dec - 0.5d0 * decwidth, -90.0d0) + ra1 = 0.0d0 + ra2 = 360.0d0 + } else { + if (dec > 0.0d0) + cosdec = cos (DEGTORAD(dec2)) + else + cosdec = cos (DEGTORAD(dec1)) + dra = 0.50d0 * rawidth / cosdec + if (dra >= 180.0d0) { + ra1 = 0.0d0 + ra2 = 360.0d0 + } else { + ra1 = ra - dra + if (ra1 < 0.0d0) + ra1 = ra1 + 360.0d0 + ra2 = ra + dra + if (ra2 > 360.0d0) + ra2 = ra2 - 360.0d0 + } + } + +end diff --git a/noao/astcat/src/agetcat/atrcrd.x b/noao/astcat/src/agetcat/atrcrd.x new file mode 100644 index 00000000..7a770c4f --- /dev/null +++ b/noao/astcat/src/agetcat/atrcrd.x @@ -0,0 +1,314 @@ +include <fset.h> +include <imhdr.h> +include <mwset.h> +include <pkg/skywcs.h> +include "../../lib/astrom.h" +include "../../lib/acatalog.h" + +# AT_RCLIST -- Create a list of field centers. + +int procedure at_rclist (at, rcsource) + +pointer at #I the astrometry descriptor +char rcsource[ARB] #I the source of the regions list + +pointer sp, symname, st, sym +int nfields, fd, imlist +double at_statd() +pointer at_statp(), stopen(), stenter() +int at_stati(), access(), open(), imtopen(), at_rcread(), at_rcwcsim() +bool streq() + +begin + # Store the rcsource name in the data structure. + call at_sets (at, RCSOURCE, rcsource) + + # Check that the field center pointer is defined. + if (at_statp (at, PRCENTER) == NULL) + return (0) + + call smark (sp) + call salloc (symname, SZ_FNAME, TY_CHAR) + + # Open the symbol table. + if (at_statp (at, RCST) != NULL) + call stclose (at_statp(at, RCST)) + st = stopen ("fclist", 2 * DEF_LEN_RCST, DEF_LEN_RCST, + 10 * DEF_LEN_RCST) + call at_setp (at, RCST, st) + + # The source is the fcpars parameter set. + if (streq (rcsource, "pars")) { + + if (at_statd (at, RCRA) < 0.0d0 || at_statd(at, RCRA) > 360.0d0) + nfields = 0 + else if (at_statd (at, RCDEC) < -90.0d0 || at_statd(at, RCDEC) > + 90.0d0) + nfields = 0 + else if (at_statd (at, RCRAWIDTH) / 60.0d0 <= 0.0d0 || + at_statd(at, RCRAWIDTH) / 60.0d0 > 360.0d0) + nfields = 0 + else if (at_statd (at, RCDECWIDTH) / 60.0d0 <= 0.0d0 || + at_statd(at, RCDECWIDTH) / 60.0d0 > 180.0d0) + nfields = 0 + else { + call sprintf (Memc[symname], SZ_FNAME, "%s1") + call pargstr (DEF_RCST_ROOTNAME) + sym = stenter (st, Memc[symname], LEN_RCST_STRUCT) + AT_RCSTRA(sym) = at_statd (at, RCRA) + AT_RCSTDEC(sym) = at_statd (at, RCDEC) + AT_RCSTRAWIDTH(sym) = at_statd (at, RCRAWIDTH) + AT_RCSTDECWIDTH(sym) = at_statd (at, RCDECWIDTH) + AT_RCSTRAUNITS(sym) = at_stati (at, RCRAUNITS) + AT_RCSTDECUNITS(sym) = at_stati (at, RCDECUNITS) + call at_stats (at, RCSYSTEM, Memc[symname], SZ_FNAME) + call strcpy (Memc[symname], AT_RCSTSYSTEM(sym), SZ_FNAME) + call strcpy ("pars", AT_RCSTSOURCE(sym), SZ_FNAME) + call strcpy ("", AT_RCSTNAME(sym), SZ_FNAME) + nfields = 1 + } + + # The source is a text file. + } else if (access (rcsource, READ_ONLY, TEXT_FILE) == YES) { + + fd = open (rcsource, READ_ONLY, TEXT_FILE) + nfields = at_rcread (fd, at, st) + call close (fd) + + # The field center source is a list of images. Assume for now that + # images with celestial coordinate systems have a wcs system name + # of "image". This is true of images with a standard FITS wcs and + # for images with a wcs created by the core IRAF tasks. + } else { + imlist = imtopen (rcsource) + nfields = at_rcwcsim (imlist, at, st) + call imtclose (imlist) + } + + call sfree (sp) + + return (nfields) +end + + +# AT_RCREAD -- Read in the field center information from a text file. + +int procedure at_rcread (fd, at, st) + +int fd #I the field center file descriptor +pointer at #I the astrometry descriptor +pointer st #I the field center symbol table descriptor. + +double ra, dec, rawidth, decwidth +pointer sp, symname, sym +int nfields +pointer stenter() +int fscan(), nscan(), at_stati(), strdic() + +begin + call smark (sp) + call salloc (symname, SZ_FNAME, TY_CHAR) + + nfields = 0 + while (fscan(fd) != EOF) { + + # Get the minimum number of fields. + call gargd (ra) + call gargd (dec) + call gargd (rawidth) + call gargd (decwidth) + if (nscan() < 4) + next + if (ra < 0.0d0 || ra > 360.0d0) + next + if (dec < -90.0d0 || dec > 90.0d0) + next + if (rawidth / 60.0d0 <= 0.0d0 || rawidth / 60.0d0 > 360.0d0) + next + if (decwidth / 60.0d0 <= 0.0d0 || decwidth / 60.0d0 > 180.0d0) + next + + # Get the next symbols. + nfields = nfields + 1 + call sprintf (Memc[symname], SZ_FNAME, "%s%d") + call pargstr (DEF_RCST_ROOTNAME) + call pargi (nfields) + sym = stenter (st, Memc[symname], LEN_RCST_STRUCT) + + AT_RCSTRA(sym) = ra + AT_RCSTDEC(sym) = dec + AT_RCSTRAWIDTH(sym) = rawidth + AT_RCSTDECWIDTH(sym) = decwidth + + # Set the source and source name. + call strcpy ("file", AT_RCSTSOURCE(sym), SZ_FNAME) + call fstats (fd, F_FILENAME, Memc[symname], SZ_FNAME) + call strcpy (Memc[symname], AT_RCSTNAME(sym), SZ_FNAME) + + # Decode the units. + call gargwrd (Memc[symname], SZ_FNAME) + if (nscan() < 5) { + AT_RCSTRAUNITS(sym) = at_stati (at, RCRAUNITS) + AT_RCSTDECUNITS(sym) = at_stati (at, RCDECUNITS) + call at_stats (at, RCSYSTEM, Memc[symname], SZ_FNAME) + call strcpy (Memc[symname], AT_RCSTSYSTEM(sym), SZ_FNAME) + next + } else + AT_RCSTRAUNITS(sym) = strdic (Memc[symname], Memc[symname], + SZ_FNAME, AT_RA_UNITS) + call gargwrd (Memc[symname], SZ_FNAME) + if (nscan() < 6) { + AT_RCSTDECUNITS(sym) = at_stati (at, RCDECUNITS) + call at_stats (at, RCSYSTEM, Memc[symname], SZ_FNAME) + call strcpy (Memc[symname], AT_RCSTSYSTEM(sym), SZ_FNAME) + next + } else + AT_RCSTDECUNITS(sym) = strdic (Memc[symname], Memc[symname], + SZ_FNAME, AT_DEC_UNITS) + + # Decode the coordinate system. + call gargstr (Memc[symname], SZ_FNAME) + if (Memc[symname] == EOS || nscan() < 7) { + call at_stats (at, RCSYSTEM, Memc[symname], SZ_FNAME) + call strcpy (Memc[symname], AT_RCSTSYSTEM(sym), SZ_FNAME) + } else + call strcpy (Memc[symname], AT_RCSTSYSTEM(sym), SZ_FNAME) + + } + + call sfree (sp) + + return (nfields) +end + + +# AT_RCWCSIM -- Read in the field center information from a list of images. + +int procedure at_rcwcsim (imlist, at, st) + +int imlist #I the image list descriptor +pointer at #I the astrometry descriptor +pointer st #I the field center symbol table descriptor. + +double ra, dec, width +pointer sp, image, symname, im, mw, coo, sym, ct +int nfields +pointer immap(), mw_sctran(), stenter() +int imtgetim(), sk_decim(), sk_stati() + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (symname, SZ_FNAME, TY_CHAR) + + nfields = 0 + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # The image must be 2D. + im = immap (Memc[image], READ_ONLY, 0) + if (IM_NDIM(im) != 2) { + call imunmap (im) + next + } + + # The image must have a FITS celestial coordinate system. + if (sk_decim (im, "world", mw, coo) == ERR) { + if (mw != NULL) + call mw_close (mw) + call sk_close (coo) + call imunmap (im) + next + } + + # Find the center of the image. + ct = mw_sctran (mw, "logical", "world", 03B) + call mw_c2trand (ct, double((1.0d0 + IM_LEN(im,1)) / 2.0d0), + double((1.0d0 + IM_LEN(im,2)) / 2.0d0), ra, dec) + if (ra < 0.0d0 || ra > 360.0d0) + next + if (dec < -90.0d0 || dec > 90.0d0) + next + + # Find the width of the field. + call at_gfwidth (im, mw, sk_stati(coo, S_PLNGAX), + sk_stati(coo, S_PLATAX), width) + + # Get the next symol. + nfields = nfields + 1 + call sprintf (Memc[symname], SZ_FNAME, "%s%d") + call pargstr (DEF_RCST_ROOTNAME) + call pargi (nfields) + sym = stenter (st, Memc[symname], LEN_RCST_STRUCT) + + AT_RCSTRA(sym) = ra + AT_RCSTDEC(sym) = dec + AT_RCSTRAWIDTH(sym) = width + AT_RCSTDECWIDTH(sym) = width + AT_RCSTRAUNITS(sym) = AT_DEGREES + AT_RCSTDECUNITS(sym) = AT_DEGREES + call sk_enwcs (coo, AT_RCSTSYSTEM(sym), SZ_FNAME) + + call strcpy ("image", AT_RCSTSOURCE(sym), SZ_FNAME) + call strcpy (Memc[image], AT_RCSTNAME(sym), SZ_FNAME) + + # Cleanup. + call sk_close (coo) + call mw_close (mw) + call imunmap (im) + } + + call sfree (sp) + + return (nfields) +end + + +define NEWCD Memd[ncd+(($2)-1)*ndim+($1)-1] + +# AT_GFWIDTH -- Estimate the field width in arcminutes from the size of the +# image and the image wcs. + +procedure at_gfwidth (im, mw, lngax, latax, width) + +pointer im #I the input image desciptor +pointer mw #I the input wcs descriptor +int lngax #I the longitude axis +int latax #I the latitude axis +double width #O the output field width in minutes of arc + +double scale +pointer r, cd, ltm, iltm, ncd +int ndim +int mw_stati() + +begin + # Get the dimension of the wcs. + ndim = mw_stati (mw, MW_NPHYSDIM) + + # Allocate working memory. + call malloc (r, ndim * ndim, TY_DOUBLE) + call malloc (cd, ndim * ndim, TY_DOUBLE) + call malloc (ltm, ndim * ndim, TY_DOUBLE) + call malloc (iltm, ndim * ndim, TY_DOUBLE) + call malloc (ncd, ndim * ndim, TY_DOUBLE) + + # Compute the original world to logical transformation. + call mw_gwtermd (mw, Memd[r], Memd[r], Memd[cd], ndim) + call mw_gltermd (mw, Memd[ltm], Memd[r], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call mwmmuld (Memd[cd], Memd[iltm], Memd[ncd], ndim) + + # Estimate the scale. + scale = max (sqrt (NEWCD(lngax,lngax)**2 + NEWCD(lngax,latax)**2), + sqrt (NEWCD(latax,lngax)**2 + NEWCD(latax,latax)**2)) + + # Compute the width + width = 60.0d0 * scale * max (IM_LEN(im,1), IM_LEN(im,2)) + + # Free the space. + call mfree (r, TY_DOUBLE) + call mfree (cd, TY_DOUBLE) + call mfree (ncd, TY_DOUBLE) + call mfree (ltm, TY_DOUBLE) + call mfree (iltm, TY_DOUBLE) +end diff --git a/noao/astcat/src/agetcat/atrcsym.x b/noao/astcat/src/agetcat/atrcsym.x new file mode 100644 index 00000000..268ea86b --- /dev/null +++ b/noao/astcat/src/agetcat/atrcsym.x @@ -0,0 +1,29 @@ +include "../../lib/astrom.h" + +# AT_RCSYM -- Return the symbol for the specified field nymber. + +pointer procedure at_rcsym (at, fieldno) + +pointer at #I the astrometry package descriptor +int fieldno #I the region whose symbol is to be locate + +pointer sp, symname, st, sym +pointer at_statp(), stfind() + +begin + st = at_statp (at, RCST) + if (st == NULL) + return (NULL) + + call smark (sp) + call salloc (symname, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[symname], SZ_FNAME, "%s%d") + call pargstr (DEF_RCST_ROOTNAME) + call pargi (fieldno) + sym = stfind (st, Memc[symname]) + + call sfree (sp) + + return (sym) +end diff --git a/noao/astcat/src/agetcat/attquery.x b/noao/astcat/src/agetcat/attquery.x new file mode 100644 index 00000000..3f8ff6d4 --- /dev/null +++ b/noao/astcat/src/agetcat/attquery.x @@ -0,0 +1,183 @@ +include <math.h> +include <pkg/cq.h> +include <pkg/skywcs.h> +include "../../lib/astrom.h" + +# AT_TQUERY -- Extract catalog objects from a text file stored in a results +# query structure. + +pointer procedure at_tquery (at, cq, cres, hdrtext, nlines, fieldno) + +pointer at #I the astrometry package descriptor +pointer cq #I the astrometric catalog descriptor +pointer cres #I the input catalog results descriptor +char hdrtext[ARB] #I the catalog header test +int nlines #I the number of lines in the header text +int fieldno #I the region number + +double rac, decc, ra, dec, rawidth, decwidth, ra1, ra2, dec1, dec2, dist +double tra, trac +pointer sp, csystem, raname, decname, funits, tmpname, line +pointer res, ccoo, mw +int i, fd, strfd, stat, units +pointer cq_fquery() +int cq_rstati(), at_rcregion(), open(), strlen(), cq_hinfo(), sk_decwcs() +int stropen(), getline(), strdic(), cq_gvald(), cq_grecord(), sk_stati() +bool streq() + +begin + # Return if the input catalog is undefined or contains no records. + if (cres == NULL) + return (NULL) + if (cq_rstati (cres, CQRNRECS) <= 0) + return (NULL) + + # Return if the header is undefined. + if (nlines <= 0 || hdrtext[1] == EOS) + return (NULL) + + # Get the region to be extracted. + if (at_rcregion (at, cres, fieldno, rac, decc, rawidth, + decwidth) == ERR) + return (NULL) + + # Compute the ra and dec limits. + call at_rclimits (rac, decc, rawidth, decwidth, ra1, ra2, dec1, dec2) + + # Get some working space. + call smark (sp) + call salloc (csystem, CQ_SZ_FNAME, TY_CHAR) + call salloc (tmpname, SZ_FNAME, TY_CHAR) + call salloc (raname, CQ_SZ_FNAME, TY_CHAR) + call salloc (decname, CQ_SZ_FNAME, TY_CHAR) + call salloc (funits, CQ_SZ_FUNITS, TY_CHAR) + call salloc (line, SZ_LINE, TY_CHAR) + + # Open the catalog coordinate system. + if (cq_hinfo (cres, "csystem", Memc[csystem], SZ_FNAME) <= 0) + Memc[csystem] = EOS + if (Memc[csystem] == EOS || streq (Memc[csystem], "INDEF")) + call strcpy ("DEF_CATSYSTEM", Memc[csystem], SZ_FNAME) + + # Open the query coordinate system data structure. + stat = sk_decwcs (Memc[csystem], mw, ccoo, NULL) + if (stat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + call sk_close (ccoo) + call sfree (sp) + return (NULL) + } + + # Open the temporary results file. + call mktemp ("res", Memc[tmpname], SZ_FNAME) + fd = open (Memc[tmpname], NEW_FILE, TEXT_FILE) + + # Write the file header to the temporary results file. + strfd = stropen (hdrtext, strlen(hdrtext), READ_ONLY) + call fprintf (fd, "# BEGIN CATALOG HEADER\n") + while (getline (strfd, Memc[line]) != EOF) { + call fprintf (fd, "# %s") + call pargstr (Memc[line]) + } + call fprintf (fd, "# END CATALOG HEADER\n#\n") + call strclose (strfd) + + # Determine the names of the ra and dec columns. + iferr (call at_stats (at, FIRA, Memc[raname], CQ_SZ_FNAME)) + call strcpy ("ra", Memc[raname], CQ_SZ_FNAME) + iferr (call at_stats (at, FIDEC, Memc[decname], CQ_SZ_FNAME)) + call strcpy ("dec", Memc[decname], CQ_SZ_FNAME) + + # Determine the units of the ra and dec keywords. + call cq_funits (cres, Memc[raname], Memc[funits], CQ_SZ_QPUNITS) + units = strdic (Memc[funits], Memc[funits], CQ_SZ_FUNITS, + SKY_LNG_UNITLIST) + if (units > 0) + call sk_seti (ccoo, S_NLNGUNITS, units) + call cq_funits (cres, Memc[decname], Memc[funits], CQ_SZ_QPUNITS) + units = strdic (Memc[funits], Memc[funits], CQ_SZ_FUNITS, + SKY_LAT_UNITLIST) + if (units > 0) + call sk_seti (ccoo, S_NLATUNITS, units) + + # Loop over the catalog records selecting those that match + # the region description. + do i = 1, cq_rstati (cres, CQRNRECS) { + + # Decode the coordinates. + if (cq_gvald (cres, i, Memc[raname], ra) <= 0) + next + if (cq_gvald (cres, i, Memc[decname], dec) <= 0) + next + + # Determine the coordinate units. + switch (sk_stati(ccoo, S_NLNGUNITS)) { + case SKY_HOURS: + ra = 15.0d0 * ra + case SKY_DEGREES: + ; + case SKY_RADIANS: + ra = DRADTODEG(ra) + default: + ; + } + switch (sk_stati(ccoo, S_NLATUNITS)) { + case SKY_HOURS: + dec = 15.0d0 * dec + case SKY_DEGREES: + ; + case SKY_RADIANS: + dec = DRADTODEG(dec) + default: + ; + } + + # Test the limits + if (dec < dec1 || dec > dec2) + next + if (ra1 < ra2) { + if (ra < ra1 || ra > ra2) + next + } else { + if (ra > ra2 && ra < ra1) + next + } + + # 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 (ra1 < ra2) { + dist = abs (ra - rac) + } else { + if (ra > ra1) + tra = ra - 360.0d0 + else + tra = ra + if (rac > ra1) + trac = rac - 360.0d0 + else + trac = rac + dist = abs (tra - trac) + } + if (abs (2.0d0 * dist *cos(DEGTORAD(dec))) > rawidth) + next + + # Record has been selected. + if (cq_grecord (cres, Memc[line], SZ_LINE, i) <= 0) + next + call putline (fd, Memc[line]) + } + + # Close the tmeporary file. + call close (fd) + + # Query the temporary file and then delete it. + res = cq_fquery (cq, Memc[tmpname], hdrtext) + call delete (Memc[tmpname]) + + # Clean up. + call sfree (sp) + + return (res) +end diff --git a/noao/astcat/src/agetcat/atwcat.x b/noao/astcat/src/agetcat/atwcat.x new file mode 100644 index 00000000..01d9ef6b --- /dev/null +++ b/noao/astcat/src/agetcat/atwcat.x @@ -0,0 +1,197 @@ +include <pkg/cq.h> + +# AT_WNOFILRECS -- Write out the catalog header and records without filtering. + +procedure at_wnofilrecs (fd, res, standard) + +int fd #I the output file descriptor +pointer res #I the results descriptor +bool standard #I write a standard catalog header. + +int nlines, nrecs +int at_wcathdr(), at_wcatrecs() + +begin + # Write out the catalog header. + if (standard) + nlines = at_wcathdr (fd, res) + + # Write out the records. + nrecs = at_wcatrecs (fd, res) +end + + +# AT_WCATHDR -- Write out a catalog header. + +int procedure at_wcathdr (fd, res) + +int fd #I the output file descriptor +pointer res #I the results descriptor + +pointer sp, catname, qpnames, qpvalues, qpunits, fname, fvalue, funits, ffmts +int i, nlines, nfields, fsize, foffset, ftype +int at_wrdstr(), cq_rstati(), cq_hinfon(), cq_finfon() +char cq_itype() + +begin + nlines = 0 + + # Allocate working space. + call smark (sp) + call salloc (catname, SZ_FNAME, TY_CHAR) + call salloc (fname, max (CQ_SZ_QPNAME, CQ_SZ_FNAME), TY_CHAR) + call salloc (fvalue, CQ_SZ_QPVALUE, TY_CHAR) + call salloc (funits, max (CQ_SZ_QPUNITS, CQ_SZ_FUNITS), TY_CHAR) + call salloc (ffmts, CQ_SZ_FFMTS, TY_CHAR) + call salloc (qpnames, SZ_LINE, TY_CHAR) + call salloc (qpvalues, SZ_LINE, TY_CHAR) + call salloc (qpunits, SZ_LINE, TY_CHAR) + + # Write the header banner. + call fprintf (fd, "# BEGIN CATALOG HEADER\n") + nlines = nlines + 1 + + # Write the catalog database and id. + call cq_rstats (res, CQRCATDB, Memc[catname], SZ_FNAME) + call fprintf (fd, "# catdb %s\n") + call pargstr (Memc[catname]) + nlines = nlines + 1 + call cq_rstats (res, CQRCATNAME, Memc[catname], SZ_FNAME) + call fprintf (fd, "# catname %s\n") + call pargstr (Memc[catname]) + nlines = nlines + 1 + + # Write out the query parameter names, values, and units used + # to generate the catalog. + call cq_rstats (res, CQRQPNAMES, Memc[qpnames], SZ_LINE) + call cq_rstats (res, CQRQPVALUES, Memc[qpvalues], SZ_LINE) + call cq_rstats (res, CQRQPUNITS, Memc[qpunits], SZ_LINE) + nfields = cq_rstati (res, CQRNQPARS) + call fprintf (fd, "# nquery %d\n") + call pargi (nfields) + nlines = nlines + 1 + do i = 1, nfields { + if (at_wrdstr (i, Memc[fname], CQ_SZ_QPNAME, Memc[qpnames]) != i) + ; + if (at_wrdstr (i, Memc[fvalue], CQ_SZ_QPVALUE, Memc[qpvalues]) != i) + ; + if (at_wrdstr (i, Memc[funits], CQ_SZ_QPUNITS, Memc[qpunits]) != i) + ; + call fprintf (fd, "# %s %s %s\n") + call pargstr (Memc[fname]) + call pargstr (Memc[fvalue]) + call pargstr (Memc[funits]) + nlines = nlines + 1 + } + + # Write out the results format type. + if (at_wrdstr (cq_rstati(res, CQRTYPE), Memc[fvalue], CQ_SZ_QPVALUE, + CQ_RTYPESTR) <= 0) + call strcpy ("stext", Memc[fvalue], CQ_SZ_QPVALUE) + call fprintf (fd, "# type %s\n") + call pargstr (Memc[fvalue]) + nlines = nlines + 1 + + # Write out the header parameters, + nfields = cq_rstati (res, CQNHEADER) + call fprintf (fd, "# nheader %d\n") + call pargi (nfields) + nlines = nlines + 1 + do i = 1, nfields { + if (cq_hinfon (res, i, Memc[fname], CQ_SZ_QPNAME, Memc[fvalue], + CQ_SZ_QPVALUE) != i) + next + call fprintf (fd, "# %s %s\n") + call pargstr (Memc[fname]) + call pargstr (Memc[fvalue]) + nlines = nlines + 1 + } + + # Write out the field parameters. + nfields = cq_rstati (res, CQNFIELDS) + call fprintf (fd, "# nfields %d\n") + call pargi (nfields) + do i = 1, nfields { + if (cq_finfon (res, i, Memc[fname], CQ_SZ_FNAME, foffset, fsize, + ftype, Memc[funits], CQ_SZ_FUNITS, Memc[ffmts], + CQ_SZ_FFMTS) != i) + next + call fprintf (fd, "# %s %d %d %c %s %s\n") + call pargstr (Memc[fname]) + call pargi (foffset) + call pargi (fsize) + call pargc (cq_itype (ftype)) + call pargstr (Memc[funits]) + call pargstr (Memc[ffmts]) + nlines = nlines + 1 + } + + # Write the header trailer. + call fprintf (fd, "# END CATALOG HEADER\n#\n") + nlines = nlines + 1 + + call sfree (sp) + + return (nlines) +end + + +# AT_WCATRECS -- Write out the catalog records without modification, except +# for the builtin trim parameters. + +int procedure at_wcatrecs (fd, res) + +int fd #I the output file descriptor +pointer res #I the results descriptor + +pointer sp, record +int sz_rec, nrec, recptr, nchars +int cq_rstati(), cq_gnrecord() + +begin + # Allocate space for the record. For now SZ_LINE is the default. + if (cq_rstati(res, CQRECSIZE) > 0) + sz_rec = max (SZ_LINE, cq_rstati (res, CQRECSIZE)) + else + sz_rec = SZ_LINE + nrec = cq_rstati (res, CQRNRECS) + + # Allocate working space. + call smark (sp) + call salloc (record, sz_rec, TY_CHAR) + + # For the moment assume that the simple and blocked text file records + # are newline delimited, and that the simple text file fields are + # whitespace delimited. + + # Write the records. + switch (cq_rstati (res, CQRTYPE)) { + + case CQ_STEXT: + recptr = 0 + while (recptr < nrec) { + nchars = cq_gnrecord (res, Memc[record], sz_rec, recptr) + if (nchars == EOF) + break + call fprintf (fd, "%s") + call pargstr (Memc[record]) + } + + case CQ_BTEXT: + recptr = 0 + while (recptr < nrec) { + nchars = cq_gnrecord (res, Memc[record], sz_rec, recptr) + if (nchars == EOF) + break + call fprintf (fd, "%s") + call pargstr (Memc[record]) + } + + default: + ; + } + + call sfree (sp) + + return (recptr) +end diff --git a/noao/astcat/src/agetcat/atwedit.x b/noao/astcat/src/agetcat/atwedit.x new file mode 100644 index 00000000..7678eb35 --- /dev/null +++ b/noao/astcat/src/agetcat/atwedit.x @@ -0,0 +1,83 @@ +include <imhdr.h> +include <pkg/cq.h> + +# Add a valid WCS to the image header if it does not already have one using +# the image WCS status specified by the wcs keyword in the image survey +# database. If the wcs keyord is "fits", the image is assumed to have a +# valid FITS WCS and no new wcs is computed, if it is "dss" the image is assumed +# to have a valid DSS image header which will be transformed to a valid FITS +# WCS if a FITS WCS is not already present, if it is "none" the image is +# assumed to have no valid WCS and the code will attempt to insert one using +# information in the image results structure. An error status is returned +# only if there is no valid wcs code. + +procedure at_wedit (im, res, at, wcstype, update, verbose) + +pointer im #I the input image descriptor +pointer res #I the image query results descriptor +pointer at #I the astrometry package descriptor +int wcstype #I the default wcs type +bool update #I actually update the header ? +bool verbose #I verbose mode ? + +int cq_istati(), at_mkdss(), at_dbwcs(), at_parwcs() + +begin + # Update WCS from database + if (res != NULL) { + + switch (cq_istati (res, CQWCS)) { + + # Image surveys database indicates image already has a FITS WCS. + case CQ_WFITS: + ; + + # Image surveys database indicates image has a DSS WCS. + case CQ_WDSS: + if (at_mkdss (im, update, verbose) == ERR) { + #if (update || verbose) + if (verbose) + call printf ( + " Error converting DSS wcs to FITS wcs\n") + } + + # Image surveys database indicates image has no WCS. If the proper + # information is not in the image survey then default to awcspars. + default: + if (at_dbwcs (im, res, update, verbose) == ERR) { + #if (update || verbose) + if (verbose) + call printf ( + " Error creating FITS wcs using image survey db\n") + } + } + + } else { + + switch (wcstype) { + + # User parameter indicates image already has a FITS WCS. + case CQ_WFITS: + ; + + # User parameter indicates image has a DSS WCS. + case CQ_WDSS: + if (at_mkdss (im, update, verbose) == ERR) { + #if (update || verbose) + if (verbose) + call printf ( + " Error converting DSS wcs to FITS wcs\n") + } + + default: + if (at == NULL) + ; + else if (at_parwcs (im, at, update, verbose) == ERR) { + #if (update || verbose) + if (verbose) + call printf ( + " Error creating FITS wcs using default parameters\n") + } + } + } +end diff --git a/noao/astcat/src/agetcat/mkpkg b/noao/astcat/src/agetcat/mkpkg new file mode 100644 index 00000000..c8b025b5 --- /dev/null +++ b/noao/astcat/src/agetcat/mkpkg @@ -0,0 +1,31 @@ +# AGETCAT task subdirectory + +$checkout libpkg.a ".." +$update libpkg.a +$checkin libpkg.a ".." +$exit + +libpkg.a: + t_aclist.x + t_aslist.x + t_agetcat.x "../../lib/astrom.h" + t_afiltcat.x "../../lib/astrom.h" + t_agetim.x "../../lib/astrom.h" <pkg/cq.h> + t_ahedit.x "../../lib/astrom.h" <pkg/cq.h> + t_aimfind.x "../../lib/astrom.h" <pkg/cq.h> + atrcquery.x <math.h> <pkg/cq.h> <pkg/skywcs.h> \ + "../../lib/astrom.h" "../../lib/acatalog.h" + atrcrd.x <fset.h> <imhdr.h> <mwset.h> <pkg/skywcs.h> \ + "../../lib/astrom.h" "../../lib/acatalog.h" + attquery.x <math.h> <pkg/cq.h> <pkg/skywcs.h> "../../lib/astrom.h" + atwcat.x <pkg/cq.h> + atfcat.x <imhdr.h> <ctotok.h> <evvexpr.h> "../../lib/astrom.h" \ + <ctype.h> "../../lib/acatalog.h" <pkg/cq.h> \ + <pkg/skywcs.h> + athedit.x "../../lib/astrom.h" "../../lib/aimpars.h" <pkg/cq.h> + atwedit.x <imhdr.h> <pkg/cq.h> + atcatinit.x + atincat.x + atoutcat.x + atrcsym.x "../../lib/astrom.h" + ; diff --git a/noao/astcat/src/agetcat/t_aclist.x b/noao/astcat/src/agetcat/t_aclist.x new file mode 100644 index 00000000..4c13e1ed --- /dev/null +++ b/noao/astcat/src/agetcat/t_aclist.x @@ -0,0 +1,112 @@ +# T_ACLIST -- List the supported catalogs. + +procedure t_aclist() + +pointer sp, str1, str2, line, cq +int i, j, catlist, nquery, nheader, nfields +bool verbose +pointer cq_map() +int at_catlist(), fntlenb(), fntrfnb(), cq_setcat(), cq_fgeti(), cq_scan() +bool clgetb() +errchk cq_fgeti() + +begin + # Allocate some working memory. + call smark (sp) + call salloc (str1, SZ_FNAME, TY_CHAR) + call salloc (str2, SZ_FNAME, TY_CHAR) + call salloc (line, SZ_LINE, TY_CHAR) + + # Get the parameters. + call clgstr ("catalogs", Memc[str1], SZ_FNAME) + call clgstr ("catdb", Memc[str2], SZ_FNAME) + verbose = clgetb ("verbose") + + # Get the catalog list. + catlist = at_catlist (Memc[str1], Memc[str2]) + if (fntlenb (catlist) <= 0) { + if (verbose) + call printf ("The catalog list is empty\n") + call fntclsb (catlist) + call sfree (sp) + return + } + + # Open the catalog database. + cq = cq_map (Memc[str2], READ_ONLY) + if (verbose) { + call printf ("\nScanning catalog database %s\n") + call pargstr (Memc[str2]) + } + + # Loop over the catalogs. + if (verbose) + call printf ("Listing the supported catalogs\n") + do i = 1, fntlenb (catlist) { + + # Get the catalog name and set the current catalog. + if (fntrfnb (catlist, i, Memc[str1], SZ_FNAME) == EOF) + break + if (cq_setcat (cq, Memc[str1]) <= 0) { + next + } else { + call printf ("%s\n") + call pargstr (Memc[str1]) + } + + # Do a detailed listing. + if (verbose) { + iferr (nquery = cq_fgeti (cq, "nquery")) + nquery = 0 + call printf ("nquery %d\n") + call pargi (nquery) + if (nquery > 0) { + do j = 1, nquery { + if (cq_scan (cq) == EOF) + break + call gargstr (Memc[line], SZ_LINE) + call printf ("%s\n") + call pargstr (Memc[line]) + } + } + iferr (nheader = cq_fgeti (cq, "nheader")) + nheader = 0 + call printf ("nheader %d\n") + call pargi (nheader) + if (nheader > 0) { + do j = 1, nheader { + if (cq_scan (cq) == EOF) + break + call gargstr (Memc[line], SZ_LINE) + call printf ("%s\n") + call pargstr (Memc[line]) + } + } + iferr (nfields = cq_fgeti (cq, "nfields")) + nfields = 0 + call printf ("nfields %d\n") + call pargi (nfields) + if (nfields > 0) { + do j = 1, nfields { + if (cq_scan (cq) == EOF) + break + call gargstr (Memc[line], SZ_LINE) + call printf ("%s\n") + call pargstr (Memc[line]) + } + } + if (nquery > 0 || nheader > 0 || nfields > 0) + call printf ("\n") + } + } + + + # Close the catalog database. + call cq_unmap (cq) + + # Close the catalog list. + call fntclsb (catlist) + + # Free working memory. + call sfree (sp) +end diff --git a/noao/astcat/src/agetcat/t_afiltcat.x b/noao/astcat/src/agetcat/t_afiltcat.x new file mode 100644 index 00000000..72dfe8b1 --- /dev/null +++ b/noao/astcat/src/agetcat/t_afiltcat.x @@ -0,0 +1,211 @@ +include "../../lib/astrom.h" + +define SZ_HDRTEXT 5 * SZ_LINE + +# T_AFILTCAT -- Filter existing astrometry catalogs. + +procedure t_afiltcat() + +pointer sp, input, output, catdb, catname, infname, outfname, tmpfname, hdrtext +pointer at, cq, res +int icatlist, ocatlist, catno, infd, outfd, nlines +bool standard, filter, update, verbose +pointer cq_map(), cq_fquery() +int fntopnb(), fntlenb(), fntgfnb(), cq_setcat(), open(), at_gcathdr() +int at_pcathdr() +bool streq(), clgetb() +errchk open() + +begin + # Allocate some working space. + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (catdb, SZ_FNAME, TY_CHAR) + call salloc (catname, SZ_FNAME, TY_CHAR) + call salloc (infname, SZ_FNAME, TY_CHAR) + call salloc (outfname, SZ_FNAME, TY_CHAR) + call salloc (tmpfname, SZ_FNAME, TY_CHAR) + call salloc (hdrtext, SZ_HDRTEXT, TY_CHAR) + + # Get the important query parameters. + call clgstr ("input", Memc[input], SZ_FNAME) + call clgstr ("output", Memc[output], SZ_FNAME) + call clgstr ("catdb", Memc[catdb], SZ_FNAME) + call clgstr ("catalogs", Memc[catname], SZ_FNAME) + + standard = clgetb ("standard") + filter = clgetb ("filter") + update = clgetb ("update") + verbose = clgetb ("verbose") + + # Open the input catalog list. + icatlist = fntopnb (Memc[input], NO) + ocatlist = fntopnb (Memc[output], NO) + + # Check that the input and output catalogs are the same size. + if (fntlenb (icatlist) != fntlenb (ocatlist)) { + if (verbose) { + call printf ( + "Input and output file lists lengths are different\n") + call flush (STDOUT) + } + call fntclsb (icatlist) + call fntclsb (ocatlist) + call sfree (sp) + return + } + + # Map the database. + cq = cq_map (Memc[catdb], READ_ONLY) + if (cq == NULL) { + if (verbose) { + call printf ("Cannot open catalog configuration file %s\n") + call pargstr (Memc[catdb]) + call flush (STDOUT) + } + call fntclsb (icatlist) + call fntclsb (ocatlist) + call sfree (sp) + return + } else { + if (verbose) { + call printf ("\nOpening catalog configuration file %s ...\n") + call pargstr (Memc[catdb]) + call flush (STDOUT) + } + } + + # Locate the dummy record, usually called "stext". + catno = cq_setcat (cq, Memc[catname]) + if (catno <= 0) { + if (verbose) { + call printf ("Cannot locate dummy catalog %s\n") + call pargstr (Memc[catname]) + call flush (STDOUT) + } + call cq_unmap (cq) + call fntclsb (icatlist) + call fntclsb (ocatlist) + call sfree (sp) + return + } else { + if (verbose) { + call printf ("Selecting dummy catalog %s\n") + call pargstr (Memc[catname]) + call flush (STDOUT) + } + } + + # Initilize the astrometry data structure. + call at_afinit (at) + + # Initialize the algorithm parameters. + call at_fapars (at) + + # Store the input and output templates. + call at_sets (at, CATALOGS, Memc[catname]) + call at_sets (at, INPUT, Memc[input]) + call at_sets (at, OUTPUT, Memc[output]) + call at_sets (at, CATDB, Memc[catdb]) + call at_sets (at, CATNAME, Memc[catname]) + + # Loop over the input and output files. + while (fntgfnb (icatlist, Memc[infname], SZ_FNAME) != EOF && + fntgfnb (ocatlist, Memc[outfname], SZ_FNAME) != EOF) { + + # Store the input and output catalog names. + call at_sets (at, INFNAME, Memc[infname]) + call at_sets (at, OUTFNAME, Memc[outfname]) + + # Create a temporary name and open the output file. + if (streq (Memc[infname], Memc[outfname])) + call mktemp ("tmp", Memc[tmpfname], SZ_FNAME) + else + call strcpy (Memc[outfname], Memc[tmpfname], SZ_FNAME) + iferr { + outfd = open (Memc[tmpfname], NEW_FILE, TEXT_FILE) + } then { + if (verbose) { + call printf (" Cannot open output file %s\n") + call pargstr (Memc[outfname]) + call flush (STDOUT) + next + } + } + + # Read the input catalog header. + infd = open (Memc[infname], READ_ONLY, TEXT_FILE) + nlines = at_gcathdr (infd, Memc[hdrtext], SZ_HDRTEXT) + call close (infd) + if (nlines <= 0) + nlines = at_pcathdr ("acatpars", Memc[hdrtext], SZ_HDRTEXT) + + # Read in the catalog and make it look like the results + # of a query. + if (nlines > 0) { + res = cq_fquery (cq, Memc[infname], Memc[hdrtext]) + if (res != NULL) { + if (filter) { + if (verbose) { + call printf ( + " Filtering catalog %s to catalog %s\n") + call pargstr (Memc[infname]) + call pargstr (Memc[outfname]) + } + call at_wfilrecs (outfd, at, res, standard) + } else { + if (verbose) { + call printf ( + " Copying catalog %s to catalog %s\n") + call pargstr (Memc[infname]) + call pargstr (Memc[outfname]) + } + call at_wnofilrecs (outfd, res, standard) + } + } else { + if (verbose) { + call printf (" Cannot read catalog %s\n") + call pargstr (Memc[infname]) + call flush (STDOUT) + } + } + } else { + if (verbose) { + call printf (" Cannot decode catalog %s\n") + call pargstr (Memc[infname]) + call flush (STDOUT) + } + res = NULL + } + + # Close the results structure. + if (res != NULL) + call cq_rclose (res) + + # Close the output file. + call close (outfd) + + # Replace the existing file with the temporary one. + if (streq (Memc[infname], Memc[outfname])) { + call delete (Memc[infname]) + call rename (Memc[tmpfname], Memc[infname]) + } + } + + # Free the database. + call cq_unmap (cq) + + # Update the algorithm parameters. + if (update) + call at_fppars (at) + + # Free the astrometry data structure. + call at_affree (at) + + # Free the input catalog list. + call fntclsb (icatlist) + call fntclsb (ocatlist) + + call sfree (sp) +end diff --git a/noao/astcat/src/agetcat/t_agetcat.x b/noao/astcat/src/agetcat/t_agetcat.x new file mode 100644 index 00000000..5f888eef --- /dev/null +++ b/noao/astcat/src/agetcat/t_agetcat.x @@ -0,0 +1,251 @@ +include "../../lib/astrom.h" + +define SZ_HDRTEXT (5 * SZ_LINE) + +procedure t_agetcat() + +pointer sp, output, hdrtext, str1, str2, at, cq, res, cres +int i, j, nfields, catlist, outlist, infd, outfd, nlines +bool standard, filter, update, verbose +pointer cq_map(), cq_query, cq_fquery(), at_tquery() +int at_rclist(), at_ocatlist(), at_catlist(), fntlenb(), cq_setcat() +int fntrfnb(), open(), at_rcquery(), access(), at_gcathdr() +bool clgetb() +errchk open() + +begin + # Allocate some working memory. + call smark (sp) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (str1, SZ_FNAME, TY_CHAR) + call salloc (str2, SZ_FNAME, TY_CHAR) + call salloc (hdrtext, SZ_HDRTEXT, TY_CHAR) + + # Initalize the data structures + call at_aginit (at) + + # Get the iportant query parameters. + call clgstr ("regions", Memc[str1], SZ_FNAME) + call clgstr ("output", Memc[output], SZ_FNAME) + + # Get the mode parameters. + standard = clgetb ("standard") + filter = clgetb ("filter") + update = clgetb ("update") + verbose = clgetb ("verbose") + + # Allocate the astrometry structure and read in the algorithm + # parameters. This must be done before the field centers are + # decoded. + call at_gapars (at) + + # Print the field center parameters. + #call at_rcshow (at) + # Print the filtering parameters. + #call at_fsshow (at) + # Print the wcs parameters. + #call at_wcshow (at) + # Print the image parameters. + #call at_imshow (at) + + # Get the field center list. + nfields = at_rclist (at, Memc[str1]) + if (nfields <= 0) { + if (verbose) + call printf ("The field center list is empty\n") + call at_agfree (at) + call sfree (sp) + return + } + + # Print the field center symbol table. + #call at_stshow (at) + + # Get the catalog list. + call clgstr ("catalogs", Memc[str1], SZ_FNAME) + call clgstr ("catdb", Memc[str2], SZ_FNAME) + catlist = at_catlist (Memc[str1], Memc[str2]) + if (fntlenb (catlist) <= 0) { + if (verbose) + call printf ("The catalog list is empty\n") + call fntclsb (catlist) + call at_agfree (at) + call sfree (sp) + return + } + call at_sets (at, CATALOGS, Memc[str1]) + call at_sets (at, CATDB, Memc[str2]) + + + # Print the i/o parameters. + #call at_ioshow (at) + + # Create the output catalog file list. + outlist = at_ocatlist (at, catlist, Memc[output], "default", "cat", NO) + if (fntlenb (outlist) <= 0) { + if (verbose) + call printf ("The output file list is empty\n") + call fntclsb (outlist) + call fntclsb (catlist) + call at_agfree (at) + call sfree (sp) + return + } + call at_sets (at, OUTPUT, Memc[output]) + + # Open the catalog database. + cq = cq_map (Memc[str2], READ_ONLY) + if (verbose) { + call printf ("\nOpening catalog database %s\n") + call pargstr (Memc[str2]) + } + + # Loop over the catalog list. + do i = 1, fntlenb (catlist) { + + # Get the catalog name and save it. + if (fntrfnb (catlist, i, Memc[str2], SZ_FNAME) == EOF) + break + if (access (Memc[str2], READ_ONLY, TEXT_FILE) == YES) { + if (cq_setcat (cq, "filename@noao") <= 0) { + if (verbose) { + call printf ("Skipping catalog %s\n") + call pargstr (Memc[str2]) + call flush (STDOUT) + } + next + } else { + call at_sets (at, CATNAME, Memc[str2]) + if (verbose) { + call printf ("Selecting catalog %s\n") + call pargstr (Memc[str2]) + call flush (STDOUT) + } + } + } else if (cq_setcat (cq, Memc[str2]) <= 0) { + if (verbose) { + call printf ("Skipping catalog %s\n") + call pargstr (Memc[str2]) + call flush (STDOUT) + } + next + } else { + call at_sets (at, CATNAME, Memc[str2]) + if (verbose) { + call printf ("Selecting catalog %s\n") + call pargstr (Memc[str2]) + call flush (STDOUT) + } + } + + # Loop over the field centers. + do j = 1, nfields { + + # Get the output file name. + if (fntrfnb (outlist, (i - 1) * nfields + j, Memc[str1], + SZ_FNAME) == EOF) + break + call at_sets (at, OUTFNAME, Memc[str1]) + + # Open the output file. + iferr { + outfd = open (Memc[str1], NEW_FILE, TEXT_FILE) + } then { + if (verbose) { + call printf (" Unable to open output file %s\n") + call pargstr (Memc[str1]) + } + break + } + + if (access (Memc[str2], READ_ONLY, TEXT_FILE) == YES) { + + # Read the catalog header. + infd = open (Memc[str2], READ_ONLY, TEXT_FILE) + nlines = at_gcathdr (infd, Memc[hdrtext], SZ_HDRTEXT) + call close (infd) + if (nlines <= 0) { + if (verbose) + call printf (" Unable to read catalog header\n") + break + } + + # Copy the catalog file into the query structure. + cres = cq_fquery (cq, Memc[str2], Memc[hdrtext]) + if (cres == NULL) { + call printf (" Catalog query failed\n") + break + } + + # Extract the requested data. + res = at_tquery (at, cq, cres, Memc[hdrtext], nlines, j) + if (res == NULL) { + if (verbose) + call printf (" Catalog query failed\n") + break + } + + } else { + + # Format the query. + if (at_rcquery (at, cq, j) == ERR) { + if (verbose) + call printf (" Unable to format network query\n") + break + } + + # Query the catalog. + res = cq_query (cq) + if (res == NULL) { + if (verbose) + call printf (" Network query failed\n") + break + } + } + + # Write the output file. + if (filter) { + if (verbose) { + call printf (" Filtering region %d to file %s\n") + call pargi (j) + call pargstr (Memc[str1]) + call flush (STDOUT) + } + call at_wfilrecs (outfd, at, res, standard) + } else { + if (verbose) { + call printf (" Copying region %d to file %s\n") + call pargi (j) + call pargstr (Memc[str1]) + call flush (STDOUT) + } + call at_wnofilrecs (outfd, res, standard) + } + + # Close the output file. + call close (outfd) + + # Close the query structure. + call cq_rclose (res) + + } + + } + + # Close the catalog database. + call cq_unmap (cq) + + # Update the algorithm parameters. + if (update) + call at_gppars (at) + + # Close the catalog and output file lists. + call fntclsb (outlist) + call fntclsb (catlist) + + # Free the astrometry structure. + call at_agfree (at) + + # Free the working memory. + call sfree (sp) +end diff --git a/noao/astcat/src/agetcat/t_agetim.x b/noao/astcat/src/agetcat/t_agetim.x new file mode 100644 index 00000000..687c1229 --- /dev/null +++ b/noao/astcat/src/agetcat/t_agetim.x @@ -0,0 +1,247 @@ +include "../../lib/astrom.h" +include <pkg/cq.h> + +define SZ_IMEXTN 10 + +procedure t_agetim() + +pointer sp, output, extn, str1, str2 +pointer cq, at, im, res +int i, j, index, nfields, svlist, imlist, addext +char period +bool wcsedit, hdredit, update, verbose +pointer cq_map(), immap(), cq_imquery() +int at_rclist(), at_svlist(), at_osvlist(), fntlenb(), cq_setcat() +int at_rcquery(), fntrfnb(), strldx(), imaccess(), imtlen(), imtrgetim() +int open() +bool clgetb(), streq() +data period /'.'/ +errchk open(), immap(), imaccess(), cq_fgstr() + +begin + # Allocate some working memory. + call smark (sp) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (str1, SZ_FNAME, TY_CHAR) + call salloc (str2, SZ_FNAME, TY_CHAR) + call salloc (extn, SZ_IMEXTN, TY_CHAR) + + # Initalize the data structures + call at_aiginit (at) + + # Get the iportant query parameters. + call clgstr ("regions", Memc[str1], SZ_FNAME) + call clgstr ("images", Memc[output], SZ_FNAME) + + # Get the editing parameters. + wcsedit = clgetb ("wcsedit") + hdredit = clgetb ("hdredit") + update = clgetb ("update") + verbose = clgetb ("verbose") + + # Allocate the astrometry structure and read in the algorithm + # parameters. This must be done before the field centers are + # decoded. + call at_giapars (at) + + # Print the field center parameters. + #call at_rcshow (at) + # Print the default wcs parameters. + #call at_wcshow (at) + # Print the default image data parameters. + #call at_imshow (at) + + # Get the field center list. + nfields = at_rclist (at, Memc[str1]) + if (nfields <= 0) { + if (verbose) + call printf ("The field center list is empty\n") + call at_aigfree (at) + call sfree (sp) + return + } + + # Print the field center symbol table. + #call at_stshow (at) + + # Get the surverys list. + call clgstr ("imsurveys", Memc[str1], SZ_FNAME) + call clgstr ("imdb", Memc[str2], SZ_FNAME) + svlist = at_svlist (Memc[str1], Memc[str2]) + if (fntlenb (svlist) <= 0) { + if (verbose) + call printf ("The image surveys list is empty\n") + call at_aigfree (at) + call fntclsb (svlist) + call sfree (sp) + return + } + call at_sets (at, SURVEYS, Memc[str1]) + call at_sets (at, IMDB, Memc[str2]) + + # Print the i/o parameters. + #call at_ioshow (at) + + # Create the output image list. + imlist = at_osvlist (at, svlist, Memc[output], "default", "", NO) + if (imtlen (imlist) <= 0) { + if (verbose) + call printf ("The output images list is empty\n") + call at_aigfree (at) + call imtclose (imlist) + call fntclsb (svlist) + call sfree (sp) + return + } + call at_sets (at, IMAGES, Memc[output]) + + # Open the catalog database. + cq = cq_map (Memc[str2], READ_ONLY) + if (verbose) { + call printf ("\nOpening surveys database %s\n") + call pargstr (Memc[str2]) + } + + # Loop over the catalog list. + do i = 1, fntlenb (svlist) { + + # Get the catalog name and save it. + if (fntrfnb (svlist, i, Memc[str1], SZ_FNAME) == EOF) + break + if (cq_setcat (cq, Memc[str1]) <= 0) { + if (verbose) { + call printf ("Skipping survey %s\n") + call pargstr (Memc[str1]) + call flush (STDOUT) + } + next + } else { + call at_sets (at, SVNAME, Memc[str1]) + if (verbose) { + call printf ("Selecting survey %s\n") + call pargstr (Memc[str1]) + call flush (STDOUT) + } + } + + # Loop over the field centers. + do j = 1, nfields { + + # Get the output file name. + if (imtrgetim (imlist, (i - 1) * nfields + j, Memc[str1], + SZ_FNAME) == EOF) + break + + # If the file is a fits file tack on the user extension. This + # is not the correct way to do this but for the moment it will + # work. Not sure there is a totally clean way to do this since + # we are not going through imio. + + ifnoerr { + call cq_fgstr (cq, "type", Memc[extn], SZ_IMEXTN) + } then { + addext = YES + index = strldx (period, Memc[str1]) + if (index > 0) { + if (streq (Memc[extn], Memc[str1+index])) + addext = NO + else + addext = YES + } + if (addext == YES) { + call strcpy (Memc[str1], Memc[str2], SZ_FNAME) + call strcat (".", Memc[str2], SZ_FNAME) + call strcat (Memc[extn], Memc[str2], SZ_FNAME) + call strcpy (Memc[str2], Memc[str1], SZ_FNAME) + } + } else { + if (verbose) + call printf ( + " Warning the image format is undefined\n") + } + call at_sets (at, IMNAME, Memc[str1]) + + # Can the output file be opened ? + iferr { + im = open (Memc[str1], NEW_FILE, BINARY_FILE) + } then { + if (verbose) { + call printf (" Unable to write output image %s\n") + call pargstr (Memc[str1]) + } + break + } else { + call close (im) + call delete (Memc[str1]) + } + + # Format the query. + if (at_rcquery (at, cq, j) == ERR) { + if (verbose) + call printf (" Unable to format network query\n") + break + } + + # Query the image surveys. + if (verbose) { + call printf ("Getting image %s ...\n") + call pargstr (Memc[str1]) + call flush (STDOUT) + } + res = cq_imquery (cq, Memc[str1]) + if (res == NULL) { + if (verbose) + call printf (" Network query failed\n") + next + } + + # Open the output file. + iferr { + if (imaccess (Memc[str1], READ_WRITE) == YES) { + if (wcsedit || hdredit) { + im = immap (Memc[str1], READ_WRITE, 0) + if (wcsedit) + call at_wedit (im, res, NULL, CQ_WNONE, true, + verbose) + if (hdredit) + call at_hedit (im, res, NULL, true, verbose) + call imunmap (im) + } + } else + im = NULL + } then { + if (verbose) { + call printf ( + " Warning %s is not a valid image\n") + call pargstr (Memc[str1]) + } + im = NULL + } + + if (verbose) + call flush (STDOUT) + + # Close the query structure. + call cq_imclose (res) + + } + + } + + # Close the catalog database. + call cq_unmap (cq) + + # Update the algorithm parameters. + if (update) + call at_gippars (at) + + # Close the file and image lists. + call imtclose (imlist) + call fntclsb (svlist) + + # Free the astrometry structure. + call at_aigfree (at) + + # Free the working memory. + call sfree (sp) +end diff --git a/noao/astcat/src/agetcat/t_ahedit.x b/noao/astcat/src/agetcat/t_ahedit.x new file mode 100644 index 00000000..c75ce3a7 --- /dev/null +++ b/noao/astcat/src/agetcat/t_ahedit.x @@ -0,0 +1,175 @@ +include "../../lib/astrom.h" +include <pkg/cq.h> + +procedure t_ahedit() + +pointer sp, images, str1, str2 +pointer at, cq, res, im +int j, imlist, catno, wcstype +bool hupdate, wcsedit, hdredit, update, verbose +bool clgetb() +pointer cq_map(), cq_fimquery(), immap() +int imtopen(), imtlen(), cq_setcat(), imtrgetim(), imaccess(), strdic() +errchk immap(), imaccess() + +begin + # Allocate some working memory. + call smark (sp) + call salloc (images, SZ_FNAME, TY_CHAR) + call salloc (str1, SZ_FNAME, TY_CHAR) + call salloc (str2, SZ_FNAME, TY_CHAR) + + # Get the iportant query parameters. + call clgstr ("images", Memc[images], SZ_FNAME) + + # Get the editing parameters. + hupdate = clgetb ("hupdate") + wcsedit = clgetb ("wcsedit") + call clgstr ("wcs", Memc[str1], SZ_FNAME) + wcstype = strdic (Memc[str1], Memc[str1], SZ_FNAME, CQ_WTYPESTR) + if (wcstype <= 0) + wcstype = CQ_WNONE + hdredit = clgetb ("hdredit") + update = clgetb ("update") + if (hupdate) + verbose = clgetb ("verbose") + else + verbose = true + + # Open the image list. + imlist = imtopen (Memc[images]) + if (imtlen (imlist) <= 0) { + if (verbose) + call printf ("The input image list is empty\n") + call imtclose (imlist) + call sfree (sp) + return + } + + # Initalize the data structures + call at_ahinit (at) + + # Allocate the astrometry structure and read in the algorithm + # parameters. + call at_hapars (at) + + # Print the default wcs parameters. + #call at_wcshow (at) + # Print the default image data parameters. + #call at_imshow (at) + + # Set the i/o parameters. + call clgstr ("imsurveys", Memc[str1], SZ_FNAME) + call clgstr ("imdb", Memc[str2], SZ_FNAME) + call at_sets (at, IMAGES, Memc[images]) + call at_sets (at, SURVEYS, Memc[str1]) + call at_sets (at, IMDB, Memc[str2]) + + # Print the i/o parameters. + #call at_ioshow (at) + + # Open the catalog database. + cq = cq_map (Memc[str2], READ_ONLY) + if (cq == NULL) { + if (verbose) { + call printf ("\nCannot opening surveys database %s\n") + call pargstr (Memc[str2]) + } + call at_ahfree (at) + call imtclose (imlist) + call sfree (sp) + return + } else if (verbose) { + call printf ("\nOpening surveys database %s\n") + call pargstr (Memc[str2]) + call flush (STDOUT) + } + + # Get the catalog name and save it. + catno = cq_setcat (cq, Memc[str1]) + if (Memc[str1] == EOS) { + catno = ERR + } else if (catno == 0) { + if (verbose) { + call printf ("Cannot locate survey %s\n") + call pargstr (Memc[str1]) + } + } else { + if (verbose) { + call printf ("Selecting survey %s\n") + call pargstr (Memc[str1]) + } + call at_sets (at, CATNAME, Memc[str1]) + } + + # Loop over the field centers. + do j = 1, imtlen (imlist) { + + # Get the output image name. + if (imtrgetim (imlist, j, Memc[str1], SZ_FNAME) == EOF) + break + call at_sets (at, IMNAME, Memc[str1]) + + # Query the image survey to get the header info even though the + # image already exists. + if (verbose) { + call printf ("Getting image %s ...\n") + call pargstr (Memc[str1]) + call flush (STDOUT) + } + if (catno <= 0) + res = NULL + else + res = cq_fimquery (cq, Memc[str1]) + + # Open the output file. + iferr { + if (imaccess (Memc[str1], READ_WRITE) == YES) { + im = immap (Memc[str1], READ_WRITE, 0) + if (wcsedit) { + if (res != NULL) + call at_wedit (im, res, NULL, wcstype, hupdate, + verbose) + else + call at_wedit (im, NULL, at, wcstype, hupdate, + verbose) + } + if (hdredit) { + if (res != NULL) + call at_hedit (im, res, NULL, hupdate, verbose) + else + call at_hedit (im, NULL, at, hupdate, verbose) + } + call imunmap (im) + } else + im = NULL + } then { + if (verbose) { + call printf (" Warning %s is not a valid image name\n") + call pargstr (Memc[str1]) + } + im = NULL + } + + # Close the query structure. + if (res != NULL) + call cq_imclose (res) + + } + + # Close the catalog database. + call cq_unmap (cq) + + # Update the algorithm parameters. + if (update) + call at_hppars (at) + + # Close the image lists. + call imtclose (imlist) + + # Free the astrometry structure. + call at_ahfree (at) + + # Free the working memory. + call sfree (sp) +end diff --git a/noao/astcat/src/agetcat/t_aimfind.x b/noao/astcat/src/agetcat/t_aimfind.x new file mode 100644 index 00000000..58601bef --- /dev/null +++ b/noao/astcat/src/agetcat/t_aimfind.x @@ -0,0 +1,318 @@ +include <pkg/cq.h> +include "../../lib/astrom.h" + +define SZ_HDRTEXT (5 * SZ_LINE) + +procedure t_aimfind() + +pointer sp, images, output, imfile, catalog, catdb, hdrtext, str1 +pointer at, cq, cres, res, sym, im +int i, j, nfields, nout, nlines, catlist, outlist, imfd, infd, outfd +bool standard, filter, append, update, verbose +pointer cq_map(), cq_query(), cq_fquery(), at_tquery(), at_rcsym(), immap() +int at_rclist(), at_catlist(), at_ocatlist(), open(), access() +int fntlenb(), fntrfnb(), cq_setcat(), at_rcquery() +int at_gcathdr(), cq_rstati() +bool clgetb() +errchk open() + +begin + # Allocate some working memory. + call smark (sp) + call salloc (images, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (imfile, SZ_FNAME, TY_CHAR) + call salloc (catalog, SZ_FNAME, TY_CHAR) + call salloc (catdb, SZ_FNAME, TY_CHAR) + call salloc (hdrtext, SZ_HDRTEXT, TY_CHAR) + call salloc (str1, SZ_FNAME, TY_CHAR) + + # Initalize the data structures + call at_aginit (at) + + # Get the iportant query parameters. + call clgstr ("images", Memc[images], SZ_FNAME) + call clgstr ("output", Memc[output], SZ_FNAME) + call clgstr ("imfile", Memc[imfile], SZ_FNAME) + + # Get the mode parameters. + standard = clgetb ("standard") + filter = clgetb ("filter") + append = clgetb ("append") + update = clgetb ("update") + verbose = clgetb ("verbose") + + # Allocate the astrometry structure and read in the algorithm + # parameters. If filtering is turned off then the filtering + # parameters are set to their default values. Probably need to + # make high level wrapper routines for the parameter defaults + # routines at some point. + if (! filter) + call at_dfspset(at) + else + call at_iapars (at) + + # Set the new field values and new field descriptions. At some + # point these may be input from parameters. At present they are + # hardwired. + call at_nflist (at, 2, "xp,yp", "d,d", "pixels,pixels", + "%10.3f,%10.3f", append) + + # Print the field center parameters. + #call at_rcshow (at) + # Print the filtering parameters. + #call at_fsshow (at) + # Print the wcs parameters. + #call at_wcshow (at) + # Print the image parameters. + #call at_imshow (at) + + # Create the region list from the image list. If an image does not + # have a valid fits wcs it will not be included in the valid + # region list. + nfields = at_rclist (at, Memc[images]) + if (nfields <= 0) { + if (verbose) + call printf ("The image list is empty\n") + call at_agfree (at) + call sfree (sp) + return + } + +# # Print the field center symbol table. +# #call at_stshow (at) + + # Get the catalog. The catalog may be a catalog server or an + # astrometry file. + call clgstr ("catalogs", Memc[catalog], SZ_FNAME) + call clgstr ("catdb", Memc[catdb], SZ_FNAME) + catlist = at_catlist (Memc[catalog], Memc[catdb]) + if (fntlenb (catlist) != 1) { + if (verbose) { + if (fntlenb (catlist) <= 0) + call printf ("The catalog is undefined\n") + else + call printf ("More than one catalog is specified\n") + + } + call fntclsb (catlist) + call at_agfree (at) + call sfree (sp) + return + } + call at_sets (at, CATALOGS, Memc[catalog]) + call at_sets (at, CATDB, Memc[catdb]) + + # Open the output image list file. If the output image file name + # is imdefined then no image list file is written. + if (Memc[imfile] == EOS) { + imfd = NULL + } else { + iferr (imfd = open (Memc[imfile], NEW_FILE, TEXT_FILE)) + imfd = NULL + } + +# # Print the i/o parameters. +# #call at_ioshow (at) + + # Create the output astrometry file list. If the output astrometry + # file list is empty no astrometry file is written. + outlist = at_ocatlist (at, catlist, Memc[output], "default", "coo", NO) + call at_sets (at, OUTPUT, Memc[output]) + + # Open the catalog database. + cq = cq_map (Memc[catdb], READ_ONLY) + if (verbose) { + call printf ("\nOpening catalog database %s\n") + call pargstr (Memc[catdb]) + } + + # Loop over the catalog list. + nout = 0 + do i = 1, fntlenb (catlist) { + + # Get the catalog name and save it. + if (fntrfnb (catlist, i, Memc[catalog], SZ_FNAME) == EOF) + break + + # Set the catalog. + if (access (Memc[catalog], READ_ONLY, TEXT_FILE) == YES) { + if (cq_setcat (cq, "filename@noao") <= 0) { + if (verbose) { + call printf ("Skipping catalog %s\n") + call pargstr (Memc[catalog]) + call flush (STDOUT) + } + next + } else { + call at_sets (at, CATNAME, Memc[catalog]) + if (verbose) { + call printf ("Selecting catalog %s\n") + call pargstr (Memc[catalog]) + call flush (STDOUT) + } + } + } else if (cq_setcat (cq, Memc[catalog]) <= 0) { + if (verbose) { + call printf ("Skipping catalog %s\n") + call pargstr (Memc[catalog]) + call flush (STDOUT) + } + next + } else { + call at_sets (at, CATNAME, Memc[catalog]) + if (verbose) { + call printf ("Selecting catalog %s\n") + call pargstr (Memc[catalog]) + call flush (STDOUT) + } + } + + # Loop over the field centers. + do j = 1, nfields { + + # Get the output file name. + if (fntrfnb (outlist, (i - 1) * nfields + j, Memc[str1], + SZ_FNAME) == EOF) + call at_sets (at, OUTFNAME, "") + #break + else + call at_sets (at, OUTFNAME, Memc[str1]) + + # Query the catalog. + if (access (Memc[catalog], READ_ONLY, TEXT_FILE) == YES) { + + # Read the catalog header. + infd = open (Memc[catalog], READ_ONLY, TEXT_FILE) + nlines = at_gcathdr (infd, Memc[hdrtext], SZ_HDRTEXT) + call close (infd) + if (nlines <= 0) { + if (verbose) + call printf (" Unable to read catalog header\n") + break + } + + # Copy the standard star catalog into the query structure. + cres = cq_fquery (cq, Memc[catalog], Memc[hdrtext]) + if (cres == NULL) { + if (verbose) + call printf (" Catalog query failed\n") + break + } + + # Extract the requested data. + res = at_tquery (at, cq, cres, Memc[hdrtext], nlines, j) + if (res == NULL) { + if (verbose) + call printf (" Catalog query failed\n") + break + } + call cq_rclose (cres) + + + } else { + + # Format the network query. + if (at_rcquery (at, cq, j) == ERR) { + if (verbose) + call printf (" Unable to format network query\n") + break + } + + # Query the catalog. + res = cq_query (cq) + if (res == NULL) { + if (verbose) + call printf (" Network query failed\n") + break + } + } + + # Get the region symbol. + sym = at_rcsym (at, j) + + # If at least one object was detected in the image then + # write out the catalog for that image, and add the image + # name to the image file. + if (cq_rstati (res, CQRNRECS) > 0) { + + # Print the number of objects found. + if (verbose) { + call printf ( + " Image %s contains %d catalog objects\n") + call pargstr (AT_RCSTNAME(sym)) + call pargi (cq_rstati(res, CQRNRECS)) + call flush (STDOUT) + } + + # Write the query results to the astrometry file. + outfd = NULL + if (fntlenb (outlist) > 0) { + + # Open the output file. + outfd = open (Memc[str1], NEW_FILE, TEXT_FILE) + if (verbose) { + call printf (" Writing catalog file %s\n") + call pargstr (Memc[str1]) + } + + im = immap (AT_RCSTNAME(sym), READ_ONLY, 0) + call at_wifilrecs (outfd, im, at, res, standard) + call imunmap (im) + + # Close the output file. + call close (outfd) + } + + # Write the image name to the image file. + if (imfd != NULL) { + if (outfd != NULL) { + call fprintf (imfd, "%s %s\n") + call pargstr (AT_RCSTNAME(sym)) + call pargstr (Memc[str1]) + } else { + call fprintf (imfd, "%s\n") + call pargstr (AT_RCSTNAME(sym)) + } + } + + # Count the number of non-empty files + nout = nout + 1 + + } else if (verbose) { + call printf (" Image %s contains no catalog objects\n") + call pargstr (AT_RCSTNAME(sym)) + call flush (STDOUT) + } + + # Close the query structure. + call cq_rclose (res) + + } + + } + + # Close the catalog database. + call cq_unmap (cq) + + # Update the algorithm parameters. + if (update) + call at_ippars (at) + + # Close the catalog and output file lists. + call fntclsb (outlist) + call fntclsb (catlist) + + # Close the image list file. Delete it if it is empty. + if (imfd != NULL) { + call close (imfd) + if (nout <= 0) + call delete (Memc[imfile]) + } + + # Free the astrometry structure. + call at_agfree (at) + + # Free the working memory. + call sfree (sp) +end diff --git a/noao/astcat/src/agetcat/t_aslist.x b/noao/astcat/src/agetcat/t_aslist.x new file mode 100644 index 00000000..19f7a55d --- /dev/null +++ b/noao/astcat/src/agetcat/t_aslist.x @@ -0,0 +1,102 @@ +# T_ASLIST -- List the support image surveys. + +procedure t_aslist() + +pointer sp, str1, str2, line, cq +int i, j, svlist, nwcs, nkeys +bool verbose +pointer cq_map() +int at_svlist(), fntlenb(), fntrfnb(), cq_setcat(), cq_fgeti(), cq_scan() +bool clgetb() +errchk cq_fgstr(), cq_fgeti() + +begin + # Allocate some working memory. + call smark (sp) + call salloc (str1, SZ_FNAME, TY_CHAR) + call salloc (str2, SZ_FNAME, TY_CHAR) + call salloc (line, SZ_LINE, TY_CHAR) + + # Get the parameters. + call clgstr ("imsurveys", Memc[str1], SZ_FNAME) + call clgstr ("imdb", Memc[str2], SZ_FNAME) + verbose = clgetb ("verbose") + + # Get the catalog list. + svlist = at_svlist (Memc[str1], Memc[str2]) + if (fntlenb (svlist) <= 0) { + if (verbose) + call printf ("The image surveys list is empty\n") + call fntclsb (svlist) + call sfree (sp) + return + } + + # Open the catalog database. + cq = cq_map (Memc[str2], READ_ONLY) + if (verbose) { + call printf ("\nScanning image surveys database %s\n") + call pargstr (Memc[str2]) + } + + # Loop over the catalogs. + if (verbose) + call printf ("Listing the supported image surveys\n") + do i = 1, fntlenb (svlist) { + + # Get the catalog name and set the current catalog. + if (fntrfnb (svlist, i, Memc[str1], SZ_FNAME) == EOF) + break + if (cq_setcat (cq, Memc[str1]) <= 0) { + next + } else { + call printf ("%s\n") + call pargstr (Memc[str1]) + } + + # Do a detailed listing. + if (verbose) { + iferr (call cq_fgstr (cq, "wcs", Memc[line], SZ_LINE)) + call strcpy ("none", Memc[line], SZ_LINE) + call printf ("wcs %s\n") + call pargstr (Memc[line]) + iferr (nwcs = cq_fgeti (cq, "nwcs")) + nwcs = 0 + call printf ("nwcs %d\n") + call pargi (nwcs) + if (nwcs > 0) { + do j = 1, nwcs { + if (cq_scan (cq) == EOF) + break + call gargstr (Memc[line], SZ_LINE) + call printf ("%s\n") + call pargstr (Memc[line]) + } + } + iferr (nkeys = cq_fgeti (cq, "nkeys")) + nkeys = 0 + call printf ("nkeys %d\n") + call pargi (nkeys) + if (nkeys > 0) { + do j = 1, nkeys { + if (cq_scan (cq) == EOF) + break + call gargstr (Memc[line], SZ_LINE) + call printf ("%s\n") + call pargstr (Memc[line]) + } + } + if (nwcs > 0 || nkeys > 0) + call printf ("\n") + } + } + + # Close the image surveys database. + call cq_unmap (cq) + + # Close the image surveys list. + call fntclsb (svlist) + + # Free working memory. + call sfree (sp) +end diff --git a/noao/astcat/src/agetim.par b/noao/astcat/src/agetim.par new file mode 100644 index 00000000..4febee1f --- /dev/null +++ b/noao/astcat/src/agetim.par @@ -0,0 +1,29 @@ +# The AGETIM parameter file. + +# The field center parameters. + +regions,s,a,"pars",,,"The regions source (pars,file,images)" +images,s,a,"default",,,"The output image(s)" +aregpars,pset,h,"",,,"The default field center parameters" + +# The image survey parameters. + +imsurveys,s,h,)_.imsurveys,,,"The input image survey(s)" + +# The image editing parameters. + +wcsedit,b,h,no,,,"Add a new FITS wcs to each image ?" +#awcspars,pset,h,,,,The default wcs parameters +hdredit,b,h,no,,,"Standardize the non-wcs image header parameters ?" +#aimpars,pset,h,"",,,The default image header parameters + +# The task mode parameters. + +update,b,h,no,,,"Update algorithm parameters at task termination ?" +verbose,b,h,yes,,,"Print task status messages ?" + +# The task configuration parameters. + +imdb,s,h,)_.imdb,,,"The image survey configuration file" + +mode,s,h,"ql",,, diff --git a/noao/astcat/src/ahedit.par b/noao/astcat/src/ahedit.par new file mode 100644 index 00000000..6538507a --- /dev/null +++ b/noao/astcat/src/ahedit.par @@ -0,0 +1,29 @@ +# The AHEDIT parameter file. + +# The images parameters. + +images,s,a,"",,,"The images to be edited" + +# The image survey parameters. + +imsurveys,s,a,"",,,"The image survey" + +# The image editing parameters. + +hupdate,b,h,yes,,,"Update the header keywords ?" +wcsedit,b,h,no,,,"Add a new FITS wcs to each image ?" +wcs,s,h,"none","|fits|dss|none|",,"The default input image wcs type" +awcspars,pset,h,"",,,"The default wcs parameters" +hdredit,b,h,yes,,,"Standardize the non-wcs image header parameters ?" +aimpars,pset,h,"",,,"The default image header keyword parameters" + +# The task parameters + +update,b,h,no,,,"Update algorithm parameters at task termination ?" +verbose,b,h,yes,,,"Print task status messages ?" + +# The task configuration parameters. + +imdb,s,h,)_.imdb,,,"The image survey configuration file" + +mode,s,h,"ql",,, diff --git a/noao/astcat/src/aimfind.par b/noao/astcat/src/aimfind.par new file mode 100644 index 00000000..089098fe --- /dev/null +++ b/noao/astcat/src/aimfind.par @@ -0,0 +1,29 @@ +# The AIMFIND parameter file. + +# The field center parameters. + +images,s,a,"",,,"The input images" +output,s,a,"default",,,"The output astrometry file(s)" +imfile,s,a,"",,,"The output image list" + +# The astrometric catalog parameters. + +catalogs,s,h,)_.catalogs,,,"The astrometric catalog(s)" + +# The output catalog filtering parameters. + +standard,b,h,yes,,,Output a standard astrometry file ? +filter,b,h,no,,,"Filter the output astrometry file ?" +afiltpars,pset,h,"",,,"The astrometry file filtering parameters" +append,b,h,no,,,"Append the predicted pixel coordinates ?" + +# The task mode parameters + +update,b,h,no,,,"Update algorithm parameters at task termination ?" +verbose,b,h,yes,,,"Print task status messages ?" + +# The task configuration parameters. + +catdb,s,h,)_.catdb,,,"The astrometric catalog configuration file" + +mode,s,h,"ql",,, diff --git a/noao/astcat/src/aimpars.par b/noao/astcat/src/aimpars.par new file mode 100644 index 00000000..63d6c8f7 --- /dev/null +++ b/noao/astcat/src/aimpars.par @@ -0,0 +1,21 @@ +# THE AIMPARS parameter set + +observat,s,h,"OBSERVAT",,,"The observatory site id" +esitelng,s,h,"INDEF",,,"The observatory longitude (degrees)" +esitelat,s,h,"INDEF",,,"The observatory latitude (degrees)" +esitealt,s,h,"INDEF",,,"The observatory altitude (meters)" +esitetz,s,h,"INDEF",,,"The observatory time zone" +emjdobs,s,h,"MJD-OBS",,,"The effective date of the observation" + +#ut,s,h,"UT",,,"The beginning UT of the observation" +#exposure,s,h,"EXPTIME",,,"The exposure time" + +edatamin,s,h,"INDEF",,,"The effective good data minimum (ADU)" +edatamax,s,h,"INDEF",,,"The effective good data maximum (ADU)" +egain,s,h,"GAIN",,,"The effective gain (electrons / ADU)" +erdnoise,s,h,"RDNOISE",,,"The effective readout noise (electrons)" +ewavlen,s,h,"INDEF",,,"The effective wavelength (microns)" +etemp,s,h,"INDEF",,,"The effective ambient temperature (degrees)" +epress,s,h,"INDEF",,,"The effective ambient pressure (mbars)" + +mode,s,h,"ql",,, diff --git a/noao/astcat/src/aobspars.par b/noao/astcat/src/aobspars.par new file mode 100644 index 00000000..b43b39cb --- /dev/null +++ b/noao/astcat/src/aobspars.par @@ -0,0 +1,29 @@ +# THE AOBSPARS parameter set + +# The observing parameters. + +csystem,s,h,"RADECSYS",,,"The image coordinate system" +equinox,s,h,"EQUINOX",,,"The equinox of the reference ra and dec" +epoch,s,h,"DATE-OBS",,,"The epoch of the observation" + +xref,s,h,"INDEF",,,"The x reference pixel" +yref,s,h,"INDEF",,,"The y reference pixel" +xmag,s,h,"SCALE",,,"The x axis image scale in arcseconds per pixel" +ymag,s,h,"SCALE",,,"The y axis image scale in arcseconds per pixel" +xrotation,s,h,"0.0",,,"The x axis rotation in degrees" +yrotation,s,h,"0.0",,,"The y axis rotation in degrees" +raref,s,h,"RA",,,"The ra of the image reference point in hours" +decref,s,h,"DEC",,,"The dec of the image reference point in degrees" +projection,s,h,"tan",,,"The image projection geometry" +raaxis,i,h,1,,,"The image ra axis" +decaxis,i,h,2,,,"The image dec axis" + +gain,s,h,"GAIN",,,"The image gain" +rdnoise,s,h,"RDNOISE",,,"The image readout noise" + +observatory,s,h,"OBSERVAT",,,"The site of the observation" +temperature,s,h,"INDEF",,,"The ambient temperature during observation" +pressure,s,h,"INDEF",,,"The ambient pressure during the observation" +elambda,s,h,"INDEF",,,"The effective wavelength of the bandpass" + +mode,s,h,"ql",,, diff --git a/noao/astcat/src/aocatpars.par b/noao/astcat/src/aocatpars.par new file mode 100644 index 00000000..2c8146f3 --- /dev/null +++ b/noao/astcat/src/aocatpars.par @@ -0,0 +1,37 @@ +# The AOCATPARS parameter file + +# The standard output catalog format parameter set. + +# Global parameters + +ocatsystem,s,h,"J2000",,,The output catalog celestial coordinate system + +# Standard column / field definitions + +oid,s,h,"",,,"The id field" + +ora,s,h,"",,,"The ra / longitude field" +odec,s,h,"",,,"The dec / latitude field" +oera,s,h,"",,,"The ra / longitude error field" +oedec,s,h,"",,,"The dec / latitude error field" + +opmra,s,h,"",,,"The ra / longitude proper motion field" +opmdec,s,h,"",,,"The dec / latitude proper motion field" +oepmra,s,h,"",,,"The ra / longitude proper motion error field" +oepmdec,s,h,"",,,"The dec / latitude proper motion error field" + +ocoosystem,s,h,"",,,"The celestial coordinate system field" +oequinox,s,h,"",,,"The epoch of the equinox field" +oepoch,s,h,"",,,"The epoch of the observation field" + +opx,s,h,"",,,"The parallax field" +orv,s,h,"",,,"The radial velocity field" +oepx,s,h,"",,,"The parallax error field" +oerv,s,h,"",,,"The radial error velocity field" + +omags,s,h,"",,,"The magnitude field(s)" +ocolors,s,h,"",,,"The color indices field(s)" +oemags,s,h,"",,,"The magnitude error field(s)" +oecolors,s,h,"",,,"The color indices error field(s)" + +# Additions .... diff --git a/noao/astcat/src/aregpars.par b/noao/astcat/src/aregpars.par new file mode 100644 index 00000000..5fa56895 --- /dev/null +++ b/noao/astcat/src/aregpars.par @@ -0,0 +1,9 @@ +# The AREGPARS parameter set file + +rcra,s,h,"00:00:00.0",,,"The region center ra / longitude" +rcdec,s,h,"+00:00:00",,,"The region center dec / latitude" +rrawidth,r,h,10.0,0.0,21600.0,"The ra / longitude region width in minutes" +rdecwidth,r,h,10.0,0.0,10800.0,"The dec / latitude region width in minutes" +rcsystem,s,h,"",,,"The region center celestial coordinate system" +rcraunits,s,h,"",,,"The region center ra / longitude units" +rcdecunits,s,h,"",,,"The region center dec / latitude units" diff --git a/noao/astcat/src/aslist.par b/noao/astcat/src/aslist.par new file mode 100644 index 00000000..136b5d84 --- /dev/null +++ b/noao/astcat/src/aslist.par @@ -0,0 +1,6 @@ +# The ASLIST parameter file. + +imsurveys,s,a,"*",,,"The image surveys(s)" +verbose,b,h,no,,,"Print verbose messages ?" +imdb,s,h,)_.imdb,,,"The image survey configuration file" +mode,s,h,"ql",,, diff --git a/noao/astcat/src/asttest.cl b/noao/astcat/src/asttest.cl new file mode 100644 index 00000000..23292172 --- /dev/null +++ b/noao/astcat/src/asttest.cl @@ -0,0 +1,289 @@ +# ASTTEST - Self testing procedure for the ASTCAT package. + +procedure asttest (rootname) + +string rootname {prompt="Root name of the output test files"} +string astlogfile {"", prompt="Name of the output log file"} + +struct *catlist +struct *svlist + +begin + # Declare local variables. + string troot, tastlog, tcatlist, tcatalog, tcatfile + string tsvlist, tsurvey, timage, ttemp1 + int tfirst, tlast, tindex + + # Check that the user truly wants to proceed. + ttemp1 = "" + print ("") + print ("ASTTEST initializes the ASTCAT task parameters") + print ("Type 'q' or 'Q' to quit, any other key to proceed") + if (scan (ttemp1) != EOF) { + if (ttemp1 == "q" || ttemp1 == "Q") { + print ("Terminating the ASTTEST task") + bye + } + } + print ("") + + # Define the plot file name. + + troot = rootname + tastlog = astlogfile + if (tastlog == "") { + tastlog = troot // ".log" + } + + # Check for the existence of the test files. + + if (access (tastlog)) { + error (0, "Error: The log file already exists on disk") + } + + # Create some temporary files. + + tcatlist = mktemp (troot) + tsvlist = mktemp (troot) + + # Initialize the ASTCAT package. + + print ("Initialize the ASTCAT package", >> tastlog) + print ("", >> tastlog) + print ("") + print ("Initialize the ASTCAT package") + print ("") + + astcat.catalogs = "usno2@noao" + astcat.catdb = "astcat$lib/catdb.dat" + astcat.imsurveys = "dss2@cadc" + astcat.imdb = "astcat$lib/imdb.dat" + + # Unlearning tasks and psets. Ran into a problem with doing + # unlearn on astcat which I will have to work around. + + # unlearn ("astcat") + unlearn ("acatpars") + unlearn ("aclist") + unlearn ("adumpcat") + unlearn ("adumpim") + unlearn ("afiltcat") + unlearn ("afiltpars") + unlearn ("agetcat") + unlearn ("agetim") + unlearn ("ahedit") + unlearn ("aimfind") + unlearn ("aimpars") + unlearn ("aregpars") + unlearn ("aslist") + unlearn ("awcspars") + + # Do the tests. + + # Test the ACLIST task. + + print ("", >> tastlog) + print ("Testing the ACLIST task", >> tastlog) + print ("Testing the ACLIST task") + print ("", >> tastlog) + + aclist ("*", verbose+, catdb=")_.catdb", >> tastlog) + aclist ("*", verbose-, catdb=")_.catdb", > tcatlist) + print ("", >> tastlog) + + # Test the ADUMPCAT task. + + print ("", >> tastlog) + print ("Testing the ADUMPCAT task", >> tastlog) + print ("Testing the ADUMPCAT task") + print ("", >> tastlog) + + catlist = tcatlist + while (fscan (catlist, tcatalog) != EOF) { + print ("", >> tastlog) + print (tcatalog, >> tastlog) + print ("", >> tastlog) + print (" ", tcatalog) + if (tcatalog == "tmass@ipac") { + adumpcat (tcatalog, "STDOUT", ra="00:00:00.0", dec="00:00:00", + size="0.17", catdb=")_.catdb", >> tastlog) + } else { + adumpcat (tcatalog, "STDOUT", ra="00:00:00.0", dec="00:00:00", + size="10.0", catdb=")_.catdb", >> tastlog) + } + print ("", >> tastlog) + } + + # Test the AGETCAT and AFILTCAT tasks. + + print ("", >> tastlog) + print ("Testing the AGETCAT and AFILTCAT tasks", >> tastlog) + print ("Testing the AGETCAT and AFILTCAT tasks") + print ("", >> tastlog) + + catlist = tcatlist + while (fscan (catlist, tcatalog) != EOF) { + print ("", >> tastlog) + print (tcatalog, >> tastlog) + print ("", >> tastlog) + print (" ", tcatalog) + tfirst = 1 + tlast = strlen (tcatalog) + tindex = stridx ("@", tcatalog) + tcatfile = substr (tcatalog, tfirst, tindex - 1) // "." // + substr (tcatalog, tindex + 1, tlast) // ".cat" + if (access (tcatfile)) { + delete (tcatfile, verify-) + } + agetcat ("pars", tcatfile, rcra="00:00:00.00", rcdec="+00:00:00.0", + rrawidth=20.0, rdecwidth=20.0, catalogs=tcatalog, standard+, + filter-, update-, verbose+, catdb=")_.catdb", >> tastlog) + print ("", >> tastlog) + type (tcatfile, map_cc+, device="terminal", >> tastlog) + print ("", >> tastlog) + afiltcat (tcatfile, tcatfile, catalogs="filename@noao", standard+, + filter+, fsort="mag1", update-, verbose+, catdb=")_.catdb", + >> tastlog) + print ("", >> tastlog) + type (tcatfile, map_cc+, device="terminal", >> tastlog) + print ("", >> tastlog) + delete (tcatfile, verify-) + } + + # Test the ASLIST task. + + print ("", >> tastlog) + print ("Testing the ASLIST task", >> tastlog) + print ("Testing the ASLIST task") + print ("", >> tastlog) + + aslist ("*", verbose+, imdb=")_.imdb", >> tastlog) + aslist ("*", verbose-, imdb=")_.imdb", > tsvlist) + print ("", >> tastlog) + + # Test the ADUMPIM task. + + print ("", >> tastlog) + print ("Testing the ADUMPIM task", >> tastlog) + print ("Testing the ADUMPIM task") + print ("", >> tastlog) + + svlist = tsvlist + while (fscan (svlist, tsurvey) != EOF) { + print ("", >> tastlog) + print (tsurvey, >> tastlog) + print ("", >> tastlog) + print (" ", tsurvey) + tfirst = 1 + tlast = strlen (tsurvey) + tindex = stridx ("@", tsurvey) + timage = substr (tsurvey, tfirst, tindex - 1) // "." // + substr (tsurvey, tindex + 1, tlast) // ".fits" + if (imaccess (timage)) { + imdelete (timage, verify-) + } + adumpim (tsurvey, timage, ra="14:28:07.0", dec="+34:55:00", + size="10.0", imdb=")_.imdb", >> tastlog) + printf (" ") + imheader (timage, longheader-, userfields+) + print ("", >> tastlog) + imheader (timage, longheader+, userfields+, >> tastlog) + print ("", >> tastlog) + imdelete (timage, verify-) + } + + # Test the AGETIM and AHEDIT tasks. + + print ("", >> tastlog) + print ("Testing the AGETIM and AHEDIT tasks", >> tastlog) + print ("Testing the AGETIM and AHEDIT tasks") + print ("", >> tastlog) + + svlist = tsvlist + while (fscan (svlist, tsurvey) != EOF) { + print ("", >> tastlog) + print (tsurvey, >> tastlog) + print ("", >> tastlog) + tfirst = 1 + tlast = strlen (tsurvey) + tindex = stridx ("@", tsurvey) + timage = substr (tsurvey, tfirst, tindex - 1) // "." // + substr (tsurvey, tindex + 1, tlast) // ".fits" + if (imaccess (timage)) { + imdelete (timage, verify-) + } + agetim ("pars", timage, rcra="14:28:07.00", rcdec="+34:55:00.0", + rrawidth=10.0, rdecwidth=10.0, imsurveys=tsurvey, wcsedit-, + hdredit-, update-, verbose+, imdb=")_.imdb", >> tastlog) + printf (" ") + imheader (timage, longheader-, userfields+) + print ("", >> tastlog) + imheader (timage, longheader+, userfields+, >> tastlog) + print ("", >> tastlog) + ahedit (timage, tsurvey, hupdate+, wcsedit+, wcs="none", hdredit+, + update-, verbose+, imdb=")_.imdb", >> tastlog) + print ("", >> tastlog) + imheader (timage, longheader+, userfields+, >> tastlog) + #imdelete (timage, verify-) + } + + # Test the AIMFIND task. + + print ("", >> tastlog) + print ("Testing the AIMFIND task", >> tastlog) + print ("Testing the AIMFIND task") + print ("", >> tastlog) + + # Test the aimfind task using the USNO2 survey + + svlist = tsvlist + while (fscan (svlist, tsurvey) != EOF) { + tfirst = 1 + tlast = strlen (tsurvey) + tindex = stridx ("@", tsurvey) + timage = substr (tsurvey, tfirst, tindex - 1) // "." // + substr (tsurvey, tindex + 1, tlast) // ".fits" + tcatfile = substr (tsurvey, tfirst, tindex - 1) // "." // + substr (tsurvey, tindex + 1, tlast) // ".cat" + if (access (tcatfile)) { + delete (tcatfile, verify-) + } + aimfind (timage, tcatfile, imfile="", catalogs="usno2@noao", + standard+, filter-, append-, update-, verbose+, + catdb=")_.catdb", >> tastlog) + } + + # Reinitialize the astcat package. + + # unlearn ("astcat") + unlearn ("acatpars") + unlearn ("aclist") + unlearn ("adumpcat") + unlearn ("adumpim") + unlearn ("afiltcat") + unlearn ("afiltpars") + unlearn ("agetcat") + unlearn ("agetim") + unlearn ("ahedit") + unlearn ("aimfind") + unlearn ("aimpars") + unlearn ("aregpars") + unlearn ("aslist") + unlearn ("awcspars") + + # Delete some temporary files. + + delete (tsvlist, verify-) + delete (tcatlist, verify-) + svlist = "" + catlist = "" + + print ("", >> tastlog) + print ("ASTCAT package tests completed", >> tastlog) + print ("", >> tastlog) + print ("") + print ("ASTCAT package tests completed") + print ("") + + bye +end diff --git a/noao/astcat/src/attools/atalloc.x b/noao/astcat/src/attools/atalloc.x new file mode 100644 index 00000000..7a46c936 --- /dev/null +++ b/noao/astcat/src/attools/atalloc.x @@ -0,0 +1,288 @@ +include "../../lib/astromdef.h" +include "../../lib/astrom.h" +include "../../lib/acatalog.h" +include "../../lib/aimparsdef.h" +include "../../lib/aimpars.h" + + +# AT_AINIT -- Initialize the main astrometry structure. + +procedure at_ainit (at) + +pointer at #I the pointer to the astrometry descriptor + +begin + call calloc (at, LEN_ASTROM, TY_STRUCT) + AT_PIO(at) = NULL + AT_PRCENTER(at) = NULL + AT_PFILTER(at) = NULL +end + + +# AT_AFREE -- Free the main astrometry structure. + +procedure at_afree (at) + +pointer at #I the pointer to the astrometry descriptor + +begin + call mfree (at, TY_STRUCT) +end + + +# AT_RCINIT -- Initialize the field center structure. + +procedure at_rcinit (at) + +pointer at #I the pointer to the astrometry descriptor + +pointer fc + +begin + call calloc (fc, LEN_PRCENTER, TY_STRUCT) + + # Set the default field. + AT_RCRA(fc) = 0.0d0 + AT_RCDEC(fc) = 0.0d0 + AT_RCRAWIDTH(fc) = 1.0d0 + AT_RCDECWIDTH(fc) = 1.0d0 + AT_RCRAUNITS(fc) = AT_HOURS + AT_RCDECUNITS(fc) = AT_DEGREES + call strcpy ("J2000", AT_RCSYSTEM(fc), SZ_FNAME) + call strcpy ("", AT_RCSOURCE(fc), SZ_FNAME) + + # Initialize the internal data structures. + #AT_RCCC(fc) = NULL + AT_RCST(fc) = NULL + + AT_PRCENTER(at) = fc +end + + +# AT_RCFREE -- Free the field center structure. + +procedure at_rcfree (at) + +pointer at #I the pointer to the astrometry descriptor + +pointer fc + +begin + fc = AT_PRCENTER(at) + + # Close the field center symbol table. + if (AT_RCST(fc) != NULL) + call stclose (AT_RCST(fc)) + AT_RCST(fc) = NULL + + # Close the coordinate structure. + #if (AT_RCCC(fc) != NULL) + #call sk_close (AT_RCCC(fc)) + #AT_RCCC(fc) = NULL + + call mfree (AT_PRCENTER(at), TY_STRUCT) + AT_PRCENTER(at) = NULL +end + + +# AT_IOINIT -- Initialize the i/o structure. + +procedure at_ioinit (at) + +pointer at #I the pointer to the i/o descriptor + +pointer io + +begin + call calloc (io, LEN_PIO, TY_STRUCT) + + AT_CATALOGS(io) = EOS + AT_SURVEYS(io) = EOS + AT_IMAGES(io) = EOS + AT_INPUT(io) = EOS + AT_OUTPUT(io) = EOS + AT_CATNAME(io) = EOS + AT_SVNAME(io) = EOS + AT_IMNAME(io) = EOS + AT_INFNAME(io) = EOS + AT_OUTFNAME(io) = EOS + AT_CATDB(io) = EOS + AT_IMDB(io) = EOS + + AT_PIO(at) = io +end + + +# AT_IOFREE -- Free the i/o structure. + +procedure at_iofree (at) + +pointer at #I the pointer to the i/o descriptor + +pointer io + +begin + io = AT_PIO(at) + + call mfree (io, TY_STRUCT) + AT_PIO(at) = NULL +end + + +# AT_FSINIT -- Initialize the filtering / selection structure. + +procedure at_fsinit (at) + +pointer at #I the pointer to the astrometry descriptor + +pointer fs + +begin + call calloc (fs, LEN_PFILTER, TY_STRUCT) + + AT_FSORT(fs) = EOS + AT_FREVERSE(fs) = NO + AT_FREPLACE(fs) = YES + + call strcpy ("J2000", AT_FOSYSTEM(fs), SZ_LINE) + call strcpy ("ra", AT_FIRA(fs), SZ_LINE) + call strcpy ("dec", AT_FIDEC(fs), SZ_LINE) + AT_FORAFORMAT(fs) = EOS + AT_FODECFORMAT(fs) = EOS + AT_FORAUNITS(fs) = AT_HOURS + AT_FODECUNITS(fs) = AT_DEGREES + + call strcpy ("xp", AT_FIXP(fs), SZ_LINE) + call strcpy ("yp", AT_FIYP(fs), SZ_LINE) + call strcpy ("xc", AT_FIXC(fs), SZ_LINE) + call strcpy ("yc", AT_FIYC(fs), SZ_LINE) + AT_FOXFORMAT(fs) = EOS + AT_FOYFORMAT(fs) = EOS + + call strcpy ("*", AT_FIELDS(fs), SZ_LINE) + call strcpy ("yes", AT_FEXPR(fs), SZ_LINE) + AT_FNAMES(fs) = EOS + AT_FNTYPES(fs) = EOS + AT_FNUNITS(fs) = EOS + AT_FNFORMATS(fs) = EOS + + AT_PFILTER(at) = fs +end + + +# AT_FSFREE -- Free the filtering / selection structure. + +procedure at_fsfree (at) + +pointer at #I the pointer to the astrometry descriptor + +pointer fs + +begin + fs = AT_PFILTER(at) + call mfree (fs, TY_STRUCT) + AT_PFILTER(at) = NULL +end + + +# AT_WCINIT -- Initialize the default WCS structure + +procedure at_wcinit (at) + +pointer at #I the mail astrometry package descriptor + +pointer wc + +begin + call calloc (wc, LEN_PWCS, TY_STRUCT) + AT_WXREF(wc) = INDEFD + AT_WYREF(wc) = INDEFD + AT_WXMAG(wc) = 1.0 + AT_WYMAG(wc) = 1.0 + AT_WXROT(wc) = 0.0 + AT_WYROT(wc) = 0.0 + AT_WRAREF(wc) = 0.0 + AT_WDECREF(wc) = 0.0 + AT_WRAUNITS(wc) = 0 + AT_WDECUNITS(wc) = 0 + AT_WPROJ(wc) = EOS + AT_WSYSTEM(wc) = EOS + + AT_WCST(wc) = NULL + + AT_PWCS(at) = wc +end + + +# AT_WCFREE -- Free the default WCS structure + +procedure at_wcfree (at) + +pointer at #I the mail astrometry package descriptor + +pointer wc + +begin + wc = AT_PWCS(at) + + # Close the default wcspars parameters symbol table. + if (AT_WCST(wc) != NULL) + call stclose(AT_WCST(wc)) + AT_WCST(wc) = NULL + + call mfree (wc, TY_STRUCT) + AT_PWCS(at) = NULL +end + + +# AT_IMINIT -- Initialize the default mage data structure + +procedure at_iminit (at) + +pointer at #I the mail astrometry package descriptor + +pointer ip + +begin + call calloc (ip, LEN_PIMPARS, TY_STRUCT) + AT_ESITELNG(ip) = INDEFD + AT_ESITELAT(ip) = INDEFD + AT_EMJDOBS(ip) = INDEFD + + AT_ESITEALT(ip) = INDEFR + AT_ESITETZ(ip) = INDEFR + AT_EDATAMIN(ip) = INDEFR + AT_EDATAMAX(ip) = INDEFR + AT_EGAIN(ip) = 1.0 + AT_ERDNOISE(ip) = 0.0 + AT_EWAVLEN(ip) = INDEFR + AT_ETEMP(ip) = INDEFR + AT_EPRESS(ip) = INDEFR + + AT_OBSERVAT(ip) = EOS + + AT_IMST(ip) = NULL + + AT_PIMPARS(at) = ip +end + + +# AT_IMFREE -- Free the default image data structure + +procedure at_imfree (at) + +pointer at #I the mail astrometry package descriptor + +pointer ip + +begin + ip = AT_PIMPARS(at) + + # Close the default wcspars parameters symbol table. + if (AT_IMST(ip) != NULL) + call stclose(AT_IMST(ip)) + AT_IMST(ip) = NULL + + call mfree (ip, TY_STRUCT) + AT_PIMPARS(at) = NULL +end diff --git a/noao/astcat/src/attools/atcathdr.x b/noao/astcat/src/attools/atcathdr.x new file mode 100644 index 00000000..d261e3cd --- /dev/null +++ b/noao/astcat/src/attools/atcathdr.x @@ -0,0 +1,262 @@ +include <pkg/cq.h> +include "../../lib/acatalog.h" + +# AT_GCATHDR -- Read a standard ASTROMZ catalog header. + +int procedure at_gcathdr (fd, hdrtext, maxch) + +int fd #I the input file descriptor +char hdrtext[ARB] #O the output catalog description +int maxch #I the maximum size of the catalog description + +pointer sp, line +int nlines, strfd, nchars +bool first_line +int stropen(), getline(), strncmp() + +begin + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Go to the beginning of the file. + call seek (fd, BOF) + + # Initialize the number of lines in the catalog description. + nlines = 0 + first_line = true + + # Open the output text as a string. + hdrtext[1] = EOS + strfd = stropen (hdrtext, maxch, NEW_FILE) + + # Read in the catalog header as delimited by BEGIN CATALOG HEADER + # and END CATALOG HEADER strings. Skip leading blank lines. + repeat { + nchars = getline (fd, Memc[line]) + if (nchars == EOF) + break + if (first_line) { + if (Memc[line] == '\n') + next + if (strncmp (Memc[line], "#\n", 2) == 0) + next + if (strncmp (Memc[line], "# \n", 3) == 0) + next + if (strncmp (Memc[line], "# BEGIN CATALOG HEADER", 22) != 0) + break + first_line = false + next + } + if (strncmp (Memc[line], "# END CATALOG HEADER", 20) == 0) + break + call fprintf (strfd, "%s") + call pargstr (Memc[line+2]) + nlines = nlines + 1 + } + call close (strfd) + + # Return to the beginning of the file if no header was found. + if (nlines == 0) + call seek (fd, BOF) + + call sfree (sp) + + return (nlines) +end + + +# AT_PCATHDR -- Read in the catalog format from a parameter set and create +# a standard ASTROMZ catalog header suitable for input to the catalog +# query routines. + +int procedure at_pcathdr (pset, hdrtxt, maxch) + +char pset[ARB] #I the name of the catalog description pset +char hdrtxt[ARB] #O the standard output catalog description +int maxch #I the maximum size of the header text + +pointer sp, fname, fval, funits, fmts, findex, ranges, pp +int i, j, nfields, ncols, nvals, nlines, number, type, fsize, fd +char cdtype +pointer clopset() +int at_wrdstr(), decode_ranges(), stropen(), strdic(), nscan() +int get_next_number + +begin + # Get working space. + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (fval, SZ_FNAME, TY_CHAR) + call salloc (funits, SZ_FNAME, TY_CHAR) + call salloc (fmts, SZ_FNAME, TY_CHAR) + call salloc (findex, AT_NSTDCOLS, TY_INT) + call salloc (ranges, 3 * AT_MAX_NRANGES + 1, TY_INT) + + # Open the pset + pp = clopset (pset) + + # Get the file type. + call clgpset (pp, "ftype", Memc[fval], SZ_FNAME) + type = strdic (Memc[fval], Memc[fval], SZ_FNAME, CQ_RTYPESTR) + if (type <= 0) + type = CQ_STEXT + + # Count the fields. + nfields = 0; ncols = 0 + do i = 1, AT_NSTDCOLS { + if (at_wrdstr (i, Memc[fname], SZ_FNAME, AT_CATNAMES) <= 0) + next + if (Memc[fname] == EOS) + next + call clgpset (pp, Memc[fname], Memc[fval], SZ_FNAME) + if (Memc[fval] == EOS) + next + call sscan (Memc[fval]) + call gargwrd (Memc[fval], SZ_FNAME) + if (nscan() < 1) + next + if (decode_ranges (Memc[fval], Memi[ranges], AT_MAX_NRANGES, + nvals) == ERR) + next + if (nvals <= 0) + next + if (type == CQ_BTEXT) { + call gargi (j) + if (nscan() < 2) + next + } + Memi[findex+nfields] = i + nfields = nfields + 1 + ncols = ncols + nvals + } + + # Write the header description. + nlines = 0 + if (nfields > 0) { + + # Open the string as a file. + hdrtxt[1] = EOS + fd = stropen (hdrtxt, maxch, NEW_FILE) + + # Write the catalog type. + call clgpset (pp, "ftype", Memc[fval], SZ_FNAME) + type = strdic (Memc[fval], Memc[fval], SZ_FNAME, CQ_RTYPESTR) + call fprintf (fd, "%s %s\n") + call pargstr ("type") + call pargstr (Memc[fval]) + nlines = nlines + 1 + + # Write out the header parameters. At present there is only one + # the catalog coordinate system. + call fprintf (fd, "nheader 1\n") + nlines = nlines + 1 + call clgpset (pp, "csystem", Memc[fval], SZ_FNAME) + call fprintf (fd, " %s %s\n") + call pargstr ("csystem") + call pargstr (Memc[fval]) + nlines = nlines + 1 + + # Write out the legal fields. + call fprintf (fd, "nfields %d\n") + call pargi (ncols) + nlines = nlines + 1 + do i = 1, nfields { + if (at_wrdstr (Memi[findex+i-1], Memc[fname], SZ_FNAME, + AT_CATNAMES) <= 0) + next + if (Memc[fname] == EOS) + next + call clgpset (pp, Memc[fname], Memc[fval], SZ_FNAME) + if (Memc[fval] == EOS) + next + call sscan (Memc[fval]) + switch (type) { + case CQ_BTEXT: + call gargwrd (Memc[fval], SZ_FNAME) + call gargi (fsize) + call gargwrd (Memc[funits], SZ_FNAME) + call gargwrd (Memc[fmts], SZ_FNAME) + default: + call gargwrd (Memc[fval], SZ_FNAME) + call gargwrd (Memc[funits], SZ_FNAME) + call gargwrd (Memc[fmts], SZ_FNAME) + } + if (decode_ranges (Memc[fval], Memi[ranges], AT_MAX_NRANGES, + nvals) == ERR) + next + if (nvals <= 0) + next + if (at_wrdstr (Memi[findex+i-1], cdtype, 1, AT_CATTYPES) <= 0) + cdtype = 'c' + if (Memc[funits] == EOS) { + if (at_wrdstr (Memi[findex+i-1], Memc[funits], SZ_FNAME, + AT_CATUNITS) <= 0) + call strcpy ("INDEF", Memc[fmts], SZ_FNAME) + } + if (Memc[fmts] == EOS) { + if (at_wrdstr (Memi[findex+i-1], Memc[fmts], SZ_FNAME, + AT_CATFORMATS) <= 0) + call strcpy ("%s", Memc[fmts], SZ_FNAME) + } + switch (type) { + case CQ_BTEXT: + if (nvals == 1) { + call fprintf (fd, " %s %s %d %c %s %s\n") + call pargstr (Memc[fname]) + call pargstr (Memc[fval]) + call pargi (fsize) + call pargc (cdtype) + call pargstr (Memc[funits]) + call pargstr (Memc[fmts]) + nlines = nlines + 1 + } else { + number = 0 + do j = 1, nvals { + call fprintf (fd, " %s%d %d %d %c %s %s\n") + call pargstr (Memc[fname]) + call pargi (j) + call pargi (get_next_number (Memi[ranges], + number)) + call pargi (fsize) + call pargc (cdtype) + call pargstr (Memc[funits]) + call pargstr (Memc[fmts]) + nlines = nlines + 1 + } + } + default: + if (nvals == 1) { + call fprintf (fd, " %s %s 0 %c %s %s\n") + call pargstr (Memc[fname]) + call pargstr (Memc[fval]) + call pargc (cdtype) + call pargstr (Memc[funits]) + call pargstr (Memc[fmts]) + nlines = nlines + 1 + } else { + number = 0 + do j = 1, nvals { + call fprintf (fd, " %s%d %d 0 %c %s %s\n") + call pargstr (Memc[fname]) + call pargi (j) + call pargi (get_next_number (Memi[ranges], + number)) + call pargc (cdtype) + call pargstr (Memc[funits]) + call pargstr (Memc[fmts]) + nlines = nlines + 1 + } + } + } + } + + call close (fd) + } + + # Close the pset + call clcpset (pp) + + call sfree (sp) + + return (nlines) +end diff --git a/noao/astcat/src/attools/atdefpars.x b/noao/astcat/src/attools/atdefpars.x new file mode 100644 index 00000000..0b8b2cb7 --- /dev/null +++ b/noao/astcat/src/attools/atdefpars.x @@ -0,0 +1,305 @@ +include "../../lib/astrom.h" +include "../../lib/acatalog.h" +include "../../lib/aimpars.h" + + +# AT_DRCPSET -- Reset the region definition parameters to their default values. + +procedure at_drcpset (at) + +pointer at #I the pointer to the main astrom structure + +begin + # Set the default field center and width. + call at_setd (at, RCRA, 0.0d0) + call at_setd (at, RCDEC, 0.0d0) + call at_setd (at, RCRAWIDTH, 10.0d0) + call at_setd (at, RCDECWIDTH, 10.0d0) + + # Set the default field center units. + call at_seti (at, RCRAUNITS, 0) + call at_seti (at, RCDECUNITS, 0) + + # Set the default field center coordinate system. + call at_sets (at, RCSYSTEM, "") +end + + +# AT_DFSPSET -- Reset the filtering parameters to their default values. + +procedure at_dfspset (at) + +pointer at #I the pointer to the main astrom structure + +begin + call at_sets (at, FIELDS, "f[*]") + call at_sets (at, FEXPR, "yes") + call at_sets (at, FNAMES, "") + call at_sets (at, FNTYPES, "") + call at_sets (at, FNUNITS, "") + call at_sets (at, FNFORMATS, "") + call at_sets (at, FSORT, "") + call at_seti (at, FREVERSE, NO) + call at_sets (at, FOSYSTEM, "") + call at_sets (at, FIRA, "ra") + call at_sets (at, FIDEC, "dec") + call at_seti (at, FORAUNITS, 0) + call at_seti (at, FODECUNITS, 0) + call at_sets (at, FORAFORMAT, "") + call at_sets (at, FODECFORMAT, "") + call at_sets (at, FIXP, "xp") + call at_sets (at, FIYP, "yp") + call at_sets (at, FIXC, "xc") + call at_sets (at, FIYC, "yc") + call at_sets (at, FOXFORMAT, "%10.3f") + call at_sets (at, FOYFORMAT, "%10.3f") +end + + +# AT_DWCPSET -- Reset the wcs parameters to their default values. + +procedure at_dwcpset (at) + +pointer at #I the pointer to the main astrom structure + +double dval +pointer st, sym +int ip +pointer at_statp(), stfind() +int ctod() + +begin + st = at_statp (at, WCST) + if (st == NULL) + return + + sym = stfind (st, "wxref") + if (sym != NULL) { + call strcpy ("INDEF", AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod ("INDEF", ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WXREF, dval) + } + + sym = stfind (st, "wyref") + if (sym != NULL) { + call strcpy ("INDEF", AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod ("INDEF", ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WYREF, dval) + } + + sym = stfind (st, "wxmag") + if (sym != NULL) { + call strcpy ("INDEF", AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod ("INDEF", ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WXMAG, dval) + } + + sym = stfind (st, "wymag") + if (sym != NULL) { + call strcpy ("INDEF", AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod ("INDEF", ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WYMAG, dval) + } + + sym = stfind (st, "wxrot") + if (sym != NULL) { + call strcpy ("180.0", AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod ("180.0", ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WXROT, dval) + } + + sym = stfind (st, "wyrot") + if (sym != NULL) { + call strcpy ("0.0", AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod ("0.0", ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WYROT, dval) + } + + sym = stfind (st, "wraref") + if (sym != NULL) { + call strcpy ("RA", AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod ("RA", ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WRAREF, dval) + } + + sym = stfind (st, "wdecref") + if (sym != NULL) { + call strcpy ("DEC", AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod ("DEC", ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WDECREF, dval) + } + + sym = stfind (st, "wraunits") + if (sym != NULL) { + call strcpy ("", AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + call at_seti (at, WRAUNITS, 0) + } + + sym = stfind (st, "wdecunits") + if (sym != NULL) { + call strcpy ("", AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + call at_seti (at, WDECUNITS, 0) + } + + sym = stfind (st, "wproj") + if (sym != NULL) { + call strcpy ("INDEF", AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + call at_sets (at, WPROJ, "tan") + } + + sym = stfind (st, "wsystem") + if (sym != NULL) { + call strcpy ("EQUINOX", AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + call at_sets (at, WSYSTEM, "EQUINOX") + } +end + + +# AT_DIMPSET -- Read in the default image data parameters. + +procedure at_dimpset (at) + +pointer at #I the pointer to the main astrom structure + +double dval +real rval +pointer st, sym +int ip +pointer at_statp(), stfind() +int ctod(), ctor() + +begin + st = at_statp (at, IMST) + if (st == NULL) + return + + sym = stfind (st, "esitelng") + if (sym != NULL) { + call strcpy ("INDEF", AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctod ("INDEF", ip, dval) <= 0) + dval = INDEFD + call at_setd (at, ESITELNG, dval) + } + + sym = stfind (st, "esitelat") + if (sym != NULL) { + call strcpy ("INDEF", AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctod ("INDEF", ip, dval) <= 0) + dval = INDEFD + call at_setd (at, ESITELAT, dval) + } + + sym = stfind (st, "esitealt") + if (sym != NULL) { + call strcpy ("INDEF", AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor ("INDEF", ip, rval) <= 0) + rval = INDEFR + call at_setr (at, ESITEALT, rval) + } + + sym = stfind (st, "esitetz") + if (sym != NULL) { + call strcpy ("INDEF", AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor ("INDEF", ip, rval) <= 0) + rval = INDEFR + call at_setr (at, ESITETZ, rval) + } + + sym = stfind (st, "emjdobs") + if (sym != NULL) { + call strcpy ("MJD-OBS", AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctod ("MJD-OBS", ip, dval) <= 0) + dval = INDEFD + call at_setd (at, EMJDOBS, dval) + } + + sym = stfind (st, "edatamin") + if (sym != NULL) { + call strcpy ("INDEF", AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor ("INDEF", ip, rval) <= 0) + rval = INDEFR + call at_setr (at, EDATAMIN, rval) + } + + sym = stfind (st, "edatamax") + if (sym != NULL) { + call strcpy ("INDEF", AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor ("INDEF", ip, rval) <= 0) + rval = INDEFR + call at_setr (at, EDATAMAX, rval) + } + + sym = stfind (st, "egain") + if (sym != NULL) { + call strcpy ("GAIN", AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor ("GAIN", ip, rval) <= 0) + rval = INDEFR + call at_setr (at, EGAIN, rval) + } + + sym = stfind (st, "erdnoise") + if (sym != NULL) { + call strcpy ("RDNOISE", AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor ("RDNOISE", ip, rval) <= 0) + rval = INDEFR + call at_setr (at, ERDNOISE, rval) + } + + sym = stfind (st, "ewavlen") + if (sym != NULL) { + call strcpy ("INDEF", AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor ("INDEF", ip, rval) <= 0) + rval = INDEFR + call at_setr (at, EWAVLEN, rval) + } + + sym = stfind (st, "etemp") + if (sym != NULL) { + call strcpy ("INDEF", AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor ("INDEF", ip, rval) <= 0) + rval = INDEFR + call at_setr (at, ETEMP, rval) + } + + sym = stfind (st, "epress") + if (sym != NULL) { + call strcpy ("INDEF", AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor ("INDEF", ip, rval) <= 0) + rval = INDEFR + call at_setr (at, EPRESS, rval) + } + + sym = stfind (st, "observat") + if (sym != NULL) { + call strcpy ("OBSERVAT", AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + call at_sets (at, OBSERVAT, "OBSERVAT") + } +end diff --git a/noao/astcat/src/attools/atdtype.x b/noao/astcat/src/attools/atdtype.x new file mode 100644 index 00000000..44ba4051 --- /dev/null +++ b/noao/astcat/src/attools/atdtype.x @@ -0,0 +1,55 @@ +# AT_DTYPE -- Decode the field data type. + +define NTYPES 6 + +# AT_DTYPE -- Given a single character data type from the set [csilrd] return +# the appropriate integer type, + +int procedure at_dtype (c) + +char c + +int type_codes[NTYPES], i +string types "csilrd" +int stridx() +data type_codes /TY_CHAR, TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE/ + +begin + i = stridx (c, types) + if (i == 0) + return (TY_CHAR) + else + return (type_codes[stridx(c,types)]) +end + + +# AT_ITYPE -- Given an integer code from the set TY_CHAR, TY_SHORT, TY_INT, +# TY_LONG, TY_REAL, and TY_DOUBLE return the appropriate character code +# from the set [csilrd]. + +char procedure at_itype (itype) + +int itype #I the integer data type + +char c + +begin + switch (itype) { + case TY_CHAR: + c = 'c' + case TY_SHORT: + c = 's' + case TY_INT: + c = 'i' + case TY_LONG: + c = 'l' + case TY_REAL: + c = 'r' + case TY_DOUBLE: + c = 'd' + default: + c = 'c' + } + + return (c) +end diff --git a/noao/astcat/src/attools/atfnames.x b/noao/astcat/src/attools/atfnames.x new file mode 100644 index 00000000..67741d5e --- /dev/null +++ b/noao/astcat/src/attools/atfnames.x @@ -0,0 +1,748 @@ +include <pkg/cq.h> +include "../../lib/astrom.h" + +# AT_SVLIST -- Create the input image survey list + +int procedure at_svlist (surveys, imdb) + +char surveys[ARB] #I the input image survey list +char imdb[ARB] #I the input image survey database file + +pointer sp, stemplate, svname, cq +int i, svlist, len_stemplate, strfd, svno +pointer cq_map() +int fntopnb(), fntlenb(), fntrfnb(), stropen(), cq_setcat(), strlen() +int cq_stati(), cq_locaten() +errchk fntopnb() + +begin + iferr (svlist = fntopnb (surveys, NO)) + svlist = fntopnb ("", NO) + if (surveys[1] == EOS) + return (svlist) + if (surveys[1] != '*' && fntlenb (svlist) <= 0) + return (svlist) + + # Open the catalog database. + cq = cq_map (imdb, READ_ONLY) + if (cq == NULL) { + call fntclsb (svlist) + svlist = fntopnb ("", NO) + return (svlist) + } + + # Determine the length of the image survey list string. + call smark (sp) + call salloc (svname, SZ_FNAME, TY_CHAR) + if (surveys[1] == '*') + len_stemplate = cq_stati (cq, CQNRECS) * SZ_FNAME + 1 + else + len_stemplate = fntlenb (svlist) * SZ_FNAME + 1 + call salloc (stemplate, len_stemplate, TY_CHAR) + Memc[stemplate] = EOS + + # Loop through the surveys checking for appropriate entry in the + # survey database + strfd = stropen (Memc[stemplate], len_stemplate, NEW_FILE) + if (surveys[1] == '*') { + do i = 1, cq_stati (cq, CQNRECS) { + if (cq_locaten (cq, i, Memc[svname], SZ_FNAME) != i) + next + call fprintf (strfd, "%s,") + call pargstr (Memc[svname]) + } + } else { + do i = 1, fntlenb (svlist) { + if (fntrfnb (svlist, i, Memc[svname], SZ_FNAME) == EOF) + break + svno = cq_setcat (cq, Memc[svname]) + if (svno <= 0) + next + call fprintf (strfd, "%s,") + call pargstr (Memc[svname]) + } + } + call close (strfd) + + # Create the final catalog list. + if (Memc[stemplate] != EOS) + Memc[stemplate+strlen(Memc[stemplate])-1] = EOS + call fntclsb (svlist) + svlist = fntopnb (Memc[stemplate], NO) + + # Unmap the catalog database. + call cq_unmap (cq) + + call sfree (sp) + + return (svlist) +end + +define SZ_HDRTEXT (5 * SZ_LINE) + +# AT_CATLIST -- Create the input catalog list + +int procedure at_catlist (catalogs, catdb) + +char catalogs[ARB] #I the input catalog list +char catdb[ARB] #I the input catalog database file + +pointer sp, ctemplate, catname, hdrtext, cq +int i, catlist, len_ctemplate, strfd, catno, tmpfd +pointer cq_map() +int fntopnb(), fntlenb(), fntrfnb(), stropen(), cq_setcat(), strlen() +int cq_stati(), cq_locaten(), access(), open(), at_gcathdr() +bool streq() +errchk fntopnb() + +begin + iferr (catlist = fntopnb (catalogs, NO)) + catlist = fntopnb ("", NO) + if (catalogs[1] == EOS) + return (catlist) + if (catalogs[1] != '*' && fntlenb (catlist) <= 0) + return (catlist) + + # Open the catalog database. + cq = cq_map (catdb, READ_ONLY) + if (cq == NULL) { + call fntclsb (catlist) + catlist = fntopnb ("", NO) + return (catlist) + } + + # Determine the length of the catalog list string. + call smark (sp) + call salloc (catname, SZ_FNAME, TY_CHAR) + if (catalogs[1] == '*') + len_ctemplate = cq_stati (cq, CQNRECS) * SZ_FNAME + 1 + else + len_ctemplate = fntlenb (catlist) * SZ_FNAME + 1 + call salloc (ctemplate, len_ctemplate, TY_CHAR) + Memc[ctemplate] = EOS + call salloc (hdrtext, SZ_HDRTEXT, TY_CHAR) + + # Loop through the catalogs checking for appropriate entry in the + # catalog database + strfd = stropen (Memc[ctemplate], len_ctemplate, NEW_FILE) + if (catalogs[1] == '*') { + do i = 1, cq_stati (cq, CQNRECS) { + if (cq_locaten (cq, i, Memc[catname], SZ_FNAME) != i) + next + if (streq (Memc[catname], "filename@noao")) + next + call fprintf (strfd, "%s,") + call pargstr (Memc[catname]) + } + } else { + do i = 1, fntlenb (catlist) { + if (fntrfnb (catlist, i, Memc[catname], SZ_FNAME) == EOF) + break + catno = cq_setcat (cq, Memc[catname]) + if (catno <= 0) { + if (access (Memc[catname], READ_ONLY, TEXT_FILE) == NO) + next + tmpfd = open (Memc[catname], READ_ONLY, TEXT_FILE) + if (at_gcathdr (tmpfd, Memc[hdrtext], SZ_HDRTEXT) <= 0) + next + call close (tmpfd) + } + call fprintf (strfd, "%s,") + call pargstr (Memc[catname]) + } + } + call close (strfd) + + # Create the final catalog list. + if (Memc[ctemplate] != EOS) + Memc[ctemplate+strlen(Memc[ctemplate])-1] = EOS + call fntclsb (catlist) + catlist = fntopnb (Memc[ctemplate], NO) + + # Unmap the catalog database. + call cq_unmap (cq) + + call sfree (sp) + + return (catlist) +end + + +# AT_OSVLIST -- Create a list output images using the input surveys list, +# the field center list stored in the field center symbol table, and an input +# template string. + +int procedure at_osvlist (at, svlist, output, defaultstr, extstr, append) + +pointer at #I the astrometry package descriptor +int svlist #I the input surveys list descriptor +char output[ARB] #I the input output file list +char defaultstr[ARB] #I the defaults id string +char extstr[ARB] #I the extension string +int append #I test for existence of file ? + +pointer sp, dirname, fname, fcname, symlist, symbol, otemplate, st +int i, j, imlist, len_dir, len_otemplate, strfd +pointer sthead(), stnext(), at_statp() +int imtopen(), fntlenb(), stnsymbols(), fnldir(), strncmp() +int strlen(), stropen(), access(), imtlen(), imtrgetim() +errchk imtopen() + +begin + # Return if the input file list is empty. + call at_sets (at, OUTPUT, "") + if (at_statp(at, PRCENTER) == NULL) { + imlist = imtopen ("") + } else if (at_statp(at, RCST) == NULL) { + imlist = imtopen ("") + } else { + iferr (imlist = imtopen (output)) + imlist = imtopen ("") + } + if (output[1] == EOS || imtlen (imlist) <= 0) + return (imlist) + + # Get the symbol table descriptor. + st = at_statp(at,RCST) + + # Return if the output file list is the wrong length. + if ((imtlen (imlist) > 1) && (imtlen (imlist) != fntlenb(svlist) * + stnsymbols(st, 0))) { + call imtclose (imlist) + imlist = imtopen ("") + return (imlist) + } + + # Get working space + call smark (sp) + call salloc (dirname, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (fcname, SZ_FNAME, TY_CHAR) + call salloc (symlist, stnsymbols(st,0), TY_INT) + + # Get the symbol list. Note that it is in reverse order. + symbol = sthead (st) + do i = 1, stnsymbols (st, 0) { + Memi[symlist+i-1] = symbol + symbol = stnext (st, symbol) + } + + # Get the directory name. + if (imtrgetim (imlist, 1, Memc[fname], SZ_FNAME) == EOF) + Memc[fname] = EOS + len_dir = fnldir (Memc[fname], Memc[dirname], SZ_FNAME) + + # Get the default output file names. There will be one output file per + # input image. + if (strncmp (defaultstr, Memc[fname+len_dir], + strlen (defaultstr)) == 0 || len_dir == strlen (Memc[fname])) { + + # Creata temporary list string. + call imtclose (imlist) + len_otemplate = fntlenb (svlist) * stnsymbols (st, 0) * + SZ_FNAME + 1 + call salloc (otemplate, len_otemplate, TY_CHAR) + Memc[otemplate] = EOS + + # Loop over the catalog list. + strfd = stropen (Memc[otemplate], len_otemplate, NEW_FILE) + do j = 1, fntlenb (svlist) { + + # Loop over the symbol table. + do i = stnsymbols (st, 0), 1, -1 { + + symbol = Memi[symlist+i-1] + if (strncmp (AT_RCSTSOURCE(symbol), "image", 5) == 0) { + if (fntlenb (svlist) > 1) { + call sprintf (Memc[fcname], SZ_FNAME, "%s.%03d") + call pargstr (AT_RCSTNAME(symbol)) + call pargi (j) + call at_oimname (Memc[fcname], Memc[dirname], + extstr, Memc[dirname], SZ_FNAME) + } else + call at_oimname (AT_RCSTNAME(symbol), Memc[dirname], + extstr, Memc[dirname], SZ_FNAME) + } else { + if (fntlenb (svlist) > 1) { + call sprintf (Memc[fcname], SZ_FNAME, + "reg%03d.%03d") + call pargi (stnsymbols(st, 0) - i + 1) + call pargi (j) + } else { + call sprintf (Memc[fcname], SZ_FNAME, "reg%03d") + call pargi (stnsymbols(st, 0) - i + 1) + } + call at_oimname (Memc[fcname], Memc[dirname], extstr, + Memc[dirname], SZ_FNAME) + } + + # Record the file name. + call fprintf (strfd, "%s,") + call pargstr (Memc[dirname]) + + } + } + call close (strfd) + + # Create the final list. + if (Memc[otemplate] != EOS) + Memc[otemplate+strlen(Memc[otemplate])-1] = EOS + imlist = imtopen (Memc[otemplate]) + + # Get the user output names. + } else { + + # Create a temporary list string. + len_otemplate = imtlen (imlist) * SZ_FNAME + 1 + call salloc (otemplate, len_otemplate, TY_CHAR) + Memc[otemplate] = EOS + + strfd = stropen (Memc[otemplate], len_otemplate, NEW_FILE) + do j = 1, fntlenb (svlist) { + + # Loop over the fields. + do i = 1, imtlen (imlist) { + + # Get the output file name. + if (imtrgetim (imlist, i, Memc[fname], SZ_FNAME) == EOF) + break + + # Provide a default name if necessary. + if (append == NO && access (Memc[fname], 0, 0) == YES) { + symbol = Memi[symlist+stnsymbols(st,0)-i] + if (strncmp (AT_RCSTSOURCE(symbol), "image", 5) == 0) { + if (stnsymbols (st,0) > 1) { + call sprintf (Memc[fcname], SZ_FNAME, "%s.%03d") + call pargstr (AT_RCSTNAME(symbol)) + call pargi (j) + call at_oimname (Memc[fcname], Memc[dirname], + extstr, Memc[fname], SZ_FNAME) + } else + call at_oimname (AT_RCSTNAME(symbol), + Memc[dirname], extstr, Memc[fname], + SZ_FNAME) + } else { + if (fntlenb (svlist) > 1) { + call sprintf (Memc[fcname], SZ_FNAME, + "reg%03d.%03d") + call pargi (stnsymbols(st, 0) - i + 1) + call pargstr (j) + } else { + call sprintf (Memc[fcname], SZ_FNAME, + "reg%03d") + call pargi (stnsymbols(st, 0) - i + 1) + } + call at_oimname (Memc[fcname], Memc[dirname], + extstr, Memc[fname], SZ_FNAME) + } + } + + # Add the file name to the list. + call fprintf (strfd, "%s,") + call pargstr (Memc[fname]) + } + } + call close (strfd) + + if (Memc[otemplate] != EOS) + Memc[otemplate+strlen(Memc[otemplate])-1] = EOS + call imtclose (imlist) + imlist = imtopen (Memc[otemplate]) + } + call at_sets (at, OUTPUT, output) + + call sfree (sp) + + return (imlist) +end + + +# AT_OCATLIST -- Create a list output files list using the input catalog list, +# the field center list stored in the field center symbol table, and an input +# file template string. + +int procedure at_ocatlist (at, catlist, output, defaultstr, extstr, append) + +pointer at #I the astrometry package descriptor +int catlist #I the input catalog list descriptor +char output[ARB] #I the input output file list +char defaultstr[ARB] #I the defaults id string +char extstr[ARB] #I the extension string +int append #I test for existence of file ? + +pointer sp, dirname, fname, fcname, symlist, symbol, otemplate, st +int i, j, olist, len_dir, len_otemplate, strfd +pointer sthead(), stnext(), at_statp() +int fntopnb(), fntlenb(), stnsymbols(), fntrfnb(), fnldir(), strncmp() +int strlen(), stropen(), access() +errchk fntopnb() + +begin + # Return if the input file list is empty. + if (at_statp(at, PRCENTER) == NULL) { + olist = fntopnb ("", NO) + } else if (at_statp(at, RCST) == NULL) { + olist = fntopnb ("", NO) + } else { + iferr (olist = fntopnb (output, NO)) + olist = fntopnb ("", NO) + } + if (output[1] == EOS || fntlenb (olist) <= 0) + return (olist) + + # Get the symbol table descriptor. + st = at_statp(at,RCST) + + # Return if the output file list is the wrong length. + if ((fntlenb (olist) > 1) && (fntlenb (olist) != fntlenb(catlist) * + stnsymbols(st, 0))) { + call fntclsb (olist) + olist = fntopnb ("", NO) + return (olist) + } + + # Get working space + call smark (sp) + call salloc (dirname, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (fcname, SZ_FNAME, TY_CHAR) + call salloc (symlist, stnsymbols(st,0), TY_INT) + + # Get the symbol list. Note that it is in reverse order. + symbol = sthead (st) + do i = 1, stnsymbols (st, 0) { + Memi[symlist+i-1] = symbol + symbol = stnext (st, symbol) + } + + # Get the directory name. + if (fntrfnb (olist, 1, Memc[fname], SZ_FNAME) == EOF) + Memc[fname] = EOS + len_dir = fnldir (Memc[fname], Memc[dirname], SZ_FNAME) + + # Get the default output file names. There will be one output file per + # input image. + if (strncmp (defaultstr, Memc[fname+len_dir], + strlen (defaultstr)) == 0 || len_dir == strlen (Memc[fname])) { + + # Creata temporary list string. + call fntclsb (olist) + len_otemplate = fntlenb (catlist) * stnsymbols (st, 0) * + SZ_FNAME + 1 + call salloc (otemplate, len_otemplate, TY_CHAR) + Memc[otemplate] = EOS + + # Loop over the catalog list. + strfd = stropen (Memc[otemplate], len_otemplate, NEW_FILE) + do j = 1, fntlenb (catlist) { + + # Loop over the symbol table. + do i = stnsymbols (st, 0), 1, -1 { + + symbol = Memi[symlist+i-1] + if (strncmp (AT_RCSTSOURCE(symbol), "image", 5) == 0) { + if (fntlenb (catlist) > 1) { + call sprintf (Memc[fcname], SZ_FNAME, "%s.%03d") + call pargstr (AT_RCSTNAME(symbol)) + call pargi (j) + call at_outname (Memc[fcname], Memc[dirname], + extstr, Memc[dirname], SZ_FNAME) + } else + call at_outname (AT_RCSTNAME(symbol), Memc[dirname], + extstr, Memc[dirname], SZ_FNAME) + } else { + if (fntlenb (catlist) > 1) { + call sprintf (Memc[fcname], SZ_FNAME, + "reg%03d.%03d") + call pargi (stnsymbols(st, 0) - i + 1) + call pargi (j) + } else { + call sprintf (Memc[fcname], SZ_FNAME, "reg%03d") + call pargi (stnsymbols(st, 0) - i + 1) + } + call at_outname (Memc[fcname], Memc[dirname], extstr, + Memc[dirname], SZ_FNAME) + } + + # Record the file name. + call fprintf (strfd, "%s,") + call pargstr (Memc[dirname]) + + } + } + call close (strfd) + + # Create the final list. + if (Memc[otemplate] != EOS) + Memc[otemplate+strlen(Memc[otemplate])-1] = EOS + olist = fntopnb (Memc[otemplate], NO) + + # Get the user output names. + } else { + + # Create a temporary list string. + len_otemplate = fntlenb (olist) * SZ_FNAME + 1 + call salloc (otemplate, len_otemplate, TY_CHAR) + Memc[otemplate] = EOS + + strfd = stropen (Memc[otemplate], len_otemplate, NEW_FILE) + do j = 1, fntlenb (catlist) { + + # Loop over the fields. + do i = 1, fntlenb (olist) { + + # Get the output file name. + if (fntrfnb (olist, i, Memc[fname], SZ_FNAME) == EOF) + break + + # Provide a default name if necessary. + if (append == NO && access (Memc[fname], 0, 0) == YES) { + symbol = Memi[symlist+stnsymbols(st,0)-i] + if (strncmp (AT_RCSTSOURCE(symbol), "image", 5) == 0) { + if (fntlenb(catlist) > 1) { + call sprintf (Memc[fcname], SZ_FNAME, "%s.%03d") + call pargstr (AT_RCSTNAME(symbol)) + call pargi (j) + call at_outname (Memc[fcname], Memc[dirname], + extstr, Memc[fname], SZ_FNAME) + } else + call at_outname (AT_RCSTNAME(symbol), + Memc[dirname], extstr, Memc[fname], + SZ_FNAME) + } else { + if (fntlenb (catlist) > 1) { + call sprintf (Memc[fcname], SZ_FNAME, + "reg%03d.%03d") + call pargi (stnsymbols(st, 0) - i + 1) + call pargi (j) + } else { + call sprintf (Memc[fcname], SZ_FNAME, + "reg%03d") + call pargi (stnsymbols(st, 0) - i + 1) + } + call at_outname (Memc[fcname], Memc[dirname], + extstr, Memc[dirname], SZ_FNAME) + } + } + + # Add the file name to the list. + call fprintf (strfd, "%s,") + call pargstr (Memc[fname]) + } + } + call close (strfd) + + if (Memc[otemplate] != EOS) + Memc[otemplate+strlen(Memc[otemplate])-1] = EOS + call fntclsb (olist) + olist = fntopnb (Memc[otemplate], NO) + } + + call sfree (sp) + + return (olist) +end + + +# AT_OUTNAME -- Construct an astrom 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 at_outname (image, output, ext, name, maxch) + +char image[ARB] #I input image name +char output[ARB] #I input output directory or name +char ext[ARB] #I input extension +char name[ARB] #O output file 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) { + if (ext[1] == EOS) { + call sprintf (name[ndir+1], maxch, "%s%d.*") + call pargstr (Memc[root+nimdir]) + call pargi (clindex) + } else { + call sprintf (name[ndir+1], maxch, "%s%d.%s.*") + call pargstr (Memc[root+nimdir]) + call pargi (clindex) + call pargstr (ext) + } + } else { + if (ext[1] == EOS) { + call sprintf (name[ndir+1], maxch, "%s.*") + call pargstr (Memc[root+nimdir]) + } else { + call sprintf (name[ndir+1], maxch, "%s.%s.*") + call pargstr (Memc[root+nimdir]) + call pargstr (ext) + } + } + call at_oversion (name, name, maxch) + } else + call strcpy (output, name, maxch) + + call sfree (sp) +end + + +# AT_OVERSION -- Compute the next available version number of a given file +# name template and output the new file name. + +procedure at_oversion (template, filename, maxch) + +char template[ARB] #I the input name template +char filename[ARB] #O the output name +int maxch #I the maximum number of characters + +char period +int newversion, version, len +pointer sp, list, name +int fntgfnb() strldx(), ctoi(), fntopnb() +errchk fntopnb() + +begin + # Allocate temporary space + call smark (sp) + call salloc (name, maxch, TY_CHAR) + period = '.' + iferr (list = fntopnb (template, NO)) + list = fntopnb ("", 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 + + +# AT_OIMNAME -- Construct an output image 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 at_oimname (image, output, ext, name, maxch) + +char image[ARB] #I the input image name +char output[ARB] #I the output directory or ouput image name +char ext[ARB] #I the output image extension +char name[ARB] #O the final output image name +int maxch #I maximum size of name + +int ndir, nimdir, clindex, clsize +pointer sp, root, str +int fnldir(), strlen() + +begin + # Allocate some temporary space. + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Determine the length of the directory spec. + ndir = fnldir (output, name, maxch) + + # If the file spec is a directory create a name from the directory and + # the route image name, otherwise use the output name directly. + 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) { + if (ext[1] == EOS) { + call sprintf (name[ndir+1], maxch, "%s%d.*") + call pargstr (Memc[root+nimdir]) + call pargi (clindex) + } else { + call sprintf (name[ndir+1], maxch, "%s%d.%s.*") + call pargstr (Memc[root+nimdir]) + call pargi (clindex) + call pargstr (ext) + } + } else { + if (ext[1] == EOS) { + call sprintf (name[ndir+1], maxch, "%s.*") + call pargstr (Memc[root+nimdir]) + } else { + call sprintf (name[ndir+1], maxch, "%s.%s.*") + call pargstr (Memc[root+nimdir]) + call pargstr (ext) + } + } + call at_oimversion (name, name, maxch) + } else + call strcpy (output, name, maxch) + + call sfree (sp) +end + + +# AT_OIMVERSION -- Determine the next available version number of for a given +# image name template and output the new image name. + +procedure at_oimversion (template, filename, maxch) + +char template[ARB] #I the image name template +char filename[ARB] #O the output image name +int maxch #I the maximum number of characters + +char period +int newversion, version, len +pointer sp, list, name +int imtopen(), imtgetim(), strldx(), ctoi() + +begin + # Allocate temporary space + call smark (sp) + call salloc (name, maxch, TY_CHAR) + period = '.' + list = imtopen (template) + + # Loop over the names in the list searchng for the highest version. + newversion = 0 + while (imtgetim (list, Memc[name], maxch) != EOF) { + len = strldx (period, Memc[name]) + Memc[name+len-1] = EOS + 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 imtclose (list) + call sfree (sp) +end diff --git a/noao/astcat/src/attools/atinpars.x b/noao/astcat/src/attools/atinpars.x new file mode 100644 index 00000000..df0f5d95 --- /dev/null +++ b/noao/astcat/src/attools/atinpars.x @@ -0,0 +1,408 @@ +include "../../lib/astrom.h" +include "../../lib/acatalog.h" +include "../../lib/aimpars.h" + + +# AT_GRCPSET -- Read in the region definition parameters. + +procedure at_grcpset (psetname, at) + +char psetname[ARB] #I the input pset name +pointer at #I the pointer to the main astrom structure + +double dval +pointer sp, str, pp +int ival, nchars +double clgpsetd() +pointer clopset() +int ctod(), strlen(), strdic() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + pp = clopset (psetname) + + # Get the field center and width. + call clgpset (pp, "rcra", Memc[str], SZ_FNAME) + nchars = strlen (Memc[str]) + ival = 1 + if (nchars != 0 && (ctod (Memc[str], ival, dval) == nchars)) + call at_setd (at, RCRA, dval) + else + call error (0, "Parameter not a legal number (aregpars.rcra)") + + call clgpset (pp, "rcdec", Memc[str], SZ_FNAME) + nchars = strlen (Memc[str]) + ival = 1 + if (nchars != 0 && (ctod (Memc[str], ival, dval) == nchars)) + call at_setd (at, RCDEC, dval) + else + call error (0, "Parameter not a legal number (aregpars.rcdec)") + + call at_setd (at, RCRAWIDTH, clgpsetd (pp, "rrawidth")) + call at_setd (at, RCDECWIDTH, clgpsetd (pp, "rdecwidth")) + + # Get the field center units. + call clgpset (pp, "rcraunits", Memc[str], SZ_FNAME) + ival = strdic (Memc[str], Memc[str], SZ_FNAME, AT_RA_UNITS) + if (ival <= 0) + call at_seti (at, RCRAUNITS, 0) + else + call at_seti (at, RCRAUNITS, ival) + call clgpset (pp, "rcdecunits", Memc[str], SZ_FNAME) + ival = strdic (Memc[str], Memc[str], SZ_FNAME, AT_DEC_UNITS) + if (ival <= 0) + call at_seti (at, RCDECUNITS, 0) + else + call at_seti (at, RCDECUNITS, ival) + + # Get the field center celestial coordinate system. + call clgpset (pp, "rcsystem", Memc[str], SZ_FNAME) + call at_sets (at, RCSYSTEM, Memc[str]) + + call clcpset (pp) + + call sfree (sp) +end + + +# AT_GFSPSET -- Read in the input catalog filtering / selection parameters. + +procedure at_gfspset (psetname, at) + +char psetname[ARB] #I the input pset name +pointer at #I the pointer to the main astrom structure + +pointer sp, str, pp +int ival +pointer clopset() +int btoi(), strdic() +bool clgpsetb() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + pp = clopset (psetname) + + call clgpset (pp, "fields", Memc[str], SZ_LINE) + call at_sets (at, FIELDS, Memc[str]) + call clgpset (pp, "fexpr", Memc[str], SZ_LINE) + call at_sets (at, FEXPR, Memc[str]) + call clgpset (pp, "fnames", Memc[str], SZ_LINE) + call at_sets (at, FNAMES, Memc[str]) + call clgpset (pp, "fntypes", Memc[str], SZ_LINE) + call at_sets (at, FNTYPES, Memc[str]) + call clgpset (pp, "fnunits", Memc[str], SZ_LINE) + call at_sets (at, FNUNITS, Memc[str]) + call clgpset (pp, "fnformats", Memc[str], SZ_LINE) + call at_sets (at, FNFORMATS, Memc[str]) + + call clgpset (pp, "fsort", Memc[str], SZ_LINE) + call at_sets (at, FSORT, Memc[str]) + call at_seti (at, FREVERSE, btoi (clgpsetb (pp, "freverse"))) + + #call at_seti (at, FREPLACE, btoi (clgpsetb (pp, "freplace"))) + call clgpset (pp, "fosystem", Memc[str], SZ_LINE) + call at_sets (at, FOSYSTEM, Memc[str]) + + call clgpset (pp, "fira", Memc[str], SZ_LINE) + call at_sets (at, FIRA, Memc[str]) + call clgpset (pp, "fidec", Memc[str], SZ_LINE) + call at_sets (at, FIDEC, Memc[str]) + call clgpset (pp, "foraunits", Memc[str], SZ_LINE) + ival = strdic (Memc[str], Memc[str], SZ_FNAME, AT_RA_UNITS) + if (ival <= 0) + call at_seti (at, FORAUNITS, 0) + else + call at_seti (at, FORAUNITS, ival) + call clgpset (pp, "fodecunits", Memc[str], SZ_LINE) + ival = strdic (Memc[str], Memc[str], SZ_FNAME, AT_DEC_UNITS) + if (ival <= 0) + call at_seti (at, FODECUNITS, 0) + else + call at_seti (at, FODECUNITS, ival) + call clgpset (pp, "foraformat", Memc[str], SZ_LINE) + call at_sets (at, FORAFORMAT, Memc[str]) + call clgpset (pp, "fodecformat", Memc[str], SZ_LINE) + call at_sets (at, FODECFORMAT, Memc[str]) + + call clgpset (pp, "fixp", Memc[str], SZ_LINE) + call at_sets (at, FIXP, Memc[str]) + call clgpset (pp, "fiyp", Memc[str], SZ_LINE) + call at_sets (at, FIYP, Memc[str]) + call clgpset (pp, "fixc", Memc[str], SZ_LINE) + call at_sets (at, FIXC, Memc[str]) + call clgpset (pp, "fiyc", Memc[str], SZ_LINE) + call at_sets (at, FIYC, Memc[str]) + + call clgpset (pp, "foxformat", Memc[str], SZ_LINE) + call at_sets (at, FOXFORMAT, Memc[str]) + call clgpset (pp, "foyformat", Memc[str], SZ_LINE) + call at_sets (at, FOYFORMAT, Memc[str]) + + call clcpset (pp) + + call sfree (sp) +end + + +# AT_GWCPSET -- Read in the default image wcs parameters. + +procedure at_gwcpset (psetname, at) + +char psetname[ARB] #I the input pset name +pointer at #I the pointer to the main astrom structure + +double dval +pointer sp, str, pp, st, sym +int ip, ival +pointer clopset(), stopen(), stenter() +int ctod(), strdic() +bool streq() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + st = stopen ("wcslist", 2 * DEF_LEN_WCST, DEF_LEN_WCST, + 10 * DEF_LEN_WCST) + call at_setp (at, WCST, st) + + pp = clopset (psetname) + + call clgpset (pp, "wxref", Memc[str], SZ_LINE) + sym = stenter (st, "wxref", LEN_WCST_STRUCT) + call strcpy (Memc[str], AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod (Memc[str], ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WXREF, dval) + + call clgpset (pp, "wyref", Memc[str], SZ_LINE) + sym = stenter (st, "wyref", LEN_WCST_STRUCT) + call strcpy (Memc[str], AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod (Memc[str], ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WYREF, dval) + + call clgpset (pp, "wxmag", Memc[str], SZ_LINE) + sym = stenter (st, "wxmag", LEN_WCST_STRUCT) + call strcpy (Memc[str], AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod (Memc[str], ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WXMAG, dval) + + call clgpset (pp, "wymag", Memc[str], SZ_LINE) + sym = stenter (st, "wymag", LEN_WCST_STRUCT) + call strcpy (Memc[str], AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod (Memc[str], ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WYMAG, dval) + + call clgpset (pp, "wxrot", Memc[str], SZ_LINE) + sym = stenter (st, "wxrot", LEN_WCST_STRUCT) + call strcpy (Memc[str], AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod (Memc[str], ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WXROT, dval) + + call clgpset (pp, "wyrot", Memc[str], SZ_LINE) + sym = stenter (st, "wyrot", LEN_WCST_STRUCT) + call strcpy (Memc[str], AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod (Memc[str], ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WYROT, dval) + + call clgpset (pp, "wraref", Memc[str], SZ_LINE) + sym = stenter (st, "wraref", LEN_WCST_STRUCT) + call strcpy (Memc[str], AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod (Memc[str], ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WRAREF, dval) + + call clgpset (pp, "wdecref", Memc[str], SZ_LINE) + sym = stenter (st, "wdecref", LEN_WCST_STRUCT) + call strcpy (Memc[str], AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ip = 1 + if (ctod (Memc[str], ip, dval) <= 0) + dval = INDEFD + call at_setd (at, WDECREF, dval) + + call clgpset (pp, "wraunits", Memc[str], SZ_LINE) + sym = stenter (st, "wraunits", LEN_WCST_STRUCT) + call strcpy (Memc[str], AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ival = strdic (Memc[str], Memc[str], SZ_FNAME, AT_RA_UNITS) + if (ival <= 0) + call at_seti (at, WRAUNITS, 0) + else + call at_seti (at, WRAUNITS, ival) + + call clgpset (pp, "wdecunits", Memc[str], SZ_LINE) + sym = stenter (st, "wdecunits", LEN_WCST_STRUCT) + call strcpy (Memc[str], AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + ival = strdic (Memc[str], Memc[str], SZ_FNAME, AT_DEC_UNITS) + if (ival <= 0) + call at_seti (at, WDECUNITS, 0) + else + call at_seti (at, WDECUNITS, ival) + + call clgpset (pp, "wproj", Memc[str], SZ_LINE) + sym = stenter (st, "wproj", LEN_WCST_STRUCT) + call strcpy (Memc[str], AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + if (streq (Memc[str], "INDEF")) + call at_sets (at, WPROJ, "tan") + else + call at_sets (at, WPROJ, Memc[str]) + + call clgpset (pp, "wsystem", Memc[str], SZ_LINE) + sym = stenter (st, "wsystem", LEN_WCST_STRUCT) + call strcpy (Memc[str], AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + if (streq (Memc[str], "INDEF")) + call at_sets (at, WSYSTEM, "J2000") + else + call at_sets (at, WSYSTEM, Memc[str]) + + call clcpset (pp) + + call sfree (sp) +end + + + +# AT_GIMPSET -- Read in the default image data parameters. + +procedure at_gimpset (psetname, at) + +char psetname[ARB] #I the input pset name +pointer at #I the pointer to the main astrom structure + +double dval +real rval +pointer sp, str, pp, st, sym +int ip +pointer clopset(), stopen(), stenter() +int ctod(), ctor() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + pp = clopset (psetname) + st = stopen ("imlist", 2 * DEF_LEN_IMST, DEF_LEN_IMST, + 10 * DEF_LEN_IMST) + call at_setp (at, IMST, st) + + call clgpset (pp, "esitelng", Memc[str], SZ_LINE) + sym = stenter (st, "esitelng", LEN_IMST_STRUCT) + call strcpy (Memc[str], AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctod (Memc[str], ip, dval) <= 0) + dval = INDEFD + call at_setd (at, ESITELNG, dval) + + call clgpset (pp, "esitelat", Memc[str], SZ_LINE) + sym = stenter (st, "esitelat", LEN_IMST_STRUCT) + call strcpy (Memc[str], AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctod (Memc[str], ip, dval) <= 0) + dval = INDEFD + call at_setd (at, ESITELAT, dval) + + call clgpset (pp, "esitealt", Memc[str], SZ_LINE) + sym = stenter (st, "esitealt", LEN_IMST_STRUCT) + call strcpy (Memc[str], AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor (Memc[str], ip, rval) <= 0) + rval = INDEFR + call at_setr (at, ESITEALT, rval) + + call clgpset (pp, "esitetz", Memc[str], SZ_LINE) + sym = stenter (st, "esitetz", LEN_IMST_STRUCT) + call strcpy (Memc[str], AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor (Memc[str], ip, rval) <= 0) + rval = INDEFR + call at_setr (at, ESITETZ, rval) + + call clgpset (pp, "emjdobs", Memc[str], SZ_LINE) + sym = stenter (st, "emjdobs", LEN_IMST_STRUCT) + call strcpy (Memc[str], AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctod (Memc[str], ip, dval) <= 0) + dval = INDEFD + call at_setd (at, EMJDOBS, dval) + + call clgpset (pp, "edatamin", Memc[str], SZ_LINE) + sym = stenter (st, "edatamin", LEN_IMST_STRUCT) + call strcpy (Memc[str], AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor (Memc[str], ip, rval) <= 0) + rval = INDEFR + call at_setr (at, EDATAMIN, rval) + + call clgpset (pp, "edatamax", Memc[str], SZ_LINE) + sym = stenter (st, "edatamax", LEN_IMST_STRUCT) + call strcpy (Memc[str], AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor (Memc[str], ip, rval) <= 0) + rval = INDEFR + call at_setr (at, EDATAMAX, rval) + + call clgpset (pp, "egain", Memc[str], SZ_LINE) + sym = stenter (st, "egain", LEN_IMST_STRUCT) + call strcpy (Memc[str], AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor (Memc[str], ip, rval) <= 0) + rval = INDEFR + call at_setr (at, EGAIN, rval) + + call clgpset (pp, "erdnoise", Memc[str], SZ_LINE) + sym = stenter (st, "erdnoise", LEN_IMST_STRUCT) + call strcpy (Memc[str], AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor (Memc[str], ip, rval) <= 0) + rval = INDEFR + call at_setr (at, ERDNOISE, rval) + + call clgpset (pp, "ewavlen", Memc[str], SZ_LINE) + sym = stenter (st, "ewavlen", LEN_IMST_STRUCT) + call strcpy (Memc[str], AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor (Memc[str], ip, rval) <= 0) + rval = INDEFR + call at_setr (at, EWAVLEN, rval) + + call clgpset (pp, "etemp", Memc[str], SZ_LINE) + sym = stenter (st, "etemp", LEN_IMST_STRUCT) + call strcpy (Memc[str], AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor (Memc[str], ip, rval) <= 0) + rval = INDEFR + call at_setr (at, ETEMP, rval) + + call clgpset (pp, "epress", Memc[str], SZ_LINE) + sym = stenter (st, "epress", LEN_IMST_STRUCT) + call strcpy (Memc[str], AT_IMSTKVAL(sym), LEN_IMST_STRUCT) + ip = 1 + if (ctor (Memc[str], ip, rval) <= 0) + rval = INDEFR + call at_setr (at, EPRESS, rval) + + call clgpset (pp, "observat", Memc[str], SZ_LINE) + sym = stenter (st, "observat", LEN_WCST_STRUCT) + call strcpy (Memc[str], AT_WCSTKVAL(sym), LEN_WCST_STRUCT) + call at_sets (at, OBSERVAT, Memc[str]) + + + call clcpset (pp) + + call sfree (sp) +end diff --git a/noao/astcat/src/attools/atoutpars.x b/noao/astcat/src/attools/atoutpars.x new file mode 100644 index 00000000..6c2bf213 --- /dev/null +++ b/noao/astcat/src/attools/atoutpars.x @@ -0,0 +1,258 @@ +include "../../lib/astrom.h" +include "../../lib/acatalog.h" +include "../../lib/aimpars.h" + + +# AT_PRCPSET -- Write the current parameter values out to the region +# parameters set. + +procedure at_prcpset (psetname, at) + +char psetname[ARB] #I the parameter set name +pointer at #I the pointer to the main astrom structure + +pointer sp, str, pp +int ival +double at_statd() +pointer clopset() +int at_wrdstr(), at_stati() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + pp = clopset ("psetname") + + # Update the field center and field width parameters. + call clppsetd (pp, "rcra", at_statd (at, RCRA)) + call clppsetd (pp, "rcdec", at_statd (at, RCDEC)) + call clppsetd (pp, "rrawidth", at_statd (at, RCRAWIDTH)) + call clppsetd (pp, "rdecwidth", at_statd (at, RCDECWIDTH)) + + # Update the units parameters. + ival = at_stati (at, RCRAUNITS) + if (ival <= 0) + Memc[str] = EOS + else if (at_wrdstr (ival, Memc[str], SZ_FNAME, AT_RA_UNITS) <= 0) + Memc[str] = EOS + call clppset (pp, "rcraunits", Memc[str]) + + ival = at_stati (at, RCDECUNITS) + if (ival <= 0) + Memc[str] = EOS + else if (at_wrdstr (ival, Memc[str], SZ_FNAME, AT_DEC_UNITS) <= 0) + Memc[str] = EOS + call clppset (pp, "rcdecunits", Memc[str]) + + # Update the celestial coordinate system. + call at_stats (at, RCSYSTEM, Memc[str], SZ_FNAME) + call clppset (pp, "rcsystem", Memc[str]) + + call clcpset (pp) + + call sfree (sp) +end + + +# AT_PFSPSET -- Write the current parameter values out to the filtering +# parameters parameter set. + +procedure at_pfspset (psetname, at) + +char psetname[ARB] #I the parameter set name +pointer at #I the pointer to the main astrom structure + +pointer sp, str, pp +int ival +pointer clopset() +int at_stati(), at_wrdstr() +bool itob() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + pp = clopset ("psetname") + + call at_stats (pp, FIELDS, Memc[str], SZ_LINE) + call clppset (pp, "fields", Memc[str]) + call at_stats (pp, FEXPR, Memc[str], SZ_LINE) + call clppset (pp, "fexpr", Memc[str]) + call at_stats (pp, FNAMES, Memc[str], SZ_LINE) + call clppset (pp, "fnames", Memc[str]) + call at_stats (pp, FNTYPES, Memc[str], SZ_LINE) + call clppset (pp, "fntypes", Memc[str]) + call at_stats (pp, FNUNITS, Memc[str], SZ_LINE) + call clppset (pp, "fnunits", Memc[str]) + call at_stats (pp, FNFORMATS, Memc[str], SZ_LINE) + call clppset (pp, "fnformats", Memc[str]) + + call at_stats (pp, FSORT, Memc[str], SZ_LINE) + call clppset (pp, "fsort", Memc[str]) + call clppsetb (pp, "freverse", itob(at_stati(at,FREVERSE))) + + #call clppsetb (pp, "freplace", itob(at_stati(at,FREPLACE))) + call at_stats (pp, FOSYSTEM, Memc[str], SZ_LINE) + call clppset (pp, "fosystem", Memc[str]) + call at_stats (pp, FIRA, Memc[str], SZ_LINE) + call clppset (pp, "fira", Memc[str]) + call at_stats (pp, FIDEC, Memc[str], SZ_LINE) + call clppset (pp, "fidec", Memc[str]) + ival = at_wrdstr (at_stati(at,FORAUNITS), Memc[str], SZ_FNAME, + AT_RA_UNITS) + if (ival <= 0) + call clppset (pp, "foraunits", "") + else + call clppset (pp, "foraunits", Memc[str]) + ival = at_wrdstr (at_stati(at,FODECUNITS), Memc[str], SZ_FNAME, + AT_DEC_UNITS) + if (ival <= 0) + call clppset (pp, "fodecunits", "") + else + call clppset (pp, "fodecunits", Memc[str]) + call at_stats (pp, FORAFORMAT, Memc[str], SZ_LINE) + call clppset (pp, "foraformats", Memc[str]) + call at_stats (pp, FODECFORMAT, Memc[str], SZ_LINE) + call clppset (pp, "fodecformats", Memc[str]) + + call at_stats (pp, FIXP, Memc[str], SZ_LINE) + call clppset (pp, "fixp", Memc[str]) + call at_stats (pp, FIYP, Memc[str], SZ_LINE) + call clppset (pp, "fiyp", Memc[str]) + call at_stats (pp, FIXC, Memc[str], SZ_LINE) + call clppset (pp, "fixc", Memc[str]) + call at_stats (pp, FIYC, Memc[str], SZ_LINE) + call clppset (pp, "fiyc", Memc[str]) + call at_stats (pp, FOXFORMAT, Memc[str], SZ_LINE) + call clppset (pp, "foxformat", Memc[str]) + call at_stats (pp, FOYFORMAT, Memc[str], SZ_LINE) + call clppset (pp, "foyformat", Memc[str]) + + call clcpset (pp) + + call sfree (sp) +end + + +# AT_PWCPSET -- Write the current parameter values out to the default WCS +# parameters parameter set. + +procedure at_pwcpset (psetname, at) + +char psetname[ARB] #I the parameter set name +pointer at #I the pointer to the main astrom structure + +pointer pp, st, sym +pointer clopset(), at_statp(), stfind() + + +begin + pp = clopset ("psetname") + st = at_statp (at, WCST) + + sym = stfind (st, "wxref") + call clppset (pp, "wxref", AT_WCSTKVAL(sym)) + + sym = stfind (st, "wyref") + call clppset (pp, "wyref", AT_WCSTKVAL(sym)) + + sym = stfind (st, "wxmag") + call clppset (pp, "wxmag", AT_WCSTKVAL(sym)) + + sym = stfind (st, "wymag") + call clppset (pp, "wymag", AT_WCSTKVAL(sym)) + + sym = stfind (st, "wxrot") + call clppset (pp, "wxrot", AT_WCSTKVAL(sym)) + + sym = stfind (st, "wyrot") + call clppset (pp, "wyrot", AT_WCSTKVAL(sym)) + + sym = stfind (st, "wraref") + call clppset (pp, "wraref", AT_WCSTKVAL(sym)) + + sym = stfind (st, "wdecref") + call clppset (pp, "wdecref", AT_WCSTKVAL(sym)) + + sym = stfind (st, "wraunits") + call clppset (pp, "wraunits", AT_WCSTKVAL(sym)) + + sym = stfind (st, "wdecunits") + call clppset (pp, "wdecunits", AT_WCSTKVAL(sym)) + + sym = stfind (st, "wproj") + call clppset (pp, "wproj", AT_WCSTKVAL(sym)) + + sym = stfind (st, "wsystem") + call clppset (pp, "wsystem", AT_WCSTKVAL(sym)) + + call clcpset (pp) +end + + +# AT_PIMPSET -- Write the current parameter values out to the default WCS +# parameters parameter set. + +procedure at_pimpset (psetname, at) + +char psetname[ARB] #I the parameter set name +pointer at #I the pointer to the main astrom structure + +pointer pp, st, sym +pointer clopset(), at_statp(), stfind() + + +begin + pp = clopset ("psetname") + st = at_statp (at, IMST) + + sym = stfind (st, "esitelng") + call clppset (pp, "esitelng", AT_IMSTKVAL(sym)) + + sym = stfind (st, "esitelat") + call clppset (pp, "esitelat", AT_IMSTKVAL(sym)) + + sym = stfind (st, "emjdobs") + call clppset (pp, "emjdobs", AT_IMSTKVAL(sym)) + + #sym = stfind (st, "ut") + #call clppset (pp, "ut", AT_IMSTKVAL(sym)) + + sym = stfind (st, "esitealt") + call clppset (pp, "esitealt", AT_IMSTKVAL(sym)) + + sym = stfind (st, "esitetz") + call clppset (pp, "esitetz", AT_IMSTKVAL(sym)) + + #sym = stfind (st, "exposure") + #call clppset (pp, "exposure", AT_IMSTKVAL(sym)) + + sym = stfind (st, "edatamin") + call clppset (pp, "edatamin", AT_IMSTKVAL(sym)) + + sym = stfind (st, "edatamax") + call clppset (pp, "edatamax", AT_IMSTKVAL(sym)) + + sym = stfind (st, "egain") + call clppset (pp, "egain", AT_IMSTKVAL(sym)) + + sym = stfind (st, "erdnoise") + call clppset (pp, "erdnoise", AT_IMSTKVAL(sym)) + + sym = stfind (st, "ewavlen") + call clppset (pp, "ewavlen", AT_IMSTKVAL(sym)) + + sym = stfind (st, "etemp") + call clppset (pp, "etemp", AT_IMSTKVAL(sym)) + + sym = stfind (st, "epress") + call clppset (pp, "epress", AT_IMSTKVAL(sym)) + + sym = stfind (st, "observat") + call clppset (pp, "observat", AT_IMSTKVAL(sym)) + + #sym = stfind (st, "dateobs") + #call clppset (pp, "dateobs", AT_IMSTKVAL(sym)) + + call clcpset (pp) +end diff --git a/noao/astcat/src/attools/atset.x b/noao/astcat/src/attools/atset.x new file mode 100644 index 00000000..882fe13a --- /dev/null +++ b/noao/astcat/src/attools/atset.x @@ -0,0 +1,509 @@ +include "../../lib/astromdef.h" +include "../../lib/astrom.h" +include "../../lib/aimparsdef.h" +include "../../lib/aimpars.h" + +# AT_SETI -- Set the value of an astrom integer parameter. + +procedure at_seti (at, parameter, value) + +pointer at #I the pointer to the main astrom structure +int parameter #I the parameter to be set +int value #I the value of the parameter to be set + +pointer fcp, fsp, wcp +string iestring "AT_SETI: Cannot set undefined integer parameter" + +begin + fcp = AT_PRCENTER(at) + fsp = AT_PFILTER(at) + wcp = AT_PWCS(at) + + switch (parameter) { + + case RCRAUNITS: + if (fcp == NULL) + call error (0, iestring) + else + AT_RCRAUNITS(fcp) = value + case RCDECUNITS: + if (fcp == NULL) + call error (0, iestring) + else + AT_RCDECUNITS(fcp) = value + + + case FREVERSE: + if (fsp == NULL) + call error (0, iestring) + else + AT_FREVERSE(fsp) = value + case FREPLACE: + if (fsp == NULL) + call error (0, iestring) + else + AT_FREPLACE(fsp) = value + case FORAUNITS: + if (fsp == NULL) + call error (0, iestring) + else + AT_FORAUNITS(fsp) = value + case FODECUNITS: + if (fsp == NULL) + call error (0, iestring) + else + AT_FODECUNITS(fsp) = value + + case WRAUNITS: + if (wcp == NULL) + call error (0, iestring) + else + AT_WRAUNITS(wcp) = value + case WDECUNITS: + if (wcp == NULL) + call error (0, iestring) + else + AT_WDECUNITS(wcp) = value + + default: + call error (0, iestring) + } +end + + +# AT_SETP -- Set the value of an astrom pointer parameter. + +procedure at_setp (at, parameter, value) + +pointer at #I the pointer to the main astrom structure +int parameter #I the parameter to be set +pointer value #I the value of the parameter to be set + +pointer fcp, wcp, ipp +string pestring "AT_SETP: Cannot set undefined pointer parameter" + +begin + fcp = AT_PRCENTER(at) + wcp = AT_PWCS(at) + ipp = AT_PIMPARS(at) + + switch (parameter) { + case PIO: + AT_PIO(at) = value + case PRCENTER: + AT_PRCENTER(at) = value + case PFILTER: + AT_PFILTER(at) = value + case PWCS: + AT_PWCS(at) = value + case PIMPARS: + AT_PIMPARS(at) = value + + #case RCCC: + #AT_RCCC(fcp) = value + case RCST: + if (fcp == NULL) + call error (0, pestring) + else + AT_RCST(fcp) = value + + case WCST: + if (wcp == NULL) + call error (0, pestring) + else + AT_WCST(wcp) = value + + case IMST: + if (ipp == NULL) + call error (0, pestring) + else + AT_IMST(ipp) = value + + default: + call error (0, pestring) + } +end + + +# AT_SETR -- Set the value of an astrom real parameter. + +procedure at_setr (at, parameter, value) + +pointer at #I the pointer to the main astrom structure +int parameter #I the parameter to be set +real value #I the value of the parameter to be set + +pointer fcp, ipp +string restring "AT_SETR: Cannot set undefined real parameter" + +begin + fcp = AT_PRCENTER(at) + ipp = AT_PIMPARS(at) + + switch (parameter) { + + case ESITEALT: + if (ipp == NULL) + call error (0, restring) + else + AT_ESITEALT(ipp) = value + case ESITETZ: + if (ipp == NULL) + call error (0, restring) + else + AT_ESITETZ(ipp) = value + case EDATAMIN: + if (ipp == NULL) + call error (0, restring) + else + AT_EDATAMIN(ipp) = value + case EDATAMAX: + if (ipp == NULL) + call error (0, restring) + else + AT_EDATAMAX(ipp) = value + case EGAIN: + if (ipp == NULL) + call error (0, restring) + else + AT_EGAIN(ipp) = value + case ERDNOISE: + if (ipp == NULL) + call error (0, restring) + else + AT_ERDNOISE(ipp) = value + case EWAVLEN: + if (ipp == NULL) + call error (0, restring) + else + AT_EWAVLEN(ipp) = value + case ETEMP: + if (ipp == NULL) + call error (0, restring) + else + AT_ETEMP(ipp) = value + case EPRESS: + if (ipp == NULL) + call error (0, restring) + else + AT_EPRESS(ipp) = value + + default: + call error (0, restring) + } +end + + +# AT_SETD -- Set the value of an astrom double parameter. + +procedure at_setd (at, parameter, value) + +pointer at #I the pointer to the main astrom structure +int parameter #I the parameter to be set +double value #I the value of the parameter to be set + +pointer fcp, wcp, ipp +string destring "AT_SETD: Cannot set undefined double parameter" + +begin + fcp = AT_PRCENTER(at) + wcp = AT_PWCS(at) + ipp = AT_PIMPARS(at) + + switch (parameter) { + + case RCRA: + if (fcp == NULL) + call error (0, destring) + else + AT_RCRA(fcp) = value + case RCDEC: + if (fcp == NULL) + call error (0, destring) + else + AT_RCDEC(fcp) = value + case RCRAWIDTH: + if (fcp == NULL) + call error (0, destring) + else + AT_RCRAWIDTH(fcp) = value + case RCDECWIDTH: + if (fcp == NULL) + call error (0, destring) + else + AT_RCDECWIDTH(fcp) = value + + case WXREF: + if (wcp == NULL) + call error (0, destring) + else + AT_WXREF(wcp) = value + case WYREF: + if (wcp == NULL) + call error (0, destring) + else + AT_WYREF(wcp) = value + case WXMAG: + if (wcp == NULL) + call error (0, destring) + else + AT_WXMAG(wcp) = value + case WYMAG: + if (wcp == NULL) + call error (0, destring) + else + AT_WYMAG(wcp) = value + case WXROT: + if (wcp == NULL) + call error (0, destring) + else + AT_WXROT(wcp) = value + case WYROT: + if (wcp == NULL) + call error (0, destring) + else + AT_WYROT(wcp) = value + case WRAREF: + if (wcp == NULL) + call error (0, destring) + else + AT_WRAREF(wcp) = value + case WDECREF: + if (wcp == NULL) + call error (0, destring) + else + AT_WDECREF(wcp) = value + + case ESITELNG: + if (ipp == NULL) + call error (0, destring) + else + AT_ESITELNG(ipp) = value + case ESITELAT: + if (ipp == NULL) + call error (0, destring) + else + AT_ESITELAT(ipp) = value + case EMJDOBS: + if (ipp == NULL) + call error (0, destring) + else + AT_EMJDOBS(ipp) = value + #case UT: + #if (ipp == NULL) + #call error (0, + #"AT_SETD: Cannot set undefined double parameter") + #else + #AT_UT(ipp) = value + + default: + call error (0, destring) + } +end + + +# AT_SETS -- Set the value of an astrom string parameter. + +procedure at_sets (at, parameter, value) + +pointer at #I the pointer to the main astrom structure +int parameter #I the parameter to be set +char value[ARB] #I the value of the parameter to be set + +pointer fcp, iop, fsp, wcp, ipp +string sestring "AT_SETS: Cannot set undefined string parameter" + +begin + iop = AT_PIO(at) + fcp = AT_PRCENTER(at) + fsp = AT_PFILTER(at) + wcp = AT_PWCS(at) + ipp = AT_PIMPARS(at) + + switch (parameter) { + + case CATALOGS: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (value, AT_CATALOGS(iop), SZ_FNAME) + case SURVEYS: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (value, AT_SURVEYS(iop), SZ_FNAME) + case IMAGES: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (value, AT_IMAGES(iop), SZ_FNAME) + case INPUT: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (value, AT_INPUT(iop), SZ_FNAME) + case OUTPUT: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (value, AT_OUTPUT(iop), SZ_FNAME) + case CATNAME: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (value, AT_CATNAME(iop), SZ_FNAME) + case SVNAME: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (value, AT_SVNAME(iop), SZ_FNAME) + case IMNAME: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (value, AT_IMNAME(iop), SZ_FNAME) + case INFNAME: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (value, AT_INFNAME(iop), SZ_FNAME) + case OUTFNAME: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (value, AT_OUTFNAME(iop), SZ_FNAME) + case CATDB: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (value, AT_CATDB(iop), SZ_FNAME) + case IMDB: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (value, AT_IMDB(iop), SZ_FNAME) + + case RCSYSTEM: + if (fcp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_RCSYSTEM(fcp), SZ_FNAME) + case RCSOURCE: + if (fcp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_RCSOURCE(fcp), SZ_FNAME) + + + case FSORT: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FSORT(fsp), SZ_FNAME) + case FOSYSTEM: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FOSYSTEM(fsp), SZ_FNAME) + case FIRA: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FIRA(fsp), SZ_FNAME) + case FIDEC: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FIDEC(fsp), SZ_FNAME) + case FORAFORMAT: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FORAFORMAT(fsp), SZ_FNAME) + case FODECFORMAT: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FODECFORMAT(fsp), SZ_FNAME) + case FIXP: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FIXP(fsp), SZ_FNAME) + case FIYP: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FIYP(fsp), SZ_FNAME) + case FIXC: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FIXC(fsp), SZ_FNAME) + case FIYC: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FIYC(fsp), SZ_FNAME) + case FOXFORMAT: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FOXFORMAT(fsp), SZ_FNAME) + case FOYFORMAT: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FOYFORMAT(fsp), SZ_FNAME) + case FIELDS: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FIELDS(fsp), SZ_FNAME) + case FEXPR: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FEXPR(fsp), SZ_FNAME) + case FNAMES: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FNAMES(fsp), SZ_FNAME) + case FNTYPES: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FNTYPES(fsp), SZ_FNAME) + case FNUNITS: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FNUNITS(fsp), SZ_FNAME) + case FNFORMATS: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_FNFORMATS(fsp), SZ_FNAME) + + case WPROJ: + if (wcp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_WPROJ(wcp), SZ_FNAME) + case WSYSTEM: + if (wcp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_WSYSTEM(wcp), SZ_FNAME) + + case OBSERVAT: + if (ipp == NULL) + call error (0, sestring) + else + call strcpy (value, AT_OBSERVAT(ipp), SZ_FNAME) + + default: + call error (0, sestring) + } +end diff --git a/noao/astcat/src/attools/atshow.x b/noao/astcat/src/attools/atshow.x new file mode 100644 index 00000000..e3a9b26b --- /dev/null +++ b/noao/astcat/src/attools/atshow.x @@ -0,0 +1,375 @@ +include "../../lib/astrom.h" +include "../../lib/acatalog.h" +include "../../lib/aimpars.h" + +# AT_IMSHOW -- Print the current default WCS parameters. + +procedure at_imshow (at) + +pointer at #I the astrometry package descriptor + +pointer sp, str1, str2 +double at_statd() +real at_statr() +pointer at_statp() + +begin + if (at_statp(at, PIMPARS) == NULL) + return + + call smark (sp) + call salloc (str1, SZ_FNAME, TY_CHAR) + call salloc (str2, SZ_FNAME, TY_CHAR) + + call printf ("\nDefault Image Data Parameters\n") + call at_stats (at, OBSERVAT, Memc[str1], SZ_FNAME) + call printf (" The observatory id: %s MJD: %0.5f\n") + call pargstr (Memc[str1]) + call pargd (at_statd (at, EMJDOBS)) + call printf ( + " The site longitude and latitude: %0.2h %0.2h (degrees degrees)\n") + call pargd (at_statd(at, ESITELNG)) + call pargd (at_statd(at, ESITELAT)) + call printf ( + " The site altitude and time zone: %0.1f %0.1f (m hours)\n") + call pargr (at_statr(at, ESITEALT)) + call pargr (at_statr(at, ESITETZ)) + call printf ( + " Effective wavelength: %0.2f (microns)\n") + call pargr (at_statr (at, EWAVLEN)) + call printf ( + " Effective tempaerature and pressure: %0.2f %0.2f (K mbars)\n") + call pargr (at_statr (at, ETEMP)) + call pargr (at_statr (at, EPRESS)) + call printf ( + " Effective gain and readout noise: %0.2f %0.2f (e-/ADU e-)\n") + call pargr (at_statr (at, EGAIN)) + call pargr (at_statr (at, ERDNOISE)) + call printf ( + " Low and high good data limits: %0.2f %0.2f (ADU ADU)\n") + call pargr (at_statr (at, EDATAMIN)) + call pargr (at_statr (at, EDATAMAX)) + + call sfree (sp) +end + + +# AT_WCSHOW -- Print the current default WCS parameters. + +procedure at_wcshow (at) + +pointer at #I the astrometry package descriptor + +pointer sp, str1, str2 +int ival +double at_statd() +pointer at_statp() +int at_stati(), at_wrdstr() + +begin + if (at_statp(at, PWCS) == NULL) + return + + call smark (sp) + call salloc (str1, SZ_FNAME, TY_CHAR) + call salloc (str2, SZ_FNAME, TY_CHAR) + + call printf ("\nDefault WCS Parameters\n") + call at_stats (at, WPROJ, Memc[str1], SZ_FNAME) + call printf (" Sky projection geometry: %s\n") + call pargstr (Memc[str1]) + ival = at_stati (at, WRAUNITS) + if (ival <= 0) + #Memc[str1] = EOS + call strcpy ("default", Memc[str1], SZ_FNAME) + else if (at_wrdstr (ival, Memc[str1], SZ_FNAME, AT_RA_UNITS) <= 0) + #Memc[str1] = EOS + call strcpy ("default", Memc[str1], SZ_FNAME) + ival = at_stati (at, WDECUNITS) + if (ival <= 0) + #Memc[str2] = EOS + call strcpy ("default", Memc[str2], SZ_FNAME) + else if (at_wrdstr (ival, Memc[str2], SZ_FNAME, AT_DEC_UNITS) <= 0) + #Memc[str2] = EOS + call strcpy ("default", Memc[str2], SZ_FNAME) + call printf (" Reference point: %0.3h %0.2h (%s %s)\n") + call pargd (at_statd(at, WRAREF)) + call pargd (at_statd(at, WDECREF)) + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call printf (" Reference point: %0.3f %0.3f (pixels pixels)\n") + call pargd (at_statd(at, WXREF)) + call pargd (at_statd(at, WYREF)) + call printf ( + " X and Y scale: %0.3f %0.3f (arcsec/pixel arsec/pixel)\n") + call pargd (at_statd(at, WXMAG)) + call pargd (at_statd(at, WYMAG)) + call printf ( + " X and Y axis rotation: %0.3f %0.3f (degrees degrees)\n") + call pargd (at_statd(at, WXROT)) + call pargd (at_statd(at, WYROT)) + call at_stats (at, WSYSTEM, Memc[str1], SZ_FNAME) + call printf (" System: %s\n") + call pargstr (Memc[str1]) + + call sfree (sp) +end + + +# AT_IOSHOW -- Print the current i/o parameters. + +procedure at_ioshow (at) + +pointer at #I the astrometry package descriptor + +pointer sp, str1, str2 +pointer at_statp() + +begin + if (at_statp(at, PIO) == NULL) + return + + call smark (sp) + call salloc (str1, SZ_FNAME, TY_CHAR) + call salloc (str2, SZ_FNAME, TY_CHAR) + + call printf ("\nI/O Parameters\n") + + call at_stats (at, CATDB, Memc[str1], SZ_FNAME) + call printf (" catdb = %s\n") + call pargstr (Memc[str1]) + call at_stats (at, CATALOGS, Memc[str1], SZ_FNAME) + call at_stats (at, CATNAME, Memc[str2], SZ_FNAME) + call printf (" catalog = %s catname = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + + call at_stats (at, IMDB, Memc[str1], SZ_FNAME) + call printf (" imdb = %s\n") + call pargstr (Memc[str1]) + call at_stats (at, SURVEYS, Memc[str1], SZ_FNAME) + call at_stats (at, SVNAME, Memc[str2], SZ_FNAME) + call printf (" survey = %s svname = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + + call at_stats (at, IMAGES, Memc[str1], SZ_FNAME) + call at_stats (at, IMNAME, Memc[str2], SZ_FNAME) + call printf (" images = %s imname = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + + call at_stats (at, INPUT, Memc[str1], SZ_FNAME) + call at_stats (at, INFNAME, Memc[str2], SZ_FNAME) + call printf (" input = %s infname = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + + call at_stats (at, OUTPUT, Memc[str1], SZ_FNAME) + call at_stats (at, OUTFNAME, Memc[str2], SZ_FNAME) + call printf (" output = %s outfname = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + + call sfree (sp) +end + + +# AT_RCSHOW -- Print the current field center parameters. + +procedure at_rcshow (at) + +pointer at #I the astrometry package descriptor + +pointer sp, str1, str2 +int ival +double at_statd() +pointer at_statp() +int at_wrdstr(), at_stati() + +begin + if (at_statp(at, PRCENTER) == NULL) + return + + call smark (sp) + call salloc (str1, SZ_FNAME, TY_CHAR) + call salloc (str2, SZ_FNAME, TY_CHAR) + + call printf ("\nField Center Parameters\n") + call at_stats (at, RCSOURCE, Memc[str1], SZ_FNAME) + call at_stats (at, RCSYSTEM, Memc[str2], SZ_FNAME) + call printf (" rcsource = %s rcsystem = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + + call printf (" rcra = %h rcdec = %h\n") + call pargd (at_statd (at, RCRA)) + call pargd (at_statd (at, RCDEC)) + call printf (" rrawidth = %0.2f rdecwidth = %0.2f\n") + call pargd (at_statd (at, RCRAWIDTH)) + call pargd (at_statd (at, RCDECWIDTH)) + + ival = at_stati (at, RCRAUNITS) + if (ival <= 0) + #Memc[str1] = EOS + call strcpy ("default", Memc[str1], SZ_FNAME) + else if (at_wrdstr (ival, Memc[str1], SZ_FNAME, AT_RA_UNITS) <= 0) + #Memc[str1] = EOS + call strcpy ("default", Memc[str1], SZ_FNAME) + ival = at_stati (at, RCDECUNITS) + if (ival <= 0) + #Memc[str2] = EOS + call strcpy ("default", Memc[str2], SZ_FNAME) + else if (at_wrdstr (ival, Memc[str2], SZ_FNAME, AT_DEC_UNITS) <= 0) + #Memc[str2] = EOS + call strcpy ("default", Memc[str2], SZ_FNAME) + call printf (" rcraunits = %s rcdecunits = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + + call printf ("\n") + + call sfree (sp) +end + + +# AT_FSSHOW -- Print the current filtering parameters. + +procedure at_fsshow (at) + +pointer at #I the astrometry package descriptor + +pointer sp, str1, str2 +int ival +pointer at_statp() +int at_stati(), at_wrdstr() +bool itob() + +begin + if (at_statp(at, PFILTER) == NULL) + return + + call smark (sp) + call salloc (str1, SZ_FNAME, TY_CHAR) + call salloc (str2, SZ_FNAME, TY_CHAR) + + call printf ("\nRecord Filtering Parameters\n") + call at_stats (at, FIELDS, Memc[str1], SZ_FNAME) + call at_stats (at, FEXPR, Memc[str2], SZ_FNAME) + call printf (" fields = %s fexpr = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call at_stats (at, FNAMES, Memc[str1], SZ_FNAME) + call at_stats (at, FNTYPES, Memc[str2], SZ_FNAME) + call printf (" fnames = %s fntypes = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call at_stats (at, FNUNITS, Memc[str1], SZ_FNAME) + call at_stats (at, FNFORMATS, Memc[str2], SZ_FNAME) + call printf (" fnunits = %s fnformats = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + + call at_stats (at, FSORT, Memc[str1], SZ_FNAME) + call printf (" fsort = %s freverse = %b\n") + call pargstr (Memc[str1]) + call pargb (itob(at_stati(at, FREVERSE))) + + call at_stats (at, FOSYSTEM, Memc[str1], SZ_FNAME) + call printf (" freplace = %b fosystem = %s\n") + call pargb (itob(at_stati(at, FREPLACE))) + call pargstr (Memc[str1]) + call at_stats (at, FIRA, Memc[str1], SZ_FNAME) + call at_stats (at, FIDEC, Memc[str2], SZ_FNAME) + call printf (" fira = %s fidec = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + + ival = at_stati (at, FORAUNITS) + if (ival <= 0) + Memc[str1] = EOS + else if (at_wrdstr (ival, Memc[str1], SZ_FNAME, AT_RA_UNITS) <= 0) + Memc[str1] = EOS + ival = at_stati (at, FODECUNITS) + if (ival <= 0) + Memc[str2] = EOS + else if (at_wrdstr (ival, Memc[str2], SZ_FNAME, AT_DEC_UNITS) <= 0) + Memc[str2] = EOS + call printf (" foraunits = %s fodecunits = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call at_stats (at, FORAFORMAT, Memc[str1], SZ_FNAME) + call at_stats (at, FODECFORMAT, Memc[str2], SZ_FNAME) + call printf (" foraformat = %s fodecformat = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + + call at_stats (at, FIXP, Memc[str1], SZ_FNAME) + call at_stats (at, FIYP, Memc[str2], SZ_FNAME) + call printf (" fixp = %s fiyp = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call at_stats (at, FIXC, Memc[str1], SZ_FNAME) + call at_stats (at, FIYC, Memc[str2], SZ_FNAME) + call printf (" fixc = %s fiyc = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call at_stats (at, FOXFORMAT, Memc[str1], SZ_FNAME) + call at_stats (at, FOYFORMAT, Memc[str2], SZ_FNAME) + call printf (" foxformat = %s foyformat = %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + + call printf ("\n") + + call sfree (sp) +end + + +# AT_STSHOW -- Dump the contents of the field center symbol table + +procedure at_stshow (at) + +pointer at #I the astrometry package descriptor + +pointer st, symlist, symbol +int i, nfields +pointer at_statp(), sthead(), stnext() +int stnsymbols() + +begin + if (at_statp(at, PRCENTER) == NULL) + return + + st = at_statp(at, RCST) + if (st == NULL) + return + + nfields = stnsymbols (st, 0) + if (nfields <= 0) + return + + call malloc (symlist, nfields, TY_INT) + symbol = sthead (st) + do i = 1, nfields { + Memi[symlist+i-1] = symbol + symbol = stnext (st, symbol) + } + + do i = nfields, 1, -1 { + symbol = Memi[symlist+i-1] + call printf ("%s %s\n") + call pargstr (AT_RCSTSOURCE(symbol)) + call pargstr (AT_RCSTNAME(symbol)) + call printf (" %h %h %8.3f %8.3f %d %d %s\n") + call pargd (AT_RCSTRA(symbol)) + call pargd (AT_RCSTDEC(symbol)) + call pargd (AT_RCSTRAWIDTH(symbol)) + call pargd (AT_RCSTDECWIDTH(symbol)) + call pargi (AT_RCSTRAUNITS(symbol)) + call pargi (AT_RCSTDECUNITS(symbol)) + call pargstr (AT_RCSTSYSTEM(symbol)) + } + + call mfree (symlist, TY_INT) +end diff --git a/noao/astcat/src/attools/atsort.x b/noao/astcat/src/attools/atsort.x new file mode 100644 index 00000000..315e6d16 --- /dev/null +++ b/noao/astcat/src/attools/atsort.x @@ -0,0 +1,76 @@ +define LOGPTR 32 +define swap {temp=$1;$1=$2;$2=temp} + +# AT_SSQUICK -- Quicksort for text data. NOTE -- This algorithm is quadratic in +# the worst case, i.e., when the data is already sorted. A random method of +# selecting the pivot should be used to improve the behaviour on sorted arrays. + +procedure at_ssquick (linbuf, linptr, index, nlines) + +char linbuf[ARB] #I the input string buffer +int linptr[ARB] #U the indices of strings in buffer +int index[ARB] #O the output sort index +int nlines #I the number of strings + +int i, j, k, temp, lv[LOGPTR], p, pivlin, uv[LOGPTR] +int strncmp() + +begin + lv[1] = 1 + uv[1] = nlines + p = 1 + + do i = 1, nlines + index[i] = i + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy loop to trigger optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select pivot element at midpoint of interval to avoid + # quadratic behavior on a sorted list. + + k = (lv[p] + uv[p]) / 2 + swap (linptr[j], linptr[k]) + swap (index[j], index[k]) + pivlin = linptr[j] + while (i < j) { + for (i=i+1; strncmp (linbuf, linptr[i], pivlin) < 0; + i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (strncmp (linbuf, linptr[j], pivlin) <= 0) + break + if (i < j) { # out of order pair + swap (linptr[i], linptr[j]) + swap (index[i], index[j]) + } + + } + + j = uv[p] # move pivot to position i + swap (linptr[i], linptr[j]) + swap (index[i], index[j]) + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + + p = p + 1 # push onto stack + } + } +end diff --git a/noao/astcat/src/attools/atstat.x b/noao/astcat/src/attools/atstat.x new file mode 100644 index 00000000..7deb2e87 --- /dev/null +++ b/noao/astcat/src/attools/atstat.x @@ -0,0 +1,506 @@ +include "../../lib/astromdef.h" +include "../../lib/astrom.h" +include "../../lib/aimparsdef.h" +include "../../lib/aimpars.h" + + +# AT_STATI -- Get the value of an astrom integer parameter. + +int procedure at_stati (at, parameter) + +pointer at #I the pointer to the main astrom structure +int parameter #I the parameter to be set + +pointer fcp, fsp, wcp +string iestring "T_STATI: Cannot fetch undefined integer parameter" + +begin + fcp = AT_PRCENTER(at) + fsp = AT_PFILTER(at) + wcp = AT_PWCS(at) + + switch (parameter) { + + case RCRAUNITS: + if (fcp == NULL) + call error (0, iestring) + else + return (AT_RCRAUNITS(fcp)) + case RCDECUNITS: + if (fcp == NULL) + call error (0, iestring) + else + return (AT_RCDECUNITS(fcp)) + + case FREVERSE: + if (fsp == NULL) + call error (0, iestring) + else + return (AT_FREVERSE(fsp)) + case FREPLACE: + if (fsp == NULL) + call error (0, iestring) + else + return (AT_FREPLACE(fsp)) + case FORAUNITS: + if (fsp == NULL) + call error (0, iestring) + else + return (AT_FORAUNITS(fsp)) + case FODECUNITS: + if (fsp == NULL) + call error (0, iestring) + else + return (AT_FODECUNITS(fsp)) + + case WRAUNITS: + if (wcp == NULL) + call error (0, iestring) + else + return (AT_WRAUNITS(wcp)) + case WDECUNITS: + if (wcp == NULL) + call error (0, iestring) + else + return (AT_WDECUNITS(wcp)) + + default: + call error (0, "AT_STATI: Cannot fetch unknown integer parameter") + } +end + + +# AT_STATP -- Get the value of an astrom pointer parameter. + +pointer procedure at_statp (at, parameter) + +pointer at #I the pointer to the main astrom structure +int parameter #I the parameter to be set + +pointer fcp, fsp, wcp, ipp +string pestring "AT_STATP: Cannot fetch undefined pointer parameter" + +begin + fcp = AT_PRCENTER(at) + fsp = AT_PFILTER(at) + wcp = AT_PWCS(at) + ipp = AT_PIMPARS(at) + + switch (parameter) { + + case PIO: + return (AT_PIO(at)) + case PRCENTER: + return (AT_PRCENTER(at)) + case PFILTER: + return (AT_PFILTER(at)) + case PWCS: + return (AT_PWCS(at)) + case PIMPARS: + return (AT_PIMPARS(at)) + + #case RCCC: + #return (AT_RCCC(fcp)) + case RCST: + if (fcp == NULL) + call error (0, pestring) + else + return (AT_RCST(fcp)) + + case WCST: + if (wcp == NULL) + call error (0, pestring) + else + return (AT_WCST(wcp)) + + case IMST: + if (ipp == NULL) + call error (0, pestring) + else + return (AT_IMST(ipp)) + + default: + call error (0, pestring) + } +end + + +# AT_STATR -- Get the value of an astrom real parameter. + +real procedure at_statr (at, parameter) + +pointer at #I the pointer to the main astrom structure +int parameter #I the parameter to be set + +pointer fcp, ipp +string restring "AT_STATR: Cannot fetch undefined real parameter" + +begin + fcp = AT_PRCENTER(at) + ipp = AT_PIMPARS(at) + + switch (parameter) { + + case ESITEALT: + if (ipp == NULL) + call error (0, restring) + else + return (AT_ESITEALT(ipp)) + case ESITETZ: + if (ipp == NULL) + call error (0, restring) + else + return (AT_ESITETZ(ipp)) + #case EXPOSURE: + #if (ipp == NULL) + #call error (0, + #"AT_STATR: Cannot fetch undefined real parameter") + #else + #return (AT_EXPOSURE(ipp)) + case EDATAMIN: + if (ipp == NULL) + call error (0, restring) + else + return (AT_EDATAMIN(ipp)) + case EDATAMAX: + if (ipp == NULL) + call error (0, restring) + else + return (AT_EDATAMAX(ipp)) + case EGAIN: + if (ipp == NULL) + call error (0, restring) + else + return (AT_EGAIN(ipp)) + case ERDNOISE: + if (ipp == NULL) + call error (0, restring) + else + return (AT_ERDNOISE(ipp)) + case EWAVLEN: + if (ipp == NULL) + call error (0, restring) + else + return (AT_EWAVLEN(ipp)) + case ETEMP: + if (ipp == NULL) + call error (0, restring) + else + return (AT_ETEMP(ipp)) + case EPRESS: + if (ipp == NULL) + call error (0, restring) + else + return (AT_EPRESS(ipp)) + + default: + call error (0, restring) + } +end + + +# AT_STATD -- Get the value of an astrom double parameter. + +double procedure at_statd (at, parameter) + +pointer at #I the pointer to the main astrom structure +int parameter #I the parameter to be set + +pointer fcp, wcp, ipp +string destring "AT_STATD: Cannot fetch undefined double parameter" + +begin + fcp = AT_PRCENTER(at) + wcp = AT_PWCS(at) + ipp = AT_PIMPARS(at) + + switch (parameter) { + + case RCRA: + if (fcp == NULL) + call error (0, destring) + else + return (AT_RCRA(fcp)) + case RCDEC: + if (fcp == NULL) + call error (0, destring) + else + return (AT_RCDEC(fcp)) + case RCRAWIDTH: + if (fcp == NULL) + call error (0, destring) + else + return (AT_RCRAWIDTH(fcp)) + case RCDECWIDTH: + if (fcp == NULL) + call error (0, destring) + else + return (AT_RCDECWIDTH(fcp)) + + case WXREF: + if (wcp == NULL) + call error (0, destring) + else + return (AT_WXREF(wcp)) + case WYREF: + if (wcp == NULL) + call error (0, destring) + else + return (AT_WYREF(wcp)) + case WXMAG: + if (wcp == NULL) + call error (0, destring) + else + return (AT_WXMAG(wcp)) + case WYMAG: + if (wcp == NULL) + call error (0, destring) + else + return (AT_WXMAG(wcp)) + case WXROT: + if (wcp == NULL) + call error (0, destring) + else + return (AT_WXROT(wcp)) + case WYROT: + if (wcp == NULL) + call error (0, destring) + else + return (AT_WYROT(wcp)) + case WRAREF: + if (wcp == NULL) + call error (0, destring) + else + return (AT_WRAREF(wcp)) + case WDECREF: + if (wcp == NULL) + call error (0, destring) + else + return (AT_WDECREF(wcp)) + + case ESITELNG: + if (ipp == NULL) + call error (0, destring) + else + return (AT_ESITELNG(ipp)) + case ESITELAT: + if (ipp == NULL) + call error (0, destring) + else + return (AT_ESITELAT(ipp)) + case EMJDOBS: + if (ipp == NULL) + call error (0, destring) + else + return (AT_EMJDOBS(ipp)) + + default: + call error (0, destring) + } +end + + +# AT_STATS -- Get the value of an astrom string parameter. + +procedure at_stats (at, parameter, value, maxch) + +pointer at #I the pointer to the main astrom structure +int parameter #I the parameter to be set +char value[ARB] #O the value of the parameter to be set +int maxch #I the maximum number of characters + +pointer fcp, iop, fsp, wcp, ipp +string sestring "AT_STATS: Cannot fetch undefined string parameter" + +begin + iop = AT_PIO(at) + fcp = AT_PRCENTER(at) + fsp = AT_PFILTER(at) + wcp = AT_PWCS(at) + ipp = AT_PIMPARS(at) + + switch (parameter) { + + case CATALOGS: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (AT_CATALOGS(iop), value, maxch) + case SURVEYS: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (AT_SURVEYS(iop), value, maxch) + case IMAGES: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (AT_IMAGES(iop), value, maxch) + case INPUT: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (AT_INPUT(iop), value, maxch) + case OUTPUT: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (AT_OUTPUT(iop), value, maxch) + case CATNAME: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (AT_CATNAME(iop), value, maxch) + case SVNAME: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (AT_SVNAME(iop), value, maxch) + case IMNAME: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (AT_IMNAME(iop), value, maxch) + case INFNAME: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (AT_INFNAME(iop), value, maxch) + case OUTFNAME: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (AT_OUTFNAME(iop), value, maxch) + case CATDB: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (AT_CATDB(iop), value, maxch) + case IMDB: + if (iop == NULL) + call error (0, sestring) + else + call strcpy (AT_IMDB(iop), value, maxch) + + case RCSYSTEM: + if (fcp == NULL) + call error (0, sestring) + else + call strcpy (AT_RCSYSTEM(fcp), value, maxch) + case RCSOURCE: + if (fcp == NULL) + call error (0, sestring) + else + call strcpy (AT_RCSOURCE(fcp), value, maxch) + + case FSORT: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FSORT(fsp), value, maxch) + case FOSYSTEM: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FOSYSTEM(fsp), value, maxch) + case FIRA: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FIRA(fsp), value, maxch) + case FIDEC: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FIDEC(fsp), value, maxch) + case FORAFORMAT: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FORAFORMAT(fsp), value, maxch) + case FODECFORMAT: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FODECFORMAT(fsp), value, maxch) + case FIXP: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FIXP(fsp), value, maxch) + case FIYP: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FIYP(fsp), value, maxch) + case FIXC: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FIXC(fsp), value, maxch) + case FIYC: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FIYC(fsp), value, maxch) + case FOXFORMAT: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FOXFORMAT(fsp), value, maxch) + case FOYFORMAT: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FOYFORMAT(fsp), value, maxch) + case FIELDS: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FIELDS(fsp), value, maxch) + case FEXPR: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FEXPR(fsp), value, maxch) + case FNAMES: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FNAMES(fsp), value, maxch) + case FNTYPES: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FNTYPES(fsp), value, maxch) + case FNUNITS: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FNUNITS(fsp), value, maxch) + case FNFORMATS: + if (fsp == NULL) + call error (0, sestring) + else + call strcpy (AT_FNFORMATS(fsp), value, maxch) + + case WPROJ: + if (wcp == NULL) + call error (0, sestring) + else + call strcpy (AT_WPROJ(wcp), value, maxch) + case WSYSTEM: + if (wcp == NULL) + call error (0, sestring) + else + call strcpy (AT_WSYSTEM(wcp), value, maxch) + + case OBSERVAT: + if (ipp == NULL) + call error (0, sestring) + else + call strcpy (AT_OBSERVAT(ipp), value, maxch) + default: + call error (0, sestring) + } +end diff --git a/noao/astcat/src/attools/atvectors.x b/noao/astcat/src/attools/atvectors.x new file mode 100644 index 00000000..9d32967b --- /dev/null +++ b/noao/astcat/src/attools/atvectors.x @@ -0,0 +1,66 @@ +define LOGPTR 20 # log2(maxpts) (1e6) + +# AT_QSORTD -- Vector Quicksort. In this version the index array is sorted. +# The input and output index array may be the same. + +procedure at_qsortd (data, a, b, npix) + +double data[ARB] #I the input data array +int a[ARB] #I the input index array +int b[ARB] #O the output index array +int npix #I the number of pixels + +int i, j, lv[LOGPTR], p, uv[LOGPTR], temp +double pivot + +begin + # Initialize the indices for an inplace sort. + do i = 1, npix + a[i] = i + call amovi (a, b, npix) + + p = 1 + lv[1] = 1 + uv[1] = npix + while (p > 0) { + + # If only one elem in subset pop stack otherwise pivot line. + if (lv[p] >= uv[p]) + p = p - 1 + else { + i = lv[p] - 1 + j = uv[p] + pivot = data[b[j]] + + while (i < j) { + for (i=i+1; data[b[i]] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (data[b[j]] <= pivot) + break + if (i < j) { # out of order pair + temp = b[j] # interchange elements + b[j] = b[i] + b[i] = temp + } + } + + j = uv[p] # move pivot to position i + temp = b[j] # interchange elements + b[j] = b[i] + b[i] = temp + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + p = p + 1 # push onto stack + } + } +end diff --git a/noao/astcat/src/attools/atwrdstr.x b/noao/astcat/src/attools/atwrdstr.x new file mode 100644 index 00000000..934570da --- /dev/null +++ b/noao/astcat/src/attools/atwrdstr.x @@ -0,0 +1,57 @@ + +# AT_WRDSTR -- Search a dictionary string for a given string index number. +# This is the opposite function of strdic(), that returns the index for +# given string. The entries in the dictionary string are separated by +# a delimiter character which is the first character of the dictionary +# string. The index of the string found is returned as the function value. +# Otherwise, if there is no string for that index, a zero is returned. + +int procedure at_wrdstr (index, outstr, maxch, dict) + +int index # String index +char outstr[ARB] # Output string as found in dictionary +int maxch # Maximum length of output string +char dict[ARB] # Dictionary string + +int i, len, start, count + +int strlen() + +begin + # Clear output string + outstr[1] = EOS + + # Return if index is not positive. + if (index <= 0) + return (0) + + # Return if the dictionary is not long enough + if (dict[1] == EOS) + return (0) + + # Initialize counters + count = 1 + len = strlen (dict) + + # Search the dictionary string. This loop only terminates + # successfully if the index is found. Otherwise the procedure + # returns with and error condition. + for (start = 2; count < index; start = start + 1) { + if (dict[start] == dict[1]) + count = count + 1 + if (start == len) + return (0) + } + + # Extract the output string from the dictionary + for (i = start; dict[i] != EOS && dict[i] != dict[1]; i = i + 1) { + if (i - start + 1 > maxch) + break + outstr[i - start + 1] = dict[i] + } + + outstr[i - start + 1] = EOS + + # Return index for output string + return (count) +end diff --git a/noao/astcat/src/attools/liststr.gx b/noao/astcat/src/attools/liststr.gx new file mode 100644 index 00000000..3af9b6a3 --- /dev/null +++ b/noao/astcat/src/attools/liststr.gx @@ -0,0 +1,496 @@ +include <ctype.h> + +$for (r) + +# LI_FIND_FIELDS -- This procedure finds the starting column for each field +# in the input line. These column numbers are returned in the array +# field_pos; the number of fields is also returned. + +procedure li_find_fields (linebuf, field_pos, max_fields, nfields) + +char linebuf[ARB] #I the input buffer +int field_pos[max_fields] #O the output field positions +int max_fields #I the maximum number of fields +int nfields #O the computed number of fields + +bool in_field +int ip, field_num + +begin + field_num = 1 + field_pos[1] = 1 + in_field = false + + for (ip=1; linebuf[ip] != '\n' && linebuf[ip] != EOS; ip=ip+1) { + if (! IS_WHITE(linebuf[ip])) + in_field = true + else if (in_field) { + in_field = false + field_num = field_num + 1 + field_pos[field_num] = ip + } + } + + field_pos[field_num+1] = ip + nfields = field_num +end + + +# LI_CAPPEND_LINE -- Fields are copied from the input buffer to the +# output buffer. + +procedure li_cappend_line (inbuf, outbuf, maxch, xoffset, yoffset, + xwidth, ywidth) + +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 xoffset #I the offset to the x field +int yoffset #I the offset to the y field +int xwidth #I the width of the x field +int ywidth #I the width of the y field + +int ip, op +int gstrcpy() + +begin + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add a blank. + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy the two fields. + op = op + gstrcpy (inbuf[xoffset], outbuf[op], min (maxch - op + 1, + xwidth)) + op = op + gstrcpy (inbuf[yoffset], outbuf[op], min (maxch - op + 1, + ywidth)) + + # Add a newline. + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + outbuf[op] = EOS +end + + +define LOGPTR 20 # log2(maxpts) (1e6) + +# LI_PQSORTI -- Vector quicksort an integer array. In this version the index +# array is actually sorted not the data array. The input and output index +# arrays may be the same. + +procedure li_pqsorti (data, a, b, npix) + +int data[ARB] # data array +int a[ARB] # input index array +int b[ARB] # output index array +int npix # number of pixels + +int i, j, lv[LOGPTR], p, uv[LOGPTR], temp, pivot + +begin + # Initialize the indices for an inplace sort. + call amovi (a, b, npix) + + p = 1 + lv[1] = 1 + uv[1] = npix + while (p > 0) { + + + # If only one elem in subset pop stack otherwise pivot line. + if (lv[p] >= uv[p]) + p = p - 1 + else { + i = lv[p] - 1 + j = uv[p] + pivot = data[b[j]] + + while (i < j) { + for (i=i+1; data[b[i]] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (data[b[j]] <= pivot) + break + if (i < j) { # out of order pair + temp = b[j] # interchange elements + b[j] = b[i] + b[i] = temp + } + } + + j = uv[p] # move pivot to position i + temp = b[j] # interchange elements + b[j] = b[i] + b[i] = temp + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + p = p + 1 # push onto stack + } + } +end + + +$endfor + +$for (rd) + +# LT_GET_NUM -- The field entry is converted from character to real or double +# in preparation for the transformation. The number of significant +# digits is counted and returned as an argument; the number of chars in +# the number is returned as the function value. + +int procedure li_get_num$t (linebuf, fval, nsdig) + +char linebuf[ARB] #I the input line buffer +PIXEL fval #O the output floating point value +int nsdig #O the number of significant digits + +char ch +int nchar, ip +int cto$t(), stridx() + +begin + ip = 1 + nsdig = 0 + nchar = cto$t (linebuf, ip, fval) + if (nchar == 0 || fval == $INDEF$T) + return (nchar) + + # Skip leading white space. + ip = 1 + repeat { + ch = linebuf[ip] + if (! IS_WHITE(ch)) + break + ip = ip + 1 + } + + # Count signifigant digits + for (; ! IS_WHITE(ch) && ch != '\n' && ch != EOS; ch=linebuf[ip]) { + if (stridx (ch, "eEdD") > 0) + break + if (IS_DIGIT (ch)) + nsdig = nsdig + 1 + ip = ip + 1 + } + + return (nchar) +end + + +# LI_PACK_LINE -- Fields are packed into the outbuf buffer. Transformed +# fields are converted to strings; other fields are copied from +# the input line to output buffer. + +procedure li_pack_line$t (inbuf, outbuf, maxch, field_pos, nfields, + xfield, yfield, xt, yt, xformat, yformat, nsdig_x, nsdig_y, + 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 xfield #I the field number of the x coordinate column +int yfield #I the field number of the y coordinate column +PIXEL xt #I the transformed x coordinate +PIXEL yt #I the transformed y coordinate +char xformat[ARB] #I the output format for the x column +char yformat[ARB] #I the output format for the y column +int nsdig_x #I the number of significant digits in x +int nsdig_y #I the number of significant digits in y +int min_sigdigits #I the minimum number of significant digits + +int num_field, width, op +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + do num_field = 1, nfields { + width = field_pos[num_field + 1] - field_pos[num_field] + + if (num_field == xfield) { + call li_format_field$t (xt, Memc[field], maxch, xformat, + nsdig_x, width, min_sigdigits) + } else if (num_field == yfield) { + call li_format_field$t (yt, Memc[field], maxch, yformat, + nsdig_y, 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) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + +# LI_NPACK_LINE -- Fields are packed into the outbuf buffer. Transformed +# fields are converted to strings; other fields are copied from +# the input line to output buffer. + +procedure li_npack_line$t (inbuf, outbuf, maxch, field_pos, nfields, + vfields, values, nsdigits, nvalues, vformats, sz_fmt, 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 vfields[ARB] #I the fields to be formatted +PIXEL values[ARB] #I the field values to be formatted +int nsdigits[ARB] #I the number of field significant digits +int nvalues #I the number of fields to be formatted +char vformats[sz_fmt,ARB] #I the field formats +int sz_fmt #I the size of the format string +int min_sigdigits #I the minimum number of significant digits + +bool found +int op, num_field, num_var, width +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + do num_field = 1, nfields { + width = field_pos[num_field + 1] - field_pos[num_field] + + found = false + do num_var = 1, nvalues { + if (num_field == vfields[num_var]) { + found = true + break + } + } + + if (found) { + call li_format_field$t (values[num_var], Memc[field], + maxch, vformats[1,num_var], nsdigits[num_var], 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) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + +# LI_APPEND_LINE -- Fields are appened to the input buffer. Transformed +# fields are converted to strings and added to the end of the input buffer. + +procedure li_append_line$t (inbuf, outbuf, maxch, xt, yt, xformat, yformat, + nsdig_x, nsdig_y, 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 +PIXEL xt #I the transformed x coordinate +PIXEL yt #I the transformed y coordinate +char xformat[ARB] #I the output format for the x column +char yformat[ARB] #I the output format for the y column +int nsdig_x #I the number of significant digits in x +int nsdig_y #I the number of significant digits in y +int min_sigdigits #I the minimum number of significant digits + +int ip, op +pointer sp, field +int gstrcpy() + +begin + # Allocate some working space. + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add two blanks. + op = op + gstrcpy (" ", outbuf[op], maxch - op + 1) + + # Format and add the the two extra fields with a blank between. + call li_format_field$t (xt, Memc[field], SZ_LINE, xformat, + nsdig_x, 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + call li_format_field$t (yt, Memc[field], SZ_LINE, yformat, + nsdig_y, 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + + # Add a newline. + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + outbuf[op] = EOS + + call sfree (sp) +end + + +# LI_NAPPEND_LINE -- Fields are appened to the input buffer. Transformed +# fields are converted to strings and added to the end of the input buffer. + +procedure li_nappend_line$t (inbuf, outbuf, maxch, field_pos, nfields, + vfields, values, nsdigits, nvalues, vformats, sz_fmt, 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 vfields[ARB] #I the fields to be formatted +PIXEL values[ARB] #I the field values to be formatted +int nsdigits[ARB] #I the number of field significant digits +int nvalues #I the number of fields to be formatted +char vformats[sz_fmt,ARB] #I the field formats +int sz_fmt #I the size of the format string +int min_sigdigits #I the minimum number of significant digits + +int num_var, ip, op, index +pointer sp, field, nvfields +int gstrcpy() + +begin + # Allocate some working space. + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + call salloc (nvfields, nvalues, TY_INT) + do num_var = 1, nvalues + Memi[nvfields+num_var-1] = num_var + call li_pqsorti (vfields, Memi[nvfields], Memi[nvfields], nvalues) + + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add two blanks. + op = op + gstrcpy (" ", outbuf[op], maxch - op + 1) + + do num_var = 1, nvalues { + index = Memi[nvfields+num_var-1] + call li_format_field$t (values[index], Memc[field], SZ_LINE, + vformats[sz_fmt,index], nsdigits[index], 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + if (num_var == nvalues) { + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + } else { + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + } + } + + outbuf[op] = EOS + + call sfree (sp) +end + + +# LI_FORMAT_FIELD -- A transformed coordinate is written into a string +# buffer. The output field is of (at least) the same width and significance +# as the input list entry. + +procedure li_format_field$t (fval, wordbuf, maxch, format, nsdig, width, + min_sigdigits) + +PIXEL fval #I the input value to be formatted +char wordbuf[maxch] #O the output formatted string +int maxch #I the maximum length of the output string +char format[ARB] #I the output format +int nsdig #I the number of sig-digits in current value +int width #I the width of the curent field +int min_sigdigits #I the minimum number of significant digits + +int fdigits, fwidth +begin + if (format[1] == EOS) { + fdigits = max (min_sigdigits, nsdig) + fwidth = max (width, fdigits + 1) + call sprintf (wordbuf, maxch, "%*.*g") + call pargi (fwidth) + call pargi (fdigits) + call parg$t (fval) + } else { + call sprintf (wordbuf, maxch, format) + call parg$t (fval) + } +end + + +$endfor diff --git a/noao/astcat/src/attools/liststr.x b/noao/astcat/src/attools/liststr.x new file mode 100644 index 00000000..05f937a0 --- /dev/null +++ b/noao/astcat/src/attools/liststr.x @@ -0,0 +1,833 @@ +include <ctype.h> + + + +# LI_FIND_FIELDS -- This procedure finds the starting column for each field +# in the input line. These column numbers are returned in the array +# field_pos; the number of fields is also returned. + +procedure li_find_fields (linebuf, field_pos, max_fields, nfields) + +char linebuf[ARB] #I the input buffer +int field_pos[max_fields] #O the output field positions +int max_fields #I the maximum number of fields +int nfields #O the computed number of fields + +bool in_field +int ip, field_num + +begin + field_num = 1 + field_pos[1] = 1 + in_field = false + + for (ip=1; linebuf[ip] != '\n' && linebuf[ip] != EOS; ip=ip+1) { + if (! IS_WHITE(linebuf[ip])) + in_field = true + else if (in_field) { + in_field = false + field_num = field_num + 1 + field_pos[field_num] = ip + } + } + + field_pos[field_num+1] = ip + nfields = field_num +end + + +# LI_CAPPEND_LINE -- Fields are copied from the input buffer to the +# output buffer. + +procedure li_cappend_line (inbuf, outbuf, maxch, xoffset, yoffset, + xwidth, ywidth) + +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 xoffset #I the offset to the x field +int yoffset #I the offset to the y field +int xwidth #I the width of the x field +int ywidth #I the width of the y field + +int ip, op +int gstrcpy() + +begin + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add a blank. + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy the two fields. + op = op + gstrcpy (inbuf[xoffset], outbuf[op], min (maxch - op + 1, + xwidth)) + op = op + gstrcpy (inbuf[yoffset], outbuf[op], min (maxch - op + 1, + ywidth)) + + # Add a newline. + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + outbuf[op] = EOS +end + + +define LOGPTR 20 # log2(maxpts) (1e6) + +# LI_PQSORTI -- Vector quicksort an integer array. In this version the index +# array is actually sorted not the data array. The input and output index +# arrays may be the same. + +procedure li_pqsorti (data, a, b, npix) + +int data[ARB] # data array +int a[ARB] # input index array +int b[ARB] # output index array +int npix # number of pixels + +int i, j, lv[LOGPTR], p, uv[LOGPTR], temp, pivot + +begin + # Initialize the indices for an inplace sort. + call amovi (a, b, npix) + + p = 1 + lv[1] = 1 + uv[1] = npix + while (p > 0) { + + + # If only one elem in subset pop stack otherwise pivot line. + if (lv[p] >= uv[p]) + p = p - 1 + else { + i = lv[p] - 1 + j = uv[p] + pivot = data[b[j]] + + while (i < j) { + for (i=i+1; data[b[i]] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (data[b[j]] <= pivot) + break + if (i < j) { # out of order pair + temp = b[j] # interchange elements + b[j] = b[i] + b[i] = temp + } + } + + j = uv[p] # move pivot to position i + temp = b[j] # interchange elements + b[j] = b[i] + b[i] = temp + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + p = p + 1 # push onto stack + } + } +end + + + + + + +# LT_GET_NUM -- The field entry is converted from character to real or double +# in preparation for the transformation. The number of significant +# digits is counted and returned as an argument; the number of chars in +# the number is returned as the function value. + +int procedure li_get_numr (linebuf, fval, nsdig) + +char linebuf[ARB] #I the input line buffer +real fval #O the output floating point value +int nsdig #O the number of significant digits + +char ch +int nchar, ip +int ctor(), stridx() + +begin + ip = 1 + nsdig = 0 + nchar = ctor (linebuf, ip, fval) + if (nchar == 0 || fval == INDEFR) + return (nchar) + + # Skip leading white space. + ip = 1 + repeat { + ch = linebuf[ip] + if (! IS_WHITE(ch)) + break + ip = ip + 1 + } + + # Count signifigant digits + for (; ! IS_WHITE(ch) && ch != '\n' && ch != EOS; ch=linebuf[ip]) { + if (stridx (ch, "eEdD") > 0) + break + if (IS_DIGIT (ch)) + nsdig = nsdig + 1 + ip = ip + 1 + } + + return (nchar) +end + + +# LI_PACK_LINE -- Fields are packed into the outbuf buffer. Transformed +# fields are converted to strings; other fields are copied from +# the input line to output buffer. + +procedure li_pack_liner (inbuf, outbuf, maxch, field_pos, nfields, + xfield, yfield, xt, yt, xformat, yformat, nsdig_x, nsdig_y, + 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 xfield #I the field number of the x coordinate column +int yfield #I the field number of the y coordinate column +real xt #I the transformed x coordinate +real yt #I the transformed y coordinate +char xformat[ARB] #I the output format for the x column +char yformat[ARB] #I the output format for the y column +int nsdig_x #I the number of significant digits in x +int nsdig_y #I the number of significant digits in y +int min_sigdigits #I the minimum number of significant digits + +int num_field, width, op +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + do num_field = 1, nfields { + width = field_pos[num_field + 1] - field_pos[num_field] + + if (num_field == xfield) { + call li_format_fieldr (xt, Memc[field], maxch, xformat, + nsdig_x, width, min_sigdigits) + } else if (num_field == yfield) { + call li_format_fieldr (yt, Memc[field], maxch, yformat, + nsdig_y, 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) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + +# LI_NPACK_LINE -- Fields are packed into the outbuf buffer. Transformed +# fields are converted to strings; other fields are copied from +# the input line to output buffer. + +procedure li_npack_liner (inbuf, outbuf, maxch, field_pos, nfields, + vfields, values, nsdigits, nvalues, vformats, sz_fmt, 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 vfields[ARB] #I the fields to be formatted +real values[ARB] #I the field values to be formatted +int nsdigits[ARB] #I the number of field significant digits +int nvalues #I the number of fields to be formatted +char vformats[sz_fmt,ARB] #I the field formats +int sz_fmt #I the size of the format string +int min_sigdigits #I the minimum number of significant digits + +bool found +int op, num_field, num_var, width +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + do num_field = 1, nfields { + width = field_pos[num_field + 1] - field_pos[num_field] + + found = false + do num_var = 1, nvalues { + if (num_field == vfields[num_var]) { + found = true + break + } + } + + if (found) { + call li_format_fieldr (values[num_var], Memc[field], + maxch, vformats[1,num_var], nsdigits[num_var], 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) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + +# LI_APPEND_LINE -- Fields are appened to the input buffer. Transformed +# fields are converted to strings and added to the end of the input buffer. + +procedure li_append_liner (inbuf, outbuf, maxch, xt, yt, xformat, yformat, + nsdig_x, nsdig_y, 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 +real xt #I the transformed x coordinate +real yt #I the transformed y coordinate +char xformat[ARB] #I the output format for the x column +char yformat[ARB] #I the output format for the y column +int nsdig_x #I the number of significant digits in x +int nsdig_y #I the number of significant digits in y +int min_sigdigits #I the minimum number of significant digits + +int ip, op +pointer sp, field +int gstrcpy() + +begin + # Allocate some working space. + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add two blanks. + op = op + gstrcpy (" ", outbuf[op], maxch - op + 1) + + # Format and add the the two extra fields with a blank between. + call li_format_fieldr (xt, Memc[field], SZ_LINE, xformat, + nsdig_x, 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + call li_format_fieldr (yt, Memc[field], SZ_LINE, yformat, + nsdig_y, 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + + # Add a newline. + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + outbuf[op] = EOS + + call sfree (sp) +end + + +# LI_NAPPEND_LINE -- Fields are appened to the input buffer. Transformed +# fields are converted to strings and added to the end of the input buffer. + +procedure li_nappend_liner (inbuf, outbuf, maxch, field_pos, nfields, + vfields, values, nsdigits, nvalues, vformats, sz_fmt, 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 vfields[ARB] #I the fields to be formatted +real values[ARB] #I the field values to be formatted +int nsdigits[ARB] #I the number of field significant digits +int nvalues #I the number of fields to be formatted +char vformats[sz_fmt,ARB] #I the field formats +int sz_fmt #I the size of the format string +int min_sigdigits #I the minimum number of significant digits + +int num_var, ip, op, index +pointer sp, field, nvfields +int gstrcpy() + +begin + # Allocate some working space. + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + call salloc (nvfields, nvalues, TY_INT) + do num_var = 1, nvalues + Memi[nvfields+num_var-1] = num_var + call li_pqsorti (vfields, Memi[nvfields], Memi[nvfields], nvalues) + + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add two blanks. + op = op + gstrcpy (" ", outbuf[op], maxch - op + 1) + + do num_var = 1, nvalues { + index = Memi[nvfields+num_var-1] + call li_format_fieldr (values[index], Memc[field], SZ_LINE, + vformats[sz_fmt,index], nsdigits[index], 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + if (num_var == nvalues) { + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + } else { + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + } + } + + outbuf[op] = EOS + + call sfree (sp) +end + + +# LI_FORMAT_FIELD -- A transformed coordinate is written into a string +# buffer. The output field is of (at least) the same width and significance +# as the input list entry. + +procedure li_format_fieldr (fval, wordbuf, maxch, format, nsdig, width, + min_sigdigits) + +real fval #I the input value to be formatted +char wordbuf[maxch] #O the output formatted string +int maxch #I the maximum length of the output string +char format[ARB] #I the output format +int nsdig #I the number of sig-digits in current value +int width #I the width of the curent field +int min_sigdigits #I the minimum number of significant digits + +int fdigits, fwidth +begin + if (format[1] == EOS) { + fdigits = max (min_sigdigits, nsdig) + fwidth = max (width, fdigits + 1) + call sprintf (wordbuf, maxch, "%*.*g") + call pargi (fwidth) + call pargi (fdigits) + call pargr (fval) + } else { + call sprintf (wordbuf, maxch, format) + call pargr (fval) + } +end + + + + +# LT_GET_NUM -- The field entry is converted from character to real or double +# in preparation for the transformation. The number of significant +# digits is counted and returned as an argument; the number of chars in +# the number is returned as the function value. + +int procedure li_get_numd (linebuf, fval, nsdig) + +char linebuf[ARB] #I the input line buffer +double fval #O the output floating point value +int nsdig #O the number of significant digits + +char ch +int nchar, ip +int ctod(), stridx() + +begin + ip = 1 + nsdig = 0 + nchar = ctod (linebuf, ip, fval) + if (nchar == 0 || fval == INDEFD) + return (nchar) + + # Skip leading white space. + ip = 1 + repeat { + ch = linebuf[ip] + if (! IS_WHITE(ch)) + break + ip = ip + 1 + } + + # Count signifigant digits + for (; ! IS_WHITE(ch) && ch != '\n' && ch != EOS; ch=linebuf[ip]) { + if (stridx (ch, "eEdD") > 0) + break + if (IS_DIGIT (ch)) + nsdig = nsdig + 1 + ip = ip + 1 + } + + return (nchar) +end + + +# LI_PACK_LINE -- Fields are packed into the outbuf buffer. Transformed +# fields are converted to strings; other fields are copied from +# the input line to output buffer. + +procedure li_pack_lined (inbuf, outbuf, maxch, field_pos, nfields, + xfield, yfield, xt, yt, xformat, yformat, nsdig_x, nsdig_y, + 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 xfield #I the field number of the x coordinate column +int yfield #I the field number of the y coordinate column +double xt #I the transformed x coordinate +double yt #I the transformed y coordinate +char xformat[ARB] #I the output format for the x column +char yformat[ARB] #I the output format for the y column +int nsdig_x #I the number of significant digits in x +int nsdig_y #I the number of significant digits in y +int min_sigdigits #I the minimum number of significant digits + +int num_field, width, op +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + do num_field = 1, nfields { + width = field_pos[num_field + 1] - field_pos[num_field] + + if (num_field == xfield) { + call li_format_fieldd (xt, Memc[field], maxch, xformat, + nsdig_x, width, min_sigdigits) + } else if (num_field == yfield) { + call li_format_fieldd (yt, Memc[field], maxch, yformat, + nsdig_y, 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) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + +# LI_NPACK_LINE -- Fields are packed into the outbuf buffer. Transformed +# fields are converted to strings; other fields are copied from +# the input line to output buffer. + +procedure li_npack_lined (inbuf, outbuf, maxch, field_pos, nfields, + vfields, values, nsdigits, nvalues, vformats, sz_fmt, 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 vfields[ARB] #I the fields to be formatted +double values[ARB] #I the field values to be formatted +int nsdigits[ARB] #I the number of field significant digits +int nvalues #I the number of fields to be formatted +char vformats[sz_fmt,ARB] #I the field formats +int sz_fmt #I the size of the format string +int min_sigdigits #I the minimum number of significant digits + +bool found +int op, num_field, num_var, width +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + do num_field = 1, nfields { + width = field_pos[num_field + 1] - field_pos[num_field] + + found = false + do num_var = 1, nvalues { + if (num_field == vfields[num_var]) { + found = true + break + } + } + + if (found) { + call li_format_fieldd (values[num_var], Memc[field], + maxch, vformats[1,num_var], nsdigits[num_var], 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) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + +# LI_APPEND_LINE -- Fields are appened to the input buffer. Transformed +# fields are converted to strings and added to the end of the input buffer. + +procedure li_append_lined (inbuf, outbuf, maxch, xt, yt, xformat, yformat, + nsdig_x, nsdig_y, 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 +double xt #I the transformed x coordinate +double yt #I the transformed y coordinate +char xformat[ARB] #I the output format for the x column +char yformat[ARB] #I the output format for the y column +int nsdig_x #I the number of significant digits in x +int nsdig_y #I the number of significant digits in y +int min_sigdigits #I the minimum number of significant digits + +int ip, op +pointer sp, field +int gstrcpy() + +begin + # Allocate some working space. + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add two blanks. + op = op + gstrcpy (" ", outbuf[op], maxch - op + 1) + + # Format and add the the two extra fields with a blank between. + call li_format_fieldd (xt, Memc[field], SZ_LINE, xformat, + nsdig_x, 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + call li_format_fieldd (yt, Memc[field], SZ_LINE, yformat, + nsdig_y, 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + + # Add a newline. + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + outbuf[op] = EOS + + call sfree (sp) +end + + +# LI_NAPPEND_LINE -- Fields are appened to the input buffer. Transformed +# fields are converted to strings and added to the end of the input buffer. + +procedure li_nappend_lined (inbuf, outbuf, maxch, field_pos, nfields, + vfields, values, nsdigits, nvalues, vformats, sz_fmt, 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 vfields[ARB] #I the fields to be formatted +double values[ARB] #I the field values to be formatted +int nsdigits[ARB] #I the number of field significant digits +int nvalues #I the number of fields to be formatted +char vformats[sz_fmt,ARB] #I the field formats +int sz_fmt #I the size of the format string +int min_sigdigits #I the minimum number of significant digits + +int num_var, ip, op, index +pointer sp, field, nvfields +int gstrcpy() + +begin + # Allocate some working space. + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + call salloc (nvfields, nvalues, TY_INT) + do num_var = 1, nvalues + Memi[nvfields+num_var-1] = num_var + call li_pqsorti (vfields, Memi[nvfields], Memi[nvfields], nvalues) + + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add two blanks. + op = op + gstrcpy (" ", outbuf[op], maxch - op + 1) + + do num_var = 1, nvalues { + index = Memi[nvfields+num_var-1] + call li_format_fieldd (values[index], Memc[field], SZ_LINE, + vformats[sz_fmt,index], nsdigits[index], 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + if (num_var == nvalues) { + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + } else { + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + } + } + + outbuf[op] = EOS + + call sfree (sp) +end + + +# LI_FORMAT_FIELD -- A transformed coordinate is written into a string +# buffer. The output field is of (at least) the same width and significance +# as the input list entry. + +procedure li_format_fieldd (fval, wordbuf, maxch, format, nsdig, width, + min_sigdigits) + +double fval #I the input value to be formatted +char wordbuf[maxch] #O the output formatted string +int maxch #I the maximum length of the output string +char format[ARB] #I the output format +int nsdig #I the number of sig-digits in current value +int width #I the width of the curent field +int min_sigdigits #I the minimum number of significant digits + +int fdigits, fwidth +begin + if (format[1] == EOS) { + fdigits = max (min_sigdigits, nsdig) + fwidth = max (width, fdigits + 1) + call sprintf (wordbuf, maxch, "%*.*g") + call pargi (fwidth) + call pargi (fdigits) + call pargd (fval) + } else { + call sprintf (wordbuf, maxch, format) + call pargd (fval) + } +end diff --git a/noao/astcat/src/attools/mkpkg b/noao/astcat/src/attools/mkpkg new file mode 100644 index 00000000..24889814 --- /dev/null +++ b/noao/astcat/src/attools/mkpkg @@ -0,0 +1,39 @@ +# ATTOOLS tools subdirectory + +$checkout libpkg.a ".." +$update libpkg.a +$checkin libpkg.a ".." +$exit + +tfiles: + $ifolder (liststr.x,liststr.gx) + $generic -k liststr.gx -o liststr.x $endif + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call tfiles $endif + + atalloc.x "../../lib/astromdef.h" "../../lib/astrom.h" \ + "../../lib/acatalog.h" "../../lib/aimparsdef.h" \ + "../../lib/aimpars.h" + atcathdr.x <pkg/cq.h> "../../lib/acatalog.h" + atfnames.x "../../lib/astrom.h" <pkg/cq.h> + atinpars.x "../../lib/astrom.h" "../../lib/acatalog.h" \ + "../../lib/aimpars.h" + atdefpars.x "../../lib/astrom.h" "../../lib/acatalog.h" \ + "../../lib/aimpars.h" + atoutpars.x "../../lib/astrom.h" "../../lib/acatalog.h" \ + "../../lib/aimpars.h" + atset.x "../../lib/astromdef.h" "../../lib/astrom.h" \ + "../../lib/aimparsdef.h" "../../lib/aimpars.h" + atshow.x "../../lib/astrom.h" "../../lib/acatalog.h" \ + "../../lib/aimpars.h" + atstat.x "../../lib/astromdef.h" "../../lib/astrom.h" \ + "../../lib/aimparsdef.h" "../../lib/aimpars.h" + atwrdstr.x + + liststr.x <ctype.h> + atvectors.x + atsort.x + atdtype.x + ; diff --git a/noao/astcat/src/awcs/atmwshow.x b/noao/astcat/src/awcs/atmwshow.x new file mode 100644 index 00000000..cc39bbf3 --- /dev/null +++ b/noao/astcat/src/awcs/atmwshow.x @@ -0,0 +1,129 @@ +# AT_MWSHOW -- Print a quick summary of the current wcs. + +procedure at_mwshow (mwim, ltv, ltm, w, r, cd, ndim) + +pointer mwim # pointer to the current 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 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 diff --git a/noao/astcat/src/awcs/calcds.x b/noao/astcat/src/awcs/calcds.x new file mode 100644 index 00000000..de7ebcf2 --- /dev/null +++ b/noao/astcat/src/awcs/calcds.x @@ -0,0 +1,128 @@ +include <math.h> + +define SZ_GRID 10 +define SZ_NTERMS 2 + +# CALCDS -- Procedure to calculate the values of the CD matrix from the +# GSSS plate solution and a grid of 100 tie points. This routine was +# adapted from one in stsdas$pkg/analysis/gasp/gasplib/. See the routine +# stsdas$copyright.stsdas. + +procedure calcds (plt_centre_ra, plt_centre_dec, plt_centre_x, plt_centre_y, + x_corner, y_corner, x_pixel_size, y_pixel_size, plate_scale, x_size, + y_size, im_cen_ra, im_cen_dec, amd_x, amd_y, cd_matrix) + +double plt_centre_ra #I plate centre RA (radians) +double plt_centre_dec #I plate centre DEC (radians) +double plt_centre_x #I x center position (microns) +double plt_centre_y #I y center position (microns) +int x_corner #I x lower left of the extracted image +int y_corner #I y lower left of the extracted image +double x_pixel_size #I y scan pixel size (microns) +double y_pixel_size #I y scan pixel size (microns) +double plate_scale #I plate scale (arcsec / mm) +int x_size #I extracted image size x_axis (pixel) +int y_size #I extracted image size y_axis (pixel) +double im_cen_ra #I extracted image center RA (radians) +double im_cen_dec #I extracted image center DEC (radians) +double amd_x[ARB] #I XI plate solution coefficients +double amd_y[ARB] #I ETA coefficients (arsec / mm) +double cd_matrix[ARB] #O CD1_1, CD1_2, CD2_1, CD2_2 (degrees / pixel) + +double ra, dec, new_plt_centre_x, new_plt_centre_y, xref, yref, mag, color +double x_coeff[SZ_NTERMS], y_coeff[SZ_NTERMS], xchisqr, ychisqr +double x_sigma[SZ_NTERMS], y_sigma[SZ_NTERMS], x, y, xc, yc +pointer sp, xip, etap, x_arr, y_arr, ww, u, v, w, cvm +int sx, sy, xlim, ylim, nx, ny, nxy +int i, j, nterms, xi, eta, npts + +begin + # Initialize color and magnitude. + mag = 0.0d0 + color = 0.0d0 + + # Calculate new plate center in microns. + new_plt_centre_x = (x_size / 2.0d0) * x_pixel_size + new_plt_centre_y = (y_size / 2.0d0) * y_pixel_size + + call smark (sp) + call salloc (xip, SZ_GRID * SZ_GRID, TY_DOUBLE) + call salloc (etap, SZ_GRID * SZ_GRID, TY_DOUBLE) + call salloc (x_arr, SZ_NTERMS * SZ_GRID * SZ_GRID, TY_DOUBLE) + call salloc (y_arr, SZ_NTERMS * SZ_GRID * SZ_GRID, TY_DOUBLE) + call salloc (ww, SZ_GRID * SZ_GRID, TY_REAL) + + sx = max (1, x_size / SZ_GRID) + sy = max (1, y_size / SZ_GRID) + xlim = x_size - mod (x_size, sx) + ylim = y_size - mod (y_size, sy) + nx = xlim / sx + ny = ylim / sy + nxy = nx * ny + xi = xip + eta = etap + + # Compute the grid points. + npts = 0 + do i = sx, xlim, sx { + y = i # x coord. from lower left + do j = sy, ylim, sy { + x =j # y coord. from lower left + xc = x + x_corner + yc = y + y_corner + + # Obtain ra and dec from this grid (w/r to the original lower + # left corner) given the original plate center. + call ccgseq (plt_centre_ra, plt_centre_dec, plt_centre_x, + plt_centre_y, x_pixel_size, y_pixel_size, plate_scale, + amd_x, amd_y, xc, yc, mag, color, ra, dec) + + # Calculate xi and eta given the new plate center. + call treqst (im_cen_ra, im_cen_dec, ra, dec, Memd[xi], Memd[eta]) + xi = xi + 1 + eta = eta + 1 + + # Pixel to mm from the new plate center, notice x, y are + # w/r to the new lower left corner. +# xref = (new_plt_centre_x - x * x_pixel_size) / 1000. + xref = (x * x_pixel_size - new_plt_centre_x) / 1000. + yref = (y * y_pixel_size - new_plt_centre_y) / 1000. + + # Form normal equations for the model. + # xi = a*xref + b*yref + # eta = c*yref + d*xref + # + Memd[x_arr+npts] = xref # XAR(j,1) + Memd[x_arr+npts+nxy] = yref # XAR(j,2) + Memd[y_arr+npts] = yref # YAR(i,1) + Memd[y_arr+npts+nxy] = xref # YAR(i,2) + Memr[ww+npts] = 1.0 + npts = npts + 1 + } + } + + # Calculate the coefficients. + nterms = SZ_NTERMS + call salloc (u, npts * nterms, TY_DOUBLE) + call salloc (v, nterms * nterms, TY_DOUBLE) + call salloc (w, nterms, TY_DOUBLE) + call salloc (cvm, nterms * nterms, TY_DOUBLE) + call fitsvd (Memd[x_arr], Memd[xip], Memr[ww], npts, x_coeff, + nterms, Memd[u], Memd[v], Memd[w], xchisqr) + call varsvd (Memd[v], nterms, Memd[w], Memd[cvm], nterms) + do i =1, nterms + x_sigma[i] = sqrt(Memd[cvm+(i-1)+(i-1)*nterms]) + call fitsvd (Memd[y_arr], Memd[etap], Memr[ww], npts, y_coeff, + nterms, Memd[u], Memd[v], Memd[w], ychisqr) + call varsvd (Memd[v], nterms, Memd[w], Memd[cvm], nterms) + do i =1, nterms + y_sigma[i] = sqrt(Memd[cvm+(i-1)+(i-1)*nterms]) + + # Degrees/pixel = (arcsec/mm)*(mm/pixel)*(degrees/arcsec) + cd_matrix[1] = x_coeff[1] * (x_pixel_size / 1000.0d0 / 3600.0d0) + cd_matrix[2] = x_coeff[2] * (y_pixel_size / 1000.0d0 / 3600.0d0) + cd_matrix[3] = y_coeff[2] * (y_pixel_size / 1000.0d0 / 3600.0d0) + cd_matrix[4] = y_coeff[1] * (x_pixel_size / 1000.0d0 / 3600.0d0) + + call sfree (sp) +end diff --git a/noao/astcat/src/awcs/ccqseq.x b/noao/astcat/src/awcs/ccqseq.x new file mode 100644 index 00000000..542ea05e --- /dev/null +++ b/noao/astcat/src/awcs/ccqseq.x @@ -0,0 +1,95 @@ +# CCGSEQ -- Routine for computing RA and Dec for a given X,Y pixel +# position on a GSSS image. Adapted from stsdas$pkg/analysis/gasp/gasplib/. +# See stsdas$copyright.stdas for copyright restrictions. + +procedure ccgseq (plate_centre_ra, plate_centre_dec, plate_centre_x, + plate_centre_y, x_pixel_size, y_pixel_size, plate_scale, amd_x, + amd_y, object_x, object_y, object_mag, object_col, object_ra, + object_dec) + +double plate_centre_ra #I plate Right Ascension (radians) +double plate_centre_dec #I plate Declination (radians) +double plate_centre_x #I x position used in solution (microns) +double plate_centre_y #I y position used in solution (microns) +double x_pixel_size #I scan pixel size in x (microns) +double y_pixel_size #I scan pixel size in y (microns) +double plate_scale #I plate scale (arcsec / mm) +double amd_x[ARB] #I ra plate model coefficients +double amd_y[ARB] #I dec plate model coefficinets +double object_x #I x pixel position for object +double object_y #I y pixel positions for objects +double object_mag #I object magnitude +double object_col #I object colour +double object_ra #O object ra (radians) +double object_dec #O object dec (radians) + +double x # position from center (mm) +double y # position from center (mm) +double xi_object # xi standard coordinate (arcsec) +double eta_object # eta standard coordinate (arcsec) +double p1,p2,p3,p4 + +begin + # Convert x,y from pixels to mm measured from the plate centre + + x = (plate_centre_x - object_x * x_pixel_size) / 1000.0d0 + y = (object_y * y_pixel_size - plate_centre_y) / 1000.0d0 + + # Compute standard coordinates from x,y and plate model coefficients + + p1 = amd_x(1) *x + + amd_x(2) *y + + amd_x(3) + + amd_x(4) *x**2 + + amd_x(5) *x*y + + amd_x(6) *y**2 + + p2 = amd_x(7) *(x**2+y**2) + + amd_x(8) *x**3 + + amd_x(9) *x**2*y + + amd_x(10) *x*y**2 + + amd_x(11) *y**3 + + p3 = amd_x(12) *x*(x**2+y**2) + + amd_x(13) *x*(x**2+y**2)**2 + + amd_x(14) *object_mag + + amd_x(15) *object_mag**2 + + amd_x(16) *object_mag**3 + + p4 = amd_x(17) *object_mag*x + + amd_x(18) *object_mag*(x**2+y**2) + + amd_x(19) *object_mag*x*(x**2+y**2) + + amd_x(20) *object_col + + xi_object = p1 + p2 + p3 + p4 + + p1 = amd_y(1) *y + + amd_y(2) *x + + amd_y(3) + + amd_y(4) *y**2 + + amd_y(5) *x*y + + amd_y(6) *x**2 + + p2 = amd_y(7) *(x**2+y**2) + + amd_y(8) *y**3 + + amd_y(9) *y**2*x + + amd_y(10) *y*x**2 + + amd_y(11) *x**3 + + p3 = amd_y(12) *y*(x**2+y**2) + + amd_y(13) *y*(x**2+y**2)**2 + + amd_y(14) *object_mag + + amd_y(15) *object_mag**2 + + amd_y(16) *object_mag**3 + + p4 = amd_y(17) *object_mag*y + + amd_y(18) *object_mag*(x**2+y**2) + + amd_y(19) *object_mag*y*(x**2+y**2) + + amd_y(20) *object_col + + eta_object = p1 + p2 + p3 + p4 + + call trsteq (plate_centre_ra, plate_centre_dec, + xi_object, eta_object, object_ra, object_dec) + +end diff --git a/noao/astcat/src/awcs/dbwcs.x b/noao/astcat/src/awcs/dbwcs.x new file mode 100644 index 00000000..f3109050 --- /dev/null +++ b/noao/astcat/src/awcs/dbwcs.x @@ -0,0 +1,522 @@ +include <imhdr.h> +include <math.h> +include <mwset.h> +include <pkg/skywcs.h> +include <pkg/cq.h> + +# These should probably go into aimpars.h. + +define IMDB_WCSDICT "|wxref|wyref|wxmag|wymag|wxrot|wyrot|wraref|wdecref|\ +wproj|wsystem|" + +define IMDB_WCS_WXREF 1 +define IMDB_WCS_WYREF 2 +define IMDB_WCS_WXMAG 3 +define IMDB_WCS_WYMAG 4 +define IMDB_WCS_WXROT 5 +define IMDB_WCS_WYROT 6 +define IMDB_WCS_WLNGREF 7 +define IMDB_WCS_WLATREF 8 +define IMDB_WCS_WPROJ 9 +define IMDB_WCS_WSYSTEM 10 + + +# AT_DBWCS -- Compute a FITS WCS from an image using WCS definitions +# stored in the image surveys configuration file and transferred to the +# image query results structure. At the moment I am going to keep this +# routine simple by not worrying about the units of any quantities but the +# world coordinates of the reference point. This routine can be made more +# sophisticated later as time permits. The information is there ... + +int procedure at_dbwcs (im, res, update, verbose) + +pointer im #I the input image descriptor +pointer res #I the image query results descriptor +bool update #I update rather than list the wcs +bool verbose #I verbose mode + +double xref, yref, xmag, ymag, xrot, yrot, lngref, latref, dval +pointer sp, kfield, kname, kvalue, kunits, wtype, ctype, coo, mw +int i, ip, stat, coostat, ktype, nwcs, wkey, lngunits, latunits +double imgetd(), at_imhms() +int cq_istati(), cq_winfon(), strdic(), ctod(), ctowrd(), sk_decwcs() +bool streq() +errchk imgetd() + +begin + # Return if the input is not 2D. + + if (IM_NDIM(im) != 2) + return (ERR) + + # Allocate working space. + + call smark (sp) + call salloc (kfield, CQ_SZ_QPNAME, TY_CHAR) + call salloc (kname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (kvalue, CQ_SZ_QPVALUE, TY_CHAR) + call salloc (kunits, CQ_SZ_QPUNITS, TY_CHAR) + call salloc (wtype, SZ_FNAME, TY_CHAR) + call salloc (ctype, SZ_FNAME, TY_CHAR) + + # Assume some sensible defaults, e.g. the reference point is at + # the center of the image, the orientation is the standard astronomical + # orientation with ra increasing to the left and declination increasing + # to the top, the projection is tan, the coordinate system is J2000. + + xref = (IM_LEN(im,1) + 1.0d0)/ 2.0d0 + yref = (IM_LEN(im,2) + 1.0d0)/ 2.0d0 + xmag = INDEFD + ymag = INDEFD + xrot = 180.0d0 + yrot = 0.0d0 + lngref = INDEFD + latref = INDEFD + call strcpy ("tan", Memc[wtype], SZ_FNAME) + call strcpy ("J2000", Memc[ctype], SZ_FNAME) + + # Loop over the mwcs database quantities. + + nwcs = cq_istati (res, CQNWCS) + do i = 1, nwcs { + + # Get the keyword information. + if (cq_winfon (res, i, Memc[kfield], CQ_SZ_QPNAME, Memc[kname], + CQ_SZ_QPNAME, Memc[kvalue], CQ_SZ_QPVALUE, ktype, Memc[kunits], + CQ_SZ_QPUNITS) != i) + next + + # Which keyword have we got ? + wkey = strdic (Memc[kfield], Memc[kfield], CQ_SZ_QPNAME, + IMDB_WCSDICT) + ip = 1 + switch (wkey) { + + # Get the x reference point in pixels. + case IMDB_WCS_WXREF: + if (streq (Memc[kname], "INDEF")) { + if (streq (Memc[kvalue], "INDEF")) + dval = INDEFD + else if (ctod (Memc[kvalue], ip, dval) <= 0) + dval = INDEFD + } else iferr (dval = imgetd (im, Memc[kname])) + dval = INDEFD + if (! IS_INDEFD(dval)) + xref = dval + + case IMDB_WCS_WYREF: + if (streq (Memc[kname], "INDEF")) { + if (streq (Memc[kvalue], "INDEF")) + dval = INDEFD + else if (ctod (Memc[kvalue], ip, dval) <= 0) + dval = INDEFD + } else iferr (dval = imgetd (im, Memc[kname])) + dval = INDEFD + if (! IS_INDEFD(dval)) + yref = dval + + case IMDB_WCS_WXMAG: + if (streq (Memc[kname], "INDEF")) { + if (streq (Memc[kvalue], "INDEF")) + dval = INDEFD + else if (ctod (Memc[kvalue], ip, dval) <= 0) + dval = INDEFD + } else iferr (dval = imgetd (im, Memc[kname])) + dval = INDEFD + if (! IS_INDEFD(dval)) + xmag = dval + + case IMDB_WCS_WYMAG: + if (streq (Memc[kname], "INDEF")) { + if (streq (Memc[kvalue], "INDEF")) + dval = INDEFD + else if (ctod (Memc[kvalue], ip, dval) <= 0) + dval = INDEFD + } else iferr (dval = imgetd (im, Memc[kname])) + dval = INDEFD + if (! IS_INDEFD(dval)) + ymag = dval + + case IMDB_WCS_WXROT: + if (streq (Memc[kname], "INDEF")) { + if (streq (Memc[kvalue], "INDEF")) + dval = INDEFD + else if (ctod (Memc[kvalue], ip, dval) <= 0) + dval = INDEFD + } else iferr (dval = imgetd (im, Memc[kname])) + dval = INDEFD + if (! IS_INDEFD(dval)) + xrot = dval + + case IMDB_WCS_WYROT: + if (streq (Memc[kname], "INDEF")) { + if (streq (Memc[kvalue], "INDEF")) + dval = INDEFD + else if (ctod (Memc[kvalue], ip, dval) <= 0) + dval = INDEFD + } else iferr (dval = imgetd (im, Memc[kname])) + dval = INDEFD + if (! IS_INDEFD(dval)) + yrot = dval + + case IMDB_WCS_WLNGREF: + if (streq (Memc[kname], "INDEF")) { + if (streq (Memc[kvalue], "INDEF")) + dval = INDEFD + else if (ctod (Memc[kvalue], ip, dval) <= 0) + dval = INDEFD + } else { + dval = at_imhms (im, Memc[kname]) + if (IS_INDEFD(dval)) { + iferr (dval = imgetd (im, Memc[kname])) + dval = INDEFD + } + } + if (! IS_INDEFD(dval)) + lngref = dval + lngunits = strdic (Memc[kunits], Memc[kunits], CQ_SZ_QPUNITS, + SKY_LNG_UNITLIST) + + case IMDB_WCS_WLATREF: + if (streq (Memc[kname], "INDEF")) { + if (streq (Memc[kvalue], "INDEF")) + dval = INDEFD + else if (ctod (Memc[kvalue], ip, dval) <= 0) + dval = INDEFD + } else { + dval = at_imhms (im, Memc[kname]) + if (IS_INDEFD(dval)) { + iferr (dval = imgetd (im, Memc[kname])) + dval = INDEFD + } + } + if (! IS_INDEFD(dval)) + latref = dval + latunits = strdic (Memc[kunits], Memc[kunits], CQ_SZ_QPUNITS, + SKY_LAT_UNITLIST) + + case IMDB_WCS_WPROJ: + if (streq (Memc[kname], "INDEF")) { + if (streq (Memc[kvalue], "INDEF")) + call strcpy ("tan", Memc[wtype], SZ_FNAME) + else if (ctowrd (Memc[kvalue], ip, Memc[wtype], + SZ_FNAME) <= 0) + call strcpy ("tan", Memc[wtype], SZ_FNAME) + } else iferr (call imgstr (im, Memc[kname], Memc[wtype], + SZ_FNAME)) + call strcpy ("tan", Memc[wtype], SZ_FNAME) + + case IMDB_WCS_WSYSTEM: + if (streq (Memc[kname], "INDEF")) { + if (streq (Memc[kvalue], "INDEF")) + call strcpy ("J2000", Memc[ctype], SZ_FNAME) + else if (ctowrd (Memc[kvalue], ip, Memc[ctype], + SZ_FNAME) <= 0) + call strcpy ("J2000", Memc[ctype], SZ_FNAME) + } else iferr (call imgstr (im, Memc[kname], Memc[ctype], + SZ_FNAME)) + call strcpy ("J2000", Memc[ctype], SZ_FNAME) + + default: + ; + } + } + + # Check to see of the critical quantities image scale and reference + # point are defined. Quit if they are not, otherwise update the + # header. + + if (IS_INDEFD(xmag) || IS_INDEFD(ymag) || IS_INDEFD(lngref) || + IS_INDEFD(latref)) { + + stat = ERR + + } else { + + # Open the coordinate system structure. + coostat = sk_decwcs (Memc[ctype], mw, coo, NULL) + + # Update hte header. + if (coostat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + stat = ERR + } else { + if (lngunits > 0) + call sk_seti (coo, S_NLNGUNITS, lngunits) + if (latunits > 0) + call sk_seti (coo, S_NLATUNITS, latunits) + if (verbose) + call printf (" Writing FITS wcs using image survey db\n") + call at_uwcs (im, coo, Memc[wtype], lngref, latref, xref, + yref, xmag, ymag, xrot, yrot, false, update) + stat = OK + } + + # Close the coordinate structure + if (coo != NULL) + call sk_close (coo) + } + + call sfree (sp) + return (stat) +end + + +define NEWCD Memd[ncd+(($2)-1)*ndim+($1)-1] + +# AT_UWCS -- Compute the image wcs from the user parameters. + +procedure at_uwcs (im, coo, projection, lngref, latref, xref, yref, + xscale, yscale, xrot, yrot, transpose, update) + +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 +bool update #I update rather than list 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 + } + + if (! update) + call at_mwshow (mwnew, Memd[ltv], Memd[ltm], Memd[w], Memd[nr], + Memd[ncd], ndim) + + # 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) + } + if (update) { + call sk_saveim (coo, mwnew, im) + call mw_saveim (mwnew, im) + } + + # Close the wcs, + 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 + + +# AT_IMHMS -- Fetch a quantity form the image header that is in hms or dms +# format, e.g. in the form "+/-hh mm ss.x" or "+/-dd mm ss.s". + +double procedure at_imhms (im, kname) + +pointer im #I the image descriptor +char kname[ARB] #I the image keyword name + +double dval, hours, minutes, seconds +pointer sp, value +int nscan() +errchk imgstr() + +begin + call smark (sp) + call salloc (value, SZ_FNAME, TY_CHAR) + + iferr { + call imgstr (im, kname, Memc[value], SZ_FNAME) + } then { + dval = INDEFD + } else { + call sscan (Memc[value]) + call gargd (hours) + call gargd (minutes) + call gargd (seconds) + if (nscan() != 3) + dval = INDEFD + else if (hours >= 0.0d0) + dval = hours + (minutes / 60.0d0) + (seconds / 3600.0d0) + else + dval = -(abs(hours) + (minutes / 60.0d0) + (seconds / 3600.0d0)) + + } + + call sfree (sp) + + return (dval) +end diff --git a/noao/astcat/src/awcs/dcmpsv.f b/noao/astcat/src/awcs/dcmpsv.f new file mode 100644 index 00000000..5326e098 --- /dev/null +++ b/noao/astcat/src/awcs/dcmpsv.f @@ -0,0 +1,233 @@ +C This routine was copied from the stsdas$pkg/analysis/gasp/gasplib/ +C directory. See stsdas$copyright.stsdas for copyright restrictions. +C + subroutine dcmpsv (a,m,n,w,v) + parameter (nmax=1000) + real*8 a(m,n),w(n),v(n,n),rv1(nmax) + real*8 c, g, f, h, s, y, z, x, scale, anorm + + g=0.0 + scale=0.0 + anorm=0.0 + do i=1,n + l=i+1 + rv1(i)=scale*g + g=0.0 + s=0.0 + scale=0.0 + if (i.le.m) then + do k=i,m + scale=scale+dabs(a(k,i)) + enddo + if (scale.ne.0.0) then + do k=i,m + a(k,i)=a(k,i)/scale + s=s+a(k,i)*a(k,i) + enddo + f=a(i,i) + g=-dsign(dsqrt(s),f) + h=f*g-s + a(i,i)=f-g + if (i.ne.n) then + do j=l,n + s=0.0 + do k=i,m + s=s+a(k,i)*a(k,j) + enddo + f=s/h + do k=i,m + a(k,j)=a(k,j)+f*a(k,i) + enddo + enddo + endif + do k= i,m + a(k,i)=scale*a(k,i) + enddo + endif + endif + w(i)=scale *g + g=0.0 + s=0.0 + scale=0.0 + if ((i.le.m).and.(i.ne.n)) then + do k=l,n + scale=scale+dabs(a(i,k)) + enddo + if (scale.ne.0.0) then + do k=l,n + a(i,k)=a(i,k)/scale + s=s+a(i,k)*a(i,k) + enddo + f=a(i,l) + g=-dsign(dsqrt(s),f) + h=f*g-s + a(i,l)=f-g + do k=l,n + rv1(k)=a(i,k)/h + enddo + if (i.ne.m) then + do j=l,m + s=0.0 + do k=l,n + s=s+a(j,k)*a(i,k) + enddo + do k=l,n + a(j,k)=a(j,k)+s*rv1(k) + enddo + enddo + endif + do k=l,n + a(i,k)=scale*a(i,k) + enddo + endif + endif + anorm=dmax1(anorm,(dabs(w(i))+dabs(rv1(i)))) + enddo + do i=n,1,-1 + if (i.lt.n) then + if (g.ne.0.0) then + do j=l,n + v(j,i)=(a(i,j)/a(i,l))/g + enddo + do j=l,n + s=0.0 + do k=l,n + s=s+a(i,k)*v(k,j) + enddo + do k=l,n + v(k,j)=v(k,j)+s*v(k,i) + enddo + enddo + endif + do j=l,n + v(i,j)=0.0 + v(j,i)=0.0 + enddo + endif + v(i,i)=1.0 + g=rv1(i) + l=i + enddo + do i=n,1,-1 + l=i+1 + g=w(i) + if (i.lt.n) then + do j=l,n + a(i,j)=0.0 + enddo + endif + if (g.ne.0.0) then + g=1.0/g + if (i.ne.n) then + do j=l,n + s=0.0 + do k=l,m + s=s+a(k,i)*a(k,j) + enddo + f=(s/a(i,i))*g + do k=i,m + a(k,j)=a(k,j)+f*a(k,i) + enddo + enddo + endif + do j=i,m + a(j,i)=a(j,i)*g + enddo + else + do j= i,m + a(j,i)=0.0 + enddo + endif + a(i,i)=a(i,i)+1.0 + enddo + do k=n,1,-1 + do its=1,30 + do l=k,1,-1 + nm=l-1 + if ((dabs(rv1(l))+anorm).eq.anorm) go to 2 + if ((dabs(w(nm))+anorm).eq.anorm) go to 1 + enddo +1 c=0.0 + s=1.0 + do i=l,k + f=s*rv1(i) + if ((dabs(f)+anorm).ne.anorm) then + g=w(i) + h=dsqrt(f*f+g*g) + w(i)=h + h=1.0/h + c= (g*h) + s=-(f*h) + do j=1,m + y=a(j,nm) + z=a(j,i) + a(j,nm)=(y*c)+(z*s) + a(j,i)=-(y*s)+(z*c) + enddo + endif + enddo +2 z=w(k) + if (l.eq.k) then + if (z.lt.0.0) then + w(k)=-z + do j=1,n + v(j,k)=-v(j,k) + enddo + endif + go to 3 + endif + if (its.eq.30) pause 'nO CONVERGENCE IN 30 ITERATIONS' + x=w(l) + nm=k-1 + y=w(nm) + g=rv1(nm) + h=rv1(k) + f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y) + g=dsqrt(f*f+1.0) + f=((x-z)*(x+z)+h*((y/(f+dsign(g,f)))-h))/x + c=1.0 + s=1.0 + do j=l,nm + i=j+1 + g=rv1(i) + y=w(i) + h=s*g + g=c*g + z=dsqrt(f*f+h*h) + rv1(j)=z + c=f/z + s=h/z + f= (x*c)+(g*s) + g=-(x*s)+(g*c) + h=y*s + y=y*c + do nm=1,n + x=v(nm,j) + z=v(nm,i) + v(nm,j)= (x*c)+(z*s) + v(nm,i)=-(x*s)+(z*c) + enddo + z=sqrt(f*f+h*h) + w(j)=z + if (z.ne.0.0) then + z=1.0/z + c=f*z + s=h*z + endif + f= (c*g)+(s*y) + x=-(s*g)+(c*y) + do nm=1,m + y=a(nm,j) + z=a(nm,i) + a(nm,j)= (y*c)+(z*s) + a(nm,i)=-(y*s)+(z*c) + enddo + enddo + rv1(l)=0.0 + rv1(k)=f + w(k)=x + enddo +3 continue + enddo + return + end diff --git a/noao/astcat/src/awcs/dsswcs.x b/noao/astcat/src/awcs/dsswcs.x new file mode 100644 index 00000000..0fe3b169 --- /dev/null +++ b/noao/astcat/src/awcs/dsswcs.x @@ -0,0 +1,300 @@ +include <imhdr.h> +include <mwset.h> +include <math.h> + +define SZ_KEYWORD 8 +define SZ_PLATECOEFF 20 +define SZ_CDMATX 4 + +# AT_MKDSS -- Compute the FITS WCS from the general plate solution for a +# DSS image. This routine assumes that the geometry of the DSS image has not +# been modified since it was extracted, i.e. it has not been shifed,rotated, +# scaled, transposed etc. This routine has been adapted from one in the STSDAS +# GASP package, whose maim limitation for IRAF purposes was that it bypassed +# the IRAF MWCS routines. Return OK it the header is successfully updated, +# ERR otherwise. + +int procedure at_mkdss (im, update, verbose) + +pointer im #I the DSS image descriptor +bool update #I update rather than list the wcs ? +bool verbose #I verbose mode ? + +double amdx[SZ_PLATECOEFF] # the RA plate solution coefficients +double amdy[SZ_PLATECOEFF] # the DEC plate solution coefficients +double plate_cen_x # the x center position in microns +double plate_cen_y # the y center position in microns +double plate_cen_ra # the RA plate center in radians +double plate_cen_dec # the DEC plate center in radians +double x_pixel_size # the x step size in microns +double y_pixel_size # the y step size in microns +double plate_scale # the plate sclae in arcsec / mm +double im_x_center_pix # the x of ll corner of scanned plate +double im_y_center_pix # the y of ll corner of scanned plate +double ra_s # the plate center RA in seconds +double dec_s # the plate center DEC in seconds +double object_mag # the object magnitude +double object_col # the object color +int ra_h, ra_m # the plate center RA hours, minutes +int dec_d, dec_m # the plate center DEC degrees, minutes +char dec_sign # the plate center DEC sign +/- +int xcorner # the ll x of image w/r to plate +int ycorner # the ll y of image w/r to plate +int xsize # naxis1 +int ysize # naxis2 + +double crpix1, crpix2, crval1, crval2, cdmatx[SZ_CDMATX] +int i +char parname[SZ_KEYWORD] + +double imgetd() +real imgetr() +int imaccf(), imgeti() +errchk imgetr(), imgetd(), imgeti() + +begin + # Check that the image is 2D, if not it is not a DSS image. + if (IM_NDIM(im) != 2) + return (ERR) + + # See if image header contains the general plate solution. + if (imaccf (im,"PPO3 ") == NO) + return (ERR) + + # If we have an old DSS image, i.e. the one with the CRPIX rather + # than CNPIX keywords, rename CRPIX to CNPIX and proceed. + # this keyword to CNPIX and proceed. + + if (imaccf (im,"CRPIX1") == YES || imaccf (im, "CRPIX2") == YES) { + if (imaccf (im,"CRVAL1") == YES || imaccf (im, "CRVAL2") == YES) { + if (imaccf (im,"CD1_1") == NO && imaccf (im, "CD1_2") == NO && + imaccf (im, "CD2_1") == NO && imaccf (im, "CD2_2") == NO) { + # This is the case when we have CRPIX, CRVAL and no CD + # so, proceed to calculate the WCS again. + iferr (crpix1 = imgetr (im, "CRPIX1")) + return (ERR) + iferr (crpix2 = imgetr (im, "CRPIX2")) + return (ERR) + call imdelf (im, "CRPIX1") + call imaddr (im, "CNPIX1", real (crpix1)) + call imdelf (im, "CRPIX2") + call imaddr (im, "CNPIX2", real (crpix2)) + } + } else { + iferr (crpix1 = imgetr (im, "CRPIX1")) + return (ERR) + iferr (crpix2 = imgetr (im, "CRPIX2")) + return (ERR) + call imdelf (im, "CRPIX1") + call imaddr (im, "CNPIX1", real (crpix1)) + call imdelf (im, "CRPIX2") + call imaddr (im, "CNPIX2", real (crpix2)) + } + } + if (imaccf (im,"CNPIX1") == NO || imaccf (im, "CNPIX2") == NO ) + return (ERR) + + # Get the plate solution. + iferr { + + # Get the plate center parameters. + plate_cen_x = imgetd (im, "PPO3 ") + plate_cen_y = imgetd (im, "PPO6 ") + x_pixel_size = imgetd (im, "XPIXELSZ") + y_pixel_size = imgetd (im, "YPIXELSZ") + plate_scale = imgetd (im, "PLTSCALE") + ra_h = imgeti (im, "PLTRAH ") + ra_m = imgeti (im, "PLTRAM ") + ra_s = imgetd (im, "PLTRAS ") + call imgstr (im, "PLTDECSN", dec_sign, 1) + dec_d = imgeti (im, "PLTDECD ") + dec_m = imgeti (im, "PLTDECM ") + dec_s = imgetd (im, "PLTDECS ") + plate_cen_ra = DDEGTORAD ((ra_h + ra_m / 60.0d0 + ra_s / + 3600.0d0) * 15.0d0) + plate_cen_dec = DDEGTORAD (dec_d + dec_m / 60.0d0 + dec_s / + 3600.0d0) + if (dec_sign == '-') + plate_cen_dec = -plate_cen_dec + + # Get general plate solution coefficients + do i = 1, SZ_PLATECOEFF { + call sprintf (parname, SZ_KEYWORD, "AMDX%d") + call pargi(i) + amdx[i] = imgetd (im, parname) + } + do i = 1, SZ_PLATECOEFF { + call sprintf (parname, SZ_KEYWORD, "AMDY%d") + call pargi(i) + amdy[i] = imgetd (im, parname) + } + xcorner = imgetr (im, "CNPIX1") + ycorner = imgetr (im, "CNPIX2") + object_mag = 0.0d0 + object_col = 0.0d0 + } then + return (ERR) + + xsize = IM_LEN(im,1) + ysize = IM_LEN(im,2) + crpix1 = xsize / 2.0d0 + crpix2 = ysize / 2.0d0 + + # Center of image w/r to original lower left corner of scanned plate. + im_x_center_pix = xcorner + (xsize / 2.0d0) - 0.5d0 + im_y_center_pix = ycorner + (ysize / 2.0d0) - 0.5d0 + + # Calculate equatorial coordinates for the center of subset giving + # the complete plate solution w/r to the original lower left corner. + call ccgseq (plate_cen_ra, + plate_cen_dec, + plate_cen_x, + plate_cen_y, + x_pixel_size, + y_pixel_size, + plate_scale, + amdx, + amdy, + im_x_center_pix, + im_y_center_pix, + object_mag, + object_col, + crval1, + crval2) + + + # Calculate CD matrix values for the input subset from the original + # plate solution. + call calcds (plate_cen_ra, + plate_cen_dec, + plate_cen_x, + plate_cen_y, + xcorner, + ycorner, + x_pixel_size, + y_pixel_size, + plate_scale, + xsize, + ysize, + crval1, + crval2, + amdx, + amdy, + cdmatx) + + # Update the image header. + crval1 = DRADTODEG (crval1) + crval2 = DRADTODEG (crval2) + + if (verbose || ! update) + call printf (" Converting DSS wcs to FITS wcs\n") + call at_dmwcs (im, crpix1, crpix2, crval1, crval2, cdmatx, update) + + return (OK) +end + +define NEWCD Memd[ncd+(($2)-1)*ndim+($1)-1] + +# AT_DMWCS -- Create new image WCS from the approximation to the DSS plate +# solution. This routine assumes that the geometry of the DSS image has +# not been changed since since the image has been exracted from the image +# survey. + +procedure at_dmwcs (im, xref, yref, lngref, latref, cdmatx, update) + +pointer im #I pointer to the input image +double xref, yref #I the reference point in pixels +double lngref, latref #I the reference point in degrees +double cdmatx[ARB] #I CD1_1, CD1_2, CD2_1, CD2_2 +bool update #I update rather than list the wcs ? + +pointer mw, mwnew +pointer sp, projstr, r, w, cd, ltm, ltv, iltm, nr, ncd, axno, axval, axes +int ndim, ax1, ax2, naxes +pointer mw_openim(), mw_open() +int mw_stati() +errchk mw_newsystem() + +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_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 (axno, IM_MAXDIM, TY_INT) + call salloc (axval, IM_MAXDIM, TY_INT) + call salloc (axes, IM_MAXDIM, TY_INT) + + # Open the new wcs. + mwnew = mw_open (NULL, ndim) + call mw_gsystem (mw, Memc[projstr], SZ_LINE) + 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) + ax1 = Memi[axes] + ax2 = Memi[axes+1] + + # Set the axes and projection type. + call sprintf (Memc[projstr], SZ_LINE, + "axis 1: axtype = ra axis 2: axtype = dec ") + call mw_swtype (mwnew, Memi[axes], ndim, "tan", Memc[projstr]) + + # Set the reference point world coordinates. + Memd[w+ax1-1] = lngref + Memd[w+ax2-1] = latref + + # Set the reference point pixel coordinates. + Memd[nr+ax1-1] = xref + Memd[nr+ax2-1] = yref + + # Compute the new CD matrix. + NEWCD(ax1,ax1) = cdmatx[1] # xscale * cos (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(ax2,ax1) = cdmatx[2] # -yscale * sin (DEGTORAD(yrot)) / 3600.0d0 + NEWCD(ax1,ax2) = cdmatx[3] # xscale * sin (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(ax2,ax2) = cdmatx[4] # yscale * cos (DEGTORAD(yrot)) / 3600.0d0 + + # List the new wcs. + if (! update) + call at_mwshow (mwnew, Memd[ltv], Memd[ltm], Memd[w], Memd[nr], + Memd[ncd], ndim) + + # Recompute and store the new wcs. + call mw_saxmap (mwnew, Memi[axno], Memi[axval], 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 (mwnew, Memd[nr], Memd[w], Memd[cd], ndim) + + # Update the image wcs. + if (update) + call mw_saveim (mwnew, im) + + call mw_close (mwnew) + call mw_close (mw) + + call sfree (sp) +end diff --git a/noao/astcat/src/awcs/fitsvd.f b/noao/astcat/src/awcs/fitsvd.f new file mode 100644 index 00000000..bb8d0f4e --- /dev/null +++ b/noao/astcat/src/awcs/fitsvd.f @@ -0,0 +1,38 @@ +C This routine was copied from the stsdas$pkg/analysis/gasp/gasplib/ +C directory. See stsdas$copyright.stsdas for copyright restrictions. +C + subroutine fitsvd (x, y, wg, npts, coef, nterms, + * u, v, w, chisq) + parameter(nmax=1000,mmax=50,tol=1.d-14) + + real wg(npts) + real*8 x(npts,nterms), y(npts), coef(nterms), v(nterms,nterms), + * u(npts,nterms), w(nterms), b(nmax) + real*8 wmax, thresh, chisq, sum + + do i=1,npts + do j=1,nterms + u(i,j)=x(i,j)*wg(i) + enddo + b(i)=y(i)*wg(i) + enddo + call dcmpsv (u,npts,nterms,w,v) + wmax=0. + do j=1,nterms + if(w(j).gt.wmax) wmax=w(j) + enddo + thresh=tol*wmax + do j=1,nterms + if(w(j).lt.thresh) w(j)=0. + enddo + call ksbsvd (u, w, v, npts, nterms, b, coef) + chisq=0. + do i=1,npts + sum=0. + do j=1,nterms + sum=sum+coef(j)*x(i,j) + enddo + chisq=chisq+((y(i)-sum)*wg(i))**2 + enddo + return + end diff --git a/noao/astcat/src/awcs/ksbsvd.f b/noao/astcat/src/awcs/ksbsvd.f new file mode 100644 index 00000000..3c78ec23 --- /dev/null +++ b/noao/astcat/src/awcs/ksbsvd.f @@ -0,0 +1,27 @@ +C This routines was copied from the stsdas$pkg/analysis/gasp/gasplib/ +C directory. See the file stsdas$copyright.stsdas for copyright +C restrictions. + subroutine ksbsvd (u,w,v,m,n,b,x) + parameter (nmax=1000) + real*8 u(m,n),w(n),v(n,n),b(m),x(n),tmp(nmax) + real*8 s + + do j=1,n + s=0. + if(w(j).ne.0.)then + do i=1,m + s=s+u(i,j)*b(i) + enddo + s=s/w(j) + endif + tmp(j)=s + enddo + do j=1,n + s=0. + do jj=1,n + s=s+v(j,jj)*tmp(jj) + enddo + x(j)=s + enddo + return + end diff --git a/noao/astcat/src/awcs/mkpkg b/noao/astcat/src/awcs/mkpkg new file mode 100644 index 00000000..29160f2a --- /dev/null +++ b/noao/astcat/src/awcs/mkpkg @@ -0,0 +1,22 @@ +# AWCS task subdirectory + +$checkout libpkg.a "../" +$update libpkg.a +$checkin libpkg.a "../" +$exit + +libpkg.a: + dsswcs.x <imhdr.h> <mwset.h> <math.h> + dbwcs.x <imhdr.h> <mwset.h> <math.h> <pkg/skywcs.h> <pkg/cq.h> + parswcs.x <imhdr.h> "../../lib/astrom.h" "../../lib/aimpars.h" \ + <pkg/skywcs.h> + atmwshow.x + ccqseq.x + calcds.x <math.h> + trsteq.x <math.h> + treqst.x + dcmpsv.f + fitsvd.f + ksbsvd.f + varsvd.f + ; diff --git a/noao/astcat/src/awcs/parswcs.x b/noao/astcat/src/awcs/parswcs.x new file mode 100644 index 00000000..56cf33f2 --- /dev/null +++ b/noao/astcat/src/awcs/parswcs.x @@ -0,0 +1,251 @@ +include <imhdr.h> +include "../../lib/astrom.h" +include "../../lib/aimpars.h" +include <pkg/skywcs.h> + + +# AT_PARWCS -- Compute a FITS WCS from an image using WCS definitions +# read from the AWCSPARS parameter file and stored in the astromery +# package descriptor. At the moment I am going to keep this routine simple +# by not worrying about the units of any quantities but the world coordinates +# of the reference point. This routine can be made more sophisticated later +# as time permits. The information is there ... + +int procedure at_parwcs (im, at, update, verbose) + +pointer im #I the input image descriptor +pointer at #I the astrometry package descriptor +bool update #I update rather than list the wcs +bool verbose #I verbose mode ? + +double xref, yref, xmag, ymag, xrot, yrot, lngref, latref, dval +pointer sp, wfield, wtype, ctype, wcst, sym, coo, mw +int i, wkey, lngunits, latunits, coostat, stat +double at_imhms(), imgetd(), at_statd() +pointer at_statp(), stfind() +int at_wrdstr(), at_stati(), sk_decwcs() +bool streq() +errchk imgetd() + +begin + # Return if the input is not 2D. + if (IM_NDIM(im) != 2) + return (ERR) + + # Return if the wcs pointer is undefined. + if (at_statp (at, PWCS) == NULL) + return (ERR) + + # Return if the keyword symbol table is undefined. + wcst = at_statp (at, WCST) + if (wcst == NULL) + return (ERR) + + # Allocate working space. + call smark (sp) + call salloc (wfield, SZ_FNAME, TY_CHAR) + call salloc (wtype, SZ_FNAME, TY_CHAR) + call salloc (ctype, SZ_FNAME, TY_CHAR) + + # Initialize. + xref = (1.0d0 + IM_LEN(im,1)) / 2.0d0 + yref = (1.0d0 + IM_LEN(im,2)) / 2.0d0 + xmag = INDEFD + ymag = INDEFD + xrot = 180.0d0 + yrot= 0.0d0 + lngref = INDEFD + latref = INDEFD + lngunits = 0 + latunits = 0 + call strcpy ("tan", Memc[wtype], SZ_FNAME) + call strcpy ("J2000", Memc[ctype], SZ_FNAME) + + do i = 1, AT_NWFIELDS { + + # Which keyword have we got ? + wkey = at_wrdstr (i, Memc[wfield], SZ_FNAME, AT_WFIELDS) + + switch (wkey) { + + # Get the x reference point in pixels. + case WCS_WXREF: + sym = stfind (wcst, Memc[wfield]) + if (sym != NULL) { + if (streq (AT_WCSTKVAL(sym), "INDEF")) + dval = at_statd (at, WXREF) + else iferr (dval = imgetd (im, AT_WCSTKVAL(sym))) + dval = at_statd (at, WXREF) + } else + dval = at_statd (at, WXREF) + if (! IS_INDEFD(dval)) + xref = dval + + case WCS_WYREF: + sym = stfind (wcst, Memc[wfield]) + if (sym != NULL) { + if (streq (AT_WCSTKVAL(sym), "INDEF")) + dval = at_statd (at, WYREF) + else iferr (dval = imgetd (im, AT_WCSTKVAL(sym))) + dval = at_statd (at, WYREF) + } else + dval = at_statd (at, WYREF) + if (! IS_INDEFD(dval)) + yref = dval + + case WCS_WXMAG: + sym = stfind (wcst, Memc[wfield]) + if (sym != NULL) { + if (streq (AT_WCSTKVAL(sym), "INDEF")) + dval = at_statd (at, WXMAG) + else iferr (dval = imgetd (im, AT_WCSTKVAL(sym))) + dval = at_statd (at, WXMAG) + } else + dval = at_statd (at, WXMAG) + if (! IS_INDEFD(dval)) + xmag = dval + + case WCS_WYMAG: + sym = stfind (wcst, Memc[wfield]) + if (sym != NULL) { + if (streq (AT_WCSTKVAL(sym), "INDEF")) + dval = at_statd (at, WYMAG) + else iferr (dval = imgetd (im, AT_WCSTKVAL(sym))) + dval = at_statd (at, WYMAG) + } else + dval = at_statd (at, WYMAG) + if (! IS_INDEFD(dval)) + ymag = dval + + case WCS_WXROT: + sym = stfind (wcst, Memc[wfield]) + if (sym != NULL) { + if (streq (AT_WCSTKVAL(sym), "INDEF")) + dval = at_statd (at, WXROT) + else iferr (dval = imgetd (im, AT_WCSTKVAL(sym))) + dval = at_statd (at, WXROT) + } else + dval = at_statd (at, WXROT) + if (! IS_INDEFD(dval)) + xrot = dval + + case WCS_WYROT: + sym = stfind (wcst, Memc[wfield]) + if (sym != NULL) { + if (streq (AT_WCSTKVAL(sym), "INDEF")) + dval = at_statd (at, WYROT) + else iferr (dval = imgetd (im, AT_WCSTKVAL(sym))) + dval = at_statd (at, WYROT) + } else + dval = at_statd (at, WYROT) + if (! IS_INDEFD(dval)) + yrot = dval + + case WCS_WRAREF: + sym = stfind (wcst, Memc[wfield]) + if (sym != NULL) { + if (streq (AT_WCSTKVAL(sym), "INDEF")) + dval = at_statd (at, WRAREF) + else { + dval = at_imhms (im, AT_WCSTKVAL(sym)) + if (IS_INDEFD(dval)) { + iferr (dval = imgetd (im, AT_WCSTKVAL(sym))) + dval = at_statd (at, WRAREF) + } + } + } else + dval = at_statd (at, WRAREF) + if (! IS_INDEFD(dval)) + lngref = dval + + case WCS_WDECREF: + sym = stfind (wcst, Memc[wfield]) + if (sym != NULL) { + if (streq (AT_WCSTKVAL(sym), "INDEF")) + dval = at_statd (at, WDECREF) + else { + dval = at_imhms (im, AT_WCSTKVAL(sym)) + if (IS_INDEFD(dval)) { + iferr (dval = imgetd (im, AT_WCSTKVAL(sym))) + dval = at_statd (at, WDECREF) + } + } + } else + dval = at_statd (at, WDECREF) + if (! IS_INDEFD(dval)) + latref = dval + + case WCS_WRAUNITS: + lngunits = at_stati (at, WRAUNITS) + + case WCS_WDECUNITS: + latunits = at_stati (at, WDECUNITS) + + case WCS_WPROJ: + sym = stfind (wcst, Memc[wfield]) + if (sym != NULL) { + if (streq (AT_WCSTKVAL(sym), "INDEF")) + call at_stats (at, WPROJ, Memc[wtype], SZ_FNAME) + else iferr (call imgstr (im, AT_WCSTKVAL(sym), Memc[wtype], + SZ_FNAME)) + call at_stats (at, WPROJ, Memc[wtype], SZ_FNAME) + } else + call at_stats (at, WPROJ, Memc[wtype], SZ_FNAME) + if (streq (Memc[wtype], "INDEF")) + call strcpy ("tan", Memc[wtype], SZ_FNAME) + + case WCS_WSYSTEM: + sym = stfind (wcst, Memc[wfield]) + if (sym != NULL) { + if (streq (AT_WCSTKVAL(sym), "INDEF")) + call at_stats (at, WSYSTEM, Memc[ctype], SZ_FNAME) + else iferr (call imgstr (im, AT_WCSTKVAL(sym), Memc[ctype], + SZ_FNAME)) + call at_stats (at, WSYSTEM, Memc[ctype], SZ_FNAME) + } else + call at_stats (at, WSYSTEM, Memc[ctype], SZ_FNAME) + if (streq (Memc[ctype], "INDEF")) + call strcpy ("J2000", Memc[ctype], SZ_FNAME) + + default: + ; + } + } + + # Update the header. + if (IS_INDEFD(xmag) || IS_INDEFD(ymag) || IS_INDEFD(lngref) || + IS_INDEFD(latref)) { + + stat = ERR + + } else { + + # Open coordinate system struct + coostat = sk_decwcs (Memc[ctype], mw, coo, NULL) + + if (coostat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + stat = ERR + } else { + if (verbose) + call printf ( + " Writing FITS wcs using default parameters\n") + if (lngunits > 0) + call sk_seti (coo, S_NLNGUNITS, lngunits) + if (latunits > 0) + call sk_seti (coo, S_NLATUNITS, latunits) + call at_uwcs (im, coo, Memc[wtype], lngref, latref, xref, + yref, xmag, ymag, xrot, yrot, false, update) + stat = OK + } + + # Close the coordinate structure + if (coo != NULL) + call sk_close (coo) + } + + call sfree (sp) + + return (stat) +end diff --git a/noao/astcat/src/awcs/treqst.x b/noao/astcat/src/awcs/treqst.x new file mode 100644 index 00000000..c4cd27e5 --- /dev/null +++ b/noao/astcat/src/awcs/treqst.x @@ -0,0 +1,49 @@ +# This routine was copied from the stsdas$pkg/analysis/gasp/gasplib/ +# directory. See stsdas$copyright.stsdas for copyright restrictions. +# + +define ARCSEC_PER_RADIAN 206264.8062470964d0 + +# TREQST -- Procedure to convert RA and Dec to standard coordinates +# given the plate centre. + +procedure treqst (plate_centre_ra, plate_centre_dec, object_ra, object_dec, + xi_object, eta_object) + +double plate_centre_ra #I plate ra center (radians) +double plate_centre_dec #I plate dec center (radians) +double object_ra #I object ra center (radians) +double object_dec #I object dec center (radians) +double xi_object #O object xi standard coordinate (arcsecs) +double eta_object #O object eta standard coordinate (arcsecs) + +#double div +double ra, cosra, sinra, cosdec, sindec, cosd0, sind0, cosdist + +begin + ra = object_ra - plate_centre_ra + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (object_dec) + sindec = sin (object_dec) + cosd0 = cos (plate_centre_dec) + sind0 = sin (plate_centre_dec) + cosdist = sindec * sind0 + cosdec * cosd0 * cosra + xi_object = cosdec * sinra * ARCSEC_PER_RADIAN / cosdist + eta_object = (sindec * cosd0 - cosdec * sind0 * cosra) * + ARCSEC_PER_RADIAN / cosdist + +# # Find the divisor. +# div = (sin(object_dec) * sin(plate_centre_dec) + +# cos(object_dec) * cos(plate_centre_dec) * +# cos(object_ra -plate_centre_ra)) +# +# # Compute standard coords and convert to arcsec +# xi_object = cos(object_dec) * sin(object_ra-plate_centre_ra) * +# ARCSEC_PER_RADIAN/div +# eta_object = (sin(object_dec) * cos(plate_centre_dec) - +# cos(object_dec) * dsin(plate_centre_dec) * +# cos(object_ra - plate_centre_ra)) * +# ARCSEC_PER_RADIAN/div + +end diff --git a/noao/astcat/src/awcs/trsteq.x b/noao/astcat/src/awcs/trsteq.x new file mode 100644 index 00000000..5fa5ea8e --- /dev/null +++ b/noao/astcat/src/awcs/trsteq.x @@ -0,0 +1,64 @@ +# This routine was copied from stsdas$pkg/asnalysis/gasp/gasplib/. See +# stsdas$copyright.stsdas for copyright restrictions. +# +include <math.h> + +define ARCSEC_PER_RADIAN 206264.8062470964d0 + +# TRSTEQ -- Procedure to compute the RA and DEC from the standard coordinates +# given the plate centre. + +procedure trsteq (plate_centre_ra, plate_centre_dec, xi, eta, ra, dec) + +double plate_centre_ra #I plate center ra (radians) +double plate_centre_dec #I plate center dec (radians) +double xi #I xi standard coordinate (arcsec) +double eta #I eta standard coordinate (arcsec) +double ra #O ra (radians) +double dec #O dec (radians) + +#double object_xi, object_eta, numerator, denominator +double object_xi, object_eta, x, y, z + +begin + # Convert from arcseconds to radians. + object_xi = xi/ARCSEC_PER_RADIAN + object_eta = eta/ARCSEC_PER_RADIAN + + # Convert to RA and Dec + x = cos (plate_centre_dec) - object_eta * sin (plate_centre_dec) + y = object_xi + z = sin (plate_centre_dec) + object_eta * cos (plate_centre_dec) + + if (x == 0.0d0 && y == 0.0d0) + ra = 0.0d0 + else + ra = atan2 (y, x) + dec = atan2 (z, sqrt (x * x + y * y)) + ra = ra + plate_centre_ra + if (ra < 0.0d0) + ra = ra + DTWOPI + else if (ra > DTWOPI) + ra = ra - DTWOPI + +## numerator = object_xi / dcos(plate_centre_dec) +# numerator = object_xi +# +## denominator = 1.0d0 - object_eta * dtan(plate_centre_dec) +# denominator = cos (plate_centre_dec) - +# object_eta * sin (plate_centre_dec) +# ra = atan2 (numerator,denominator) + plate_centre_ra +# if (ra < 0.0d0) +# ra = ra + DTWOPI +# else if (ra > DTWOPI) +# ra = ra - DTWOPI +# +## numerator = dcos(ra-plate_centre_ra) * +## (object_eta + dtan(plate_centre_dec)) +# numerator = cos (ra - plate_centre_ra) * +# (cos (plate_centre_dec) * object_eta + sin (plate_centre_dec)) +## denominator = 1.0d0 - object_eta * dtan(plate_centre_dec) +# denominator = cos (plate_centre_dec) - object_eta * +# sin (plate_centre_dec) +# dec = atan2 (numerator, denominator) +end diff --git a/noao/astcat/src/awcs/varsvd.f b/noao/astcat/src/awcs/varsvd.f new file mode 100644 index 00000000..b779a1e0 --- /dev/null +++ b/noao/astcat/src/awcs/varsvd.f @@ -0,0 +1,24 @@ +C This routine was copied from stsdas$pkg/analysis/gasp/gasplib/. +C See stsdas$copyright.stsdas for copyright restrictions. +C + subroutine varsvd (v,ma,w,cvm,ncvm) + parameter (mmax=20) + real*8 v(ma,ma),w(ma),cvm(ncvm,ncvm),wti(mmax) + real*8 sum + + do i=1,ma + wti(i)=0. + if(w(i).ne.0.0d0) wti(i)=1./(w(i)*w(i)) + enddo + do i=1,ma + do j=1,i + sum=0. + do k=1,ma + sum=sum+v(i,k)*v(j,k)*wti(k) + enddo + cvm(i,j)=sum + cvm(j,i)=sum + enddo + enddo + return + end diff --git a/noao/astcat/src/awcspars.par b/noao/astcat/src/awcspars.par new file mode 100644 index 00000000..9bf51d8a --- /dev/null +++ b/noao/astcat/src/awcspars.par @@ -0,0 +1,18 @@ +# The AWCSPARS parameter set + +wxref,s,h,"INDEF",,,"The x axis reference pixel" +wyref,s,h,"INDEF",,,"The y axis reference pixel" +wxmag,s,h,"INDEF",,,"The x axis image scale in arcseconds per pixel" +wymag,s,h,"INDEF",,,"The y axis image scale in arcseconds per pixel" +wxrot,s,h,"180.0",,,"The x axis rotation in degrees" +wyrot,s,h,"0.0",,,"The y axis rotation in degrees" +wraref,s,h,"RA",,,"The ra / longitude of the image reference point" +wdecref,s,h,"DEC",,,"The dec / latitude of the image reference point" +wraunits,s,h,"",,,The ra / longitude reference units +wdecunits,s,h,"",,,The dec / latitude reference units +wproj,s,h,tan,,,"The image projection geometry" +wsystem,s,h,"EQUINOX",,,"The image coordinate system" +#wradecsys,s,h,"RADECSYS",,,The equatorial reference frame +#wequinox,s,h,"EQUINOX",,,The equinox in years +#wmjdobs,s,h,"MJD-OBS",,,The MJD of the observation +mode,s,h,"ql",,, diff --git a/noao/astcat/src/debug/mkpkg b/noao/astcat/src/debug/mkpkg new file mode 100644 index 00000000..9546b422 --- /dev/null +++ b/noao/astcat/src/debug/mkpkg @@ -0,0 +1,15 @@ +# Catalog query and access tools subdirectory + +$checkout libpkg.a ".." +$update libpkg.a +$checkin libpkg.a ".." +$exit + +libpkg.a: + t_acqctest.x <pkg/cq.h> + t_acqftest.x <pkg/cq.h> + t_adumpcat.x <fset.h> <pkg/cq.h> + t_adumpim.x <mach.h> <fset.h> <pkg/cq.h> + t_acqitest.x <pkg/cq.h> + zzdebug.x <fset.h> + ; diff --git a/noao/astcat/src/debug/t_acqctest.x b/noao/astcat/src/debug/t_acqctest.x new file mode 100644 index 00000000..e59fb80d --- /dev/null +++ b/noao/astcat/src/debug/t_acqctest.x @@ -0,0 +1,304 @@ +include <pkg/cq.h> + +# T_ACQCTEST -- Test basic catalog database access and query procedures. + +procedure t_acqctest () + +double dval1, dval2 +real width, rval1, rval2 +long lval1, lval2 +pointer cq, sp, reclist, res +int i, ip, catno, nqpars, parno, nres, recptr, nchars, foffset, fsize +int ftype, nfields, ival1, ival2 +short sval1, sval2 +char database[SZ_FNAME], record[SZ_LINE], ra[SZ_FNAME], dec[SZ_FNAME] +char str[SZ_FNAME], catalog[SZ_LINE] +char qpname[CQ_SZ_QPNAME], qpvalue[CQ_SZ_QPVALUE], qpunits[CQ_SZ_QPUNITS] +char qpformats[CQ_SZ_QPFMTS] + +real clgetr() +pointer cq_map(), cq_query() +int cq_stati(), cq_statt(), cq_setcat(), cq_setcatn(), cq_nqpars() +int cq_gqpar(), cq_gqparn(), cq_sqpar(), ctod(), cq_rstati() +int cq_gnrecord(), cq_grecord(), cq_finfon(), cq_finfo(), cq_fname() +int cq_foffset(), cq_fsize(), cq_ftype(), cq_gvali(), cq_hinfo() +int cq_gvalc(), cq_gvald(), cq_gvalr(), cq_gvall(), cq_gvals(), cq_hinfon() +bool streq() + +begin + # Get the database and record names. + call clgstr ("record", record, SZ_LINE) + call clgstr ("ra", ra, SZ_FNAME) + call clgstr ("dec", dec, SZ_FNAME) + width = clgetr ("width") + call clgstr ("database", database, SZ_FNAME) + + # Map the database. + cq = cq_map (database, READ_ONLY) + + # Print the database file name and number of records. + call cq_stats (cq, CQCATDB, database, SZ_FNAME) + call printf ("\nDatabase: %s Nrecs: %d\n\n") + call pargstr (database) + call pargi (cq_stati (cq, CQNRECS)) + + # Print the record list. + call printf ("Szreclist = %d characters\n") + call pargi (cq_stati (cq, CQSZRECLIST)) + + call smark (sp) + call salloc (reclist, cq_stati(cq, CQSZRECLIST), TY_CHAR) + if (cq_statt (cq, CQRECLIST, Memc[reclist], cq_stati(cq, + CQSZRECLIST)) <= 0) + Memc[reclist] = EOS + call printf ("%s") + call pargstr (Memc[reclist]) + call sfree (sp) + + # Print the current catalog name and number. + call cq_stats (cq, CQCATNAME, catalog, SZ_LINE) + call printf ("\nCurrent catalog: %s index: %d\n") + call pargstr (catalog) + call pargi (cq_stati (cq, CQCATNO)) + + # Set the current catalog by name. + catno = cq_setcat (cq, record) + call cq_stats (cq, CQCATNAME, catalog, SZ_LINE) + call printf ("\nCurrent catalog: %s index: %d\n") + call pargstr (catalog) + call pargi (cq_stati (cq, CQCATNO)) + + # Set the same catalog by number. + catno = cq_setcatn (cq, catno) + call cq_stats (cq, CQCATNAME, catalog, SZ_LINE) + call printf ("\nCurrent catalog: %s index: %d\n\n") + call pargstr (catalog) + call pargi (cq_stati (cq, CQCATNO)) + + # Set the query parameters. Don't worry about units in this case. + nqpars = cq_nqpars (cq) + do i = 1, nqpars { + + # Get description of each query parameter. + parno = cq_gqparn (cq, i, qpname, CQ_SZ_QPNAME, qpvalue, + CQ_SZ_QPVALUE, qpunits, CQ_SZ_QPUNITS, qpformats, CQ_SZ_QPFMTS) + call printf ("parno: %d %s %s %s %s\n") + call pargi (parno) + call pargstr (qpname) + call pargstr (qpvalue) + call pargstr (qpunits) + call pargstr (qpformats) + parno = cq_gqpar (cq, qpname, qpname, CQ_SZ_QPNAME, qpvalue, + CQ_SZ_QPVALUE, qpunits, CQ_SZ_QPUNITS, qpformats, CQ_SZ_QPFMTS) + call printf ("parno: %d %s %s %s %s\n") + call pargi (parno) + call pargstr (qpname) + call pargstr (qpvalue) + call pargstr (qpunits) + call pargstr (qpformats) + + + # Set the astrometric parameters. + if (streq (qpname, "ra")) { + ip = 1 + if (ctod (ra, ip, dval1) > 0) { + call sprintf (ra, SZ_FNAME, qpformats) + call pargd (dval1) + } + parno = cq_sqpar (cq, qpname, ra) + } else if (streq (qpname, "dec")) { + ip = 1 + if (ctod (dec, ip, dval1) > 0) { + if (dval1 >= 0.0) { + #dec[1] = '+' + #call sprintf (dec[2], SZ_FNAME - 1, qpformats) + call sprintf (dec, SZ_FNAME, qpformats) + } else { + call sprintf (dec, SZ_FNAME, qpformats) + } + call pargd (dval1) + } + parno = cq_sqpar (cq, qpname, dec) + } else if (streq (qpname, "width")) { + call sprintf (str, SZ_FNAME, qpformats) + call pargr (width) + parno = cq_sqpar (cq, qpname, str) + } else if (streq (qpname, "radius")) { + call sprintf (str, SZ_FNAME, qpformats) + call pargr (width / 2.0) + parno = cq_sqpar (cq, qpname, str) + } + + } + call flush (STDOUT) + + # Send the query and get back the results. + res = cq_query (cq) + if (res == NULL) + return + + call cq_rstats (res, CQRADDRESS, str, SZ_FNAME) + call printf ("\nraddress: %s\n") + call pargstr (str) + call cq_rstats (res, CQRQUERY, str, SZ_FNAME) + call printf ("rquery: %s\n") + call pargstr (str) + call cq_rstats (res, CQRQPNAMES, str, SZ_FNAME) + call printf ("rqpnames:%s\n") + call pargstr (str) + call cq_rstats (res, CQRQPVALUES, str, SZ_FNAME) + call printf ("rqpvalues:%s\n") + call pargstr (str) + + # Get the number of header parameters. + nfields = cq_rstati (res, CQNHEADER) + call printf ("nheader = %d\n") + call pargi (nfields) + + # Print the information for each field. + do i = 1, nfields { + if (cq_hinfon (res, i, qpname, CQ_SZ_QPNAME, record, SZ_LINE) <= 0) + next + call printf ("keyword: %d %s %s\n") + call pargi (i) + call pargstr (qpname) + call pargstr (record) + if (cq_hinfo (res, qpname, record, SZ_LINE) <= 0) + next + call printf ("keyword: %d %s %s\n") + call pargi (i) + call pargstr (qpname) + call pargstr (record) + } + call printf ("\n") + + # Get the number of fields. + nfields = cq_rstati (res, CQNFIELDS) + call printf ("nfields = %d\n") + call pargi (nfields) + + # Print the information for each field. + do i = 1, nfields { + if (cq_finfon (res, i, qpname, CQ_SZ_FNAME, foffset, fsize, + ftype, qpunits, CQ_SZ_FUNITS, qpformats, CQ_SZ_FFMTS) <= 0) + next + call printf ("field: %d %s %d %d %d %s %s\n") + call pargi (i) + call pargstr (qpname) + call pargi (foffset) + call pargi (fsize) + call pargi (ftype) + call pargstr (qpunits) + call pargstr (qpformats) + if (cq_finfo (res, qpname, foffset, fsize, ftype, qpunits, + CQ_SZ_FUNITS, qpformats, CQ_SZ_FFMTS) <= 0) + next + call printf ("field: %d %s %d %d %d %s %s\n") + call pargi (i) + call pargstr (qpname) + call pargi (foffset) + call pargi (fsize) + call pargi (ftype) + call pargstr (qpunits) + call pargstr (qpformats) + if (cq_fname (res, i, qpname, CQ_SZ_FNAME) <= 0) + next + foffset = cq_foffset (res, qpname) + fsize = cq_fsize (res, qpname) + ftype = cq_ftype (res, qpname) + call cq_funits (res, qpname, qpunits, CQ_SZ_FUNITS) + call cq_ffmts (res, qpname, qpformats, CQ_SZ_FFMTS) + call printf ("field: %d %s %d %d %d %s %s\n") + call pargi (i) + call pargstr (qpname) + call pargi (foffset) + call pargi (fsize) + call pargi (ftype) + call pargstr (qpunits) + call pargstr (qpformats) + } + call printf ("\n") + + # Get the number of records. + nres = cq_rstati (res, CQRNRECS) + call printf ("nrecords = %d\n") + call pargi (nres) + + # Loop through and print the records. + recptr = 0 + while (recptr < nres) { + nchars = cq_gnrecord (res, record, SZ_LINE, recptr) + if (nchars == EOF) + break + call printf ("record %4d %4d %s") + call pargi (recptr) + call pargi (nchars) + call pargstr (record) + } + + # Find and print records at random. + record[1] = EOS + nchars = cq_grecord (res, record, SZ_LINE, 1) + call printf ("\nrecord %4d %4d %s") + call pargi (1) + call pargi (nchars) + call pargstr (record) + + record[1] = EOS + nchars = cq_grecord (res, record, SZ_LINE, (1 + nres) / 2) + call printf ("record %4d %4d %s") + call pargi ((1 + nres) / 2) + call pargi (nchars) + call pargstr (record) + + record[1] = EOS + nchars = cq_grecord (res, record, SZ_LINE, nres) + call printf ("record %4d %4d %s") + call pargi (nres) + call pargi (nchars) + call pargstr (record) + + # Loop through the records and decode the ra and dec fields as + # char, double precision, real precision, and integer fields. + call printf ("\nra dec\n") + do i = 1, nres { + call printf ("rec %d\n") + call pargi (i) + nchars = cq_gvalc (res, i, "ra", ra, SZ_FNAME) + nchars = cq_gvalc (res, i, "dec", dec, SZ_FNAME) + call printf (" %s %s\n") + call pargstr (ra) + call pargstr (dec) + nchars = cq_gvald (res, i, "ra", dval1) + nchars = cq_gvald (res, i, "dec", dval2) + call printf (" %h %h\n") + call pargd (dval1) + call pargd (dval2) + nchars = cq_gvalr (res, i, "ra", rval1) + nchars = cq_gvalr (res, i, "dec", rval2) + call printf (" %h %h\n") + call pargr (rval1) + call pargr (rval2) + nchars = cq_gvall (res, i, "ra", lval1) + nchars = cq_gvall (res, i, "dec", lval2) + call printf (" %h %h\n") + call pargl (lval1) + call pargl (lval2) + nchars = cq_gvali (res, i, "ra", ival1) + nchars = cq_gvali (res, i, "dec", ival2) + call printf (" %h %h\n") + call pargi (ival1) + call pargi (ival2) + nchars = cq_gvals (res, i, "ra", sval1) + nchars = cq_gvals (res, i, "dec", sval2) + call printf (" %h %h\n") + call pargs (sval1) + call pargs (sval2) + } + + # Close the query descriptor. + call cq_rclose (res) + + # Unmap the database. + call cq_unmap (cq) +end diff --git a/noao/astcat/src/debug/t_acqftest.x b/noao/astcat/src/debug/t_acqftest.x new file mode 100644 index 00000000..fd896fb7 --- /dev/null +++ b/noao/astcat/src/debug/t_acqftest.x @@ -0,0 +1,244 @@ +include <pkg/cq.h> + +# T_ACQFTEXT -- Procedure to use the catalog access API routines to make +# an astrometry text file look like the results of a database query. +# There are two cases: 1) the astrometry file has a simple header record +# generated by an astrometry package routine and 2) the calling program +# get this information from another source and set it. + +procedure t_acqftest() + +double dval1, dval2 +real rval1, rval2 +long lval1, lval2 +int ival1, ival2 +short sval1, sval2 + +pointer cq, res +int i, catno, nqpars, fd, nlines, nfields, nres, foffset, fsize, ftype +int recptr, nchars +char textfile[SZ_FNAME], record[SZ_FNAME], database[SZ_FNAME] +char catalog[SZ_FNAME], hdrtext[SZ_LINE], str[SZ_FNAME] +char qpname[CQ_SZ_QPNAME], qpunits[CQ_SZ_QPUNITS], qpformats[CQ_SZ_QPFMTS] +char ra[SZ_FNAME], dec[SZ_FNAME] + +pointer cq_map(), cq_fquery() +int cq_setcat(), cq_stati(), cq_nqpars(), open(), at_gcathdr() +int cq_rstati(), cq_finfon(), cq_finfo(), cq_fname() +int cq_foffset(), cq_ftype(), cq_fsize(), cq_grecord(), cq_gnrecord() +int cq_gvali(), at_pcathdr(), cq_hinfon(), cq_hinfo() +int cq_gvald(), cq_gvalr(), cq_gvall(), cq_gvals(), cq_gvalc() + +begin + # Get the parameters. + call clgstr ("textfile", textfile, SZ_FNAME) + call clgstr ("record", record, SZ_FNAME) + call clgstr ("database", database, SZ_FNAME) + + # Map the database. + cq = cq_map (database, READ_ONLY) + + # Set the current catalog by name. In this case the catalog record + # is the dummy record "text". + catno = cq_setcat (cq, record) + call cq_stats (cq, CQCATNAME, catalog, SZ_LINE) + call printf ("\nCurrent catalog: %s index: %d\n") + call pargstr (catalog) + call pargi (cq_stati (cq, CQCATNO)) + call flush (STDOUT) + + # Get the number of query parameters. This should be zero in this + # case. + nqpars = cq_nqpars (cq) + call printf ("nqpars = %d\n") + call pargi (nqpars) + + # Read the catalog header. + fd = open (textfile, READ_ONLY, TEXT_FILE) + nlines = at_gcathdr (fd, hdrtext, SZ_LINE) + call printf ("catalog header text: nlines = %d\n%s\n") + call pargi (nlines) + call pargstr (hdrtext) + call close (fd) + + # If the catalog has no header then create one from the acatpars + # pset. + if (nlines <= 0) { + nlines = at_pcathdr ("acatpars", hdrtext, SZ_LINE) + call printf ("catalog header text: nlines = %d\n%s\n") + call pargi (nlines) + call pargstr (hdrtext) + } + + # Read in the catalog and make it look like a query. + res = cq_fquery (cq, textfile, hdrtext) + if (res == NULL) + return + + # Print basic query info. + call cq_rstats (res, CQRADDRESS, str, SZ_FNAME) + call printf ("\nraddress: %s\n") + call pargstr (str) + call cq_rstats (res, CQRQUERY, str, SZ_FNAME) + call printf ("rquery: %s\n") + call pargstr (str) + call cq_rstats (res, CQRQPNAMES, str, SZ_FNAME) + call printf ("rqpnames:%s\n") + call pargstr (str) + call cq_rstats (res, CQRQPVALUES, str, SZ_FNAME) + call printf ("rqpvalues:%s\n") + call pargstr (str) + + # Get the number of keywords. + nfields = cq_rstati (res, CQNHEADER) + call printf ("nheader = %d\n") + call pargi (nfields) + + # Print information for each keyword. + do i = 1, nfields { + if (cq_hinfon (res, i, qpname, CQ_SZ_QPNAME, record, SZ_LINE) <= 0) + next + call printf ("keyword: %d %s %s\n") + call pargi (i) + call pargstr (qpname) + call pargstr (record) + if (cq_hinfo (res, qpname, record, SZ_LINE) <= 0) + next + call printf ("keyword: %d %s %s\n") + call pargi (i) + call pargstr (qpname) + call pargstr (record) + } + call printf ("\n") + + # Get the number of fields. + nfields = cq_rstati (res, CQNFIELDS) + call printf ("nfields = %d\n") + call pargi (nfields) + + # Print the information for each field. + do i = 1, nfields { + if (cq_finfon (res, i, qpname, CQ_SZ_FNAME, foffset, fsize, + ftype, qpunits, CQ_SZ_FUNITS, qpformats, CQ_SZ_FFMTS) <= 0) + next + call printf ("field: %d %s %d %d %d %s %s\n") + call pargi (i) + call pargstr (qpname) + call pargi (foffset) + call pargi (fsize) + call pargi (ftype) + call pargstr (qpunits) + call pargstr (qpformats) + if (cq_finfo (res, qpname, foffset, fsize, ftype, qpunits, + CQ_SZ_FUNITS, qpformats, CQ_SZ_FFMTS) <= 0) + next + call printf ("field: %d %s %d %d %d %s %s\n") + call pargi (i) + call pargstr (qpname) + call pargi (foffset) + call pargi (fsize) + call pargi (ftype) + call pargstr (qpunits) + call pargstr (qpformats) + if (cq_fname (res, i, qpname, CQ_SZ_FNAME) <= 0) + next + foffset = cq_foffset (res, qpname) + fsize = cq_fsize (res, qpname) + ftype = cq_ftype (res, qpname) + call cq_funits (res, qpname, qpunits, CQ_SZ_FUNITS) + call cq_ffmts (res, qpname, qpformats, CQ_SZ_FFMTS) + call printf ("field: %d %s %d %d %d %s %s\n") + call pargi (i) + call pargstr (qpname) + call pargi (foffset) + call pargi (fsize) + call pargi (ftype) + call pargstr (qpunits) + call pargstr (qpformats) + } + call printf ("\n") + + # Get the number of records. + nres = cq_rstati (res, CQRNRECS) + call printf ("nrecords = %d\n") + call pargi (nres) + + # Loop through and print the records. + recptr = 0 + while (recptr < nres) { + nchars = cq_gnrecord (res, record, SZ_LINE, recptr) + if (nchars == EOF) + break + call printf ("record %4d %4d %s") + call pargi (recptr) + call pargi (nchars) + call pargstr (record) + } + + # Find and print records at random. + record[1] = EOS + nchars = cq_grecord (res, record, SZ_LINE, 1) + call printf ("\nrecord %4d %4d %s") + call pargi (1) + call pargi (nchars) + call pargstr (record) + + record[1] = EOS + nchars = cq_grecord (res, record, SZ_LINE, (1 + nres) / 2) + call printf ("record %4d %4d %s") + call pargi ((1 + nres) / 2) + call pargi (nchars) + call pargstr (record) + + record[1] = EOS + nchars = cq_grecord (res, record, SZ_LINE, nres) + call printf ("record %4d %4d %s") + call pargi (nres) + call pargi (nchars) + call pargstr (record) + + # Loop through the records and decode the ra and dec fields as + # char, double precision, real precision, and integer fields. + call printf ("\nra dec\n") + do i = 1, nres { + call printf ("rec %d\n") + call pargi (i) + nchars = cq_gvalc (res, i, "ra", ra, SZ_FNAME) + nchars = cq_gvalc (res, i, "dec", dec, SZ_FNAME) + call printf (" %s %s\n") + call pargstr (ra) + call pargstr (dec) + nchars = cq_gvald (res, i, "ra", dval1) + nchars = cq_gvald (res, i, "dec", dval2) + call printf (" %h %h\n") + call pargd (dval1) + call pargd (dval2) + nchars = cq_gvalr (res, i, "ra", rval1) + nchars = cq_gvalr (res, i, "dec", rval2) + call printf (" %h %h\n") + call pargr (rval1) + call pargr (rval2) + nchars = cq_gvall (res, i, "ra", lval1) + nchars = cq_gvall (res, i, "dec", lval2) + call printf (" %h %h\n") + call pargl (lval1) + call pargl (lval2) + nchars = cq_gvali (res, i, "ra", ival1) + nchars = cq_gvali (res, i, "dec", ival2) + call printf (" %h %h\n") + call pargi (ival1) + call pargi (ival2) + nchars = cq_gvals (res, i, "ra", sval1) + nchars = cq_gvals (res, i, "dec", sval2) + call printf (" %h %h\n") + call pargs (sval1) + call pargs (sval2) + } + + + # Close the query. + call cq_rclose (res) + + # Unmap the database. + call cq_unmap (cq) +end diff --git a/noao/astcat/src/debug/t_acqitest.x b/noao/astcat/src/debug/t_acqitest.x new file mode 100644 index 00000000..56e532ec --- /dev/null +++ b/noao/astcat/src/debug/t_acqitest.x @@ -0,0 +1,220 @@ +include <pkg/cq.h> + +# T_ACQITEST -- Test basic catalog database access and query procedures. + +procedure t_acqitest () + +double dval1 +real width +pointer cq, sp, reclist, res +int i, ip, catno, nqpars, parno, ftype, nfields +char database[SZ_FNAME], record[SZ_LINE], ra[SZ_FNAME], dec[SZ_FNAME] +char str[SZ_FNAME], catalog[SZ_LINE], imname[SZ_LINE] +char qpname[CQ_SZ_QPNAME], qkname[CQ_SZ_QPNAME], qpvalue[CQ_SZ_QPVALUE] +char qpunits[CQ_SZ_QPUNITS], qpformats[CQ_SZ_QPFMTS] + +real clgetr() +pointer cq_map(), cq_imquery() +int cq_stati(), cq_statt(), cq_setcat(), cq_setcatn(), cq_nqpars() +int cq_gqpar(), cq_gqparn(), cq_sqpar(), ctod(), cq_istati() +int cq_winfon(), cq_winfo(), cq_kinfon(), cq_kinfo() +bool streq() + +begin + # Get the database and record names. + call clgstr ("record", record, SZ_LINE) + call clgstr ("image", imname, SZ_LINE) + call clgstr ("ra", ra, SZ_FNAME) + call clgstr ("dec", dec, SZ_FNAME) + width = clgetr ("width") + call clgstr ("database", database, SZ_FNAME) + + # Map the database. + cq = cq_map (database, READ_ONLY) + + # Print the database file name and number of records. + call cq_stats (cq, CQCATDB, database, SZ_FNAME) + call printf ("\nDatabase: %s Nrecs: %d\n\n") + call pargstr (database) + call pargi (cq_stati (cq, CQNRECS)) + + # Print the record list. + call printf ("Szreclist = %d characters\n") + call pargi (cq_stati (cq, CQSZRECLIST)) + + call smark (sp) + call salloc (reclist, cq_stati(cq, CQSZRECLIST), TY_CHAR) + if (cq_statt (cq, CQRECLIST, Memc[reclist], cq_stati(cq, + CQSZRECLIST)) <= 0) + Memc[reclist] = EOS + call printf ("%s") + call pargstr (Memc[reclist]) + call sfree (sp) + + # Print the current catalog name and number. + call cq_stats (cq, CQCATNAME, catalog, SZ_LINE) + call printf ("\nCurrent catalog: %s index: %d\n") + call pargstr (catalog) + call pargi (cq_stati (cq, CQCATNO)) + + # Set the current catalog by name. + catno = cq_setcat (cq, record) + call cq_stats (cq, CQCATNAME, catalog, SZ_LINE) + call printf ("\nCurrent catalog: %s index: %d\n") + call pargstr (catalog) + call pargi (cq_stati (cq, CQCATNO)) + + # Set the same catalog by number. + catno = cq_setcatn (cq, catno) + call cq_stats (cq, CQCATNAME, catalog, SZ_LINE) + call printf ("\nCurrent catalog: %s index: %d\n\n") + call pargstr (catalog) + call pargi (cq_stati (cq, CQCATNO)) + + # Set the query parameters. Don't worry about units in this case. + nqpars = cq_nqpars (cq) + do i = 1, nqpars { + + # Get description of each query parameter. + parno = cq_gqparn (cq, i, qpname, CQ_SZ_QPNAME, qpvalue, + CQ_SZ_QPVALUE, qpunits, CQ_SZ_QPUNITS, qpformats, CQ_SZ_QPFMTS) + call printf ("parno: %d %s %s %s %s\n") + call pargi (parno) + call pargstr (qpname) + call pargstr (qpvalue) + call pargstr (qpunits) + call pargstr (qpformats) + parno = cq_gqpar (cq, qpname, qpname, CQ_SZ_QPNAME, qpvalue, + CQ_SZ_QPVALUE, qpunits, CQ_SZ_QPUNITS, qpformats, CQ_SZ_QPFMTS) + call printf ("parno: %d %s %s %s %s\n") + call pargi (parno) + call pargstr (qpname) + call pargstr (qpvalue) + call pargstr (qpunits) + call pargstr (qpformats) + + + # Set the astrometric parameters. + if (streq (qpname, "ra")) { + ip = 1 + if (ctod (ra, ip, dval1) > 0) { + call sprintf (ra, SZ_FNAME, qpformats) + call pargd (dval1) + } + parno = cq_sqpar (cq, qpname, ra) + } else if (streq (qpname, "dec")) { + ip = 1 + if (ctod (dec, ip, dval1) > 0) { + if (dval1 >= 0.0) { + #dec[1] = '+' + #call sprintf (dec[2], SZ_FNAME - 1, qpformats) + call sprintf (dec, SZ_FNAME, qpformats) + } else { + call sprintf (dec, SZ_FNAME, qpformats) + } + call pargd (dval1) + } + parno = cq_sqpar (cq, qpname, dec) + } else if (streq (qpname, "width")) { + call sprintf (str, SZ_FNAME, qpformats) + call pargr (width) + parno = cq_sqpar (cq, qpname, str) + } else if (streq (qpname, "radius")) { + call sprintf (str, SZ_FNAME, qpformats) + call pargr (width / 2.0) + parno = cq_sqpar (cq, qpname, str) + } + + } + call flush (STDOUT) + + # Send the query and get back the results. + res = cq_imquery (cq, imname) + if (res == NULL) + return + + call cq_istats (res, CQIMADDRESS, str, SZ_FNAME) + call printf ("\nimaddress: %s\n") + call pargstr (str) + call cq_istats (res, CQIMQUERY, str, SZ_FNAME) + call printf ("imquery: %s\n") + call pargstr (str) + call cq_istats (res, CQIQPNAMES, str, SZ_FNAME) + call printf ("iqpnames:%s\n") + call pargstr (str) + call cq_istats (res, CQIQPVALUES, str, SZ_FNAME) + call printf ("iqpvalues:%s\n") + call pargstr (str) + call flush (STDOUT) + + # Get the number of wcs parameters. + call printf ("nheader = 0\n") + nfields = cq_istati (res, CQNWCS) + call printf ("nheader = %d\n") + call pargi (nfields) + call flush (STDOUT) + + # Print the information for each field. + do i = 1, nfields { + if (cq_winfon (res, i, qpname, CQ_SZ_QPNAME, qkname, CQ_SZ_QPNAME, + qpvalue, CQ_SZ_QPVALUE, ftype, qpunits, CQ_SZ_QPUNITS) <= 0) + next + call printf ("keyword: %d %s %s %s %d %s\n") + call pargi (i) + call pargstr (qpname) + call pargstr (qkname) + call pargstr (qpvalue) + call pargi (ftype) + call pargstr (qpunits) + if (cq_winfo (res, qpname, qkname, CQ_SZ_QPNAME, qpvalue, + CQ_SZ_QPVALUE, ftype, qpunits, CQ_SZ_QPUNITS) <= 0) + next + call printf ("keyword: %d %s %s %s %d %s\n") + call pargi (i) + call pargstr (qpname) + call pargstr (qkname) + call pargstr (qpvalue) + call pargi (ftype) + call pargstr (qpunits) + } + call printf ("\n") + call flush (STDOUT) + + # Get the number of fields. + nfields = cq_istati (res, CQNIMPARS) + call printf ("nfields = %d\n") + call pargi (nfields) + call flush (STDOUT) + + # Print the information for each field. + do i = 1, nfields { + if (cq_kinfon (res, i, qpname, CQ_SZ_QPNAME, qkname, CQ_SZ_QPNAME, + qpvalue, CQ_SZ_QPVALUE, ftype, qpunits, CQ_SZ_QPUNITS) <= 0) + next + call printf ("keyword: %d %s %s %s %d %s\n") + call pargi (i) + call pargstr (qpname) + call pargstr (qkname) + call pargstr (qpvalue) + call pargi (ftype) + call pargstr (qpunits) + if (cq_kinfo (res, qpname, qkname, CQ_SZ_QPNAME, qpvalue, + CQ_SZ_QPVALUE, ftype, qpunits, CQ_SZ_QPUNITS) <= 0) + next + call printf ("keyword: %d %s %s %s %d %s\n") + call pargi (i) + call pargstr (qpname) + call pargstr (qkname) + call pargstr (qpvalue) + call pargi (ftype) + call pargstr (qpunits) + } + call printf ("\n") + call flush (STDOUT) + + # Close the query descriptor. + call cq_imclose (res) + + # Unmap the database. + call cq_unmap (cq) +end diff --git a/noao/astcat/src/debug/t_adumpcat.x b/noao/astcat/src/debug/t_adumpcat.x new file mode 100644 index 00000000..de2c9a1c --- /dev/null +++ b/noao/astcat/src/debug/t_adumpcat.x @@ -0,0 +1,164 @@ +include <fset.h> +include <pkg/cq.h> + +define DEF_SZPARS 15 +define DEF_SZBUF 32768 + +procedure t_adumpcat() + +pointer sp, catalog, output, catdb, ra, dec, size +pointer query, qpname, qpvalue, qpunits, qpformats, str, cq, buf +int i, fd, ofd, nqpars, parno, nchars +bool done +pointer cq_map() +int cq_setcat(), ndopen(), open(), cq_nqpars(), cq_gqparn(), read() +int getline() +bool streq() +errchk ndopen() + +begin + # Allocate some working space. + call smark (sp) + call salloc (catalog, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (catdb, SZ_FNAME, TY_CHAR) + call salloc (ra, DEF_SZPARS, TY_CHAR) + call salloc (dec, DEF_SZPARS, TY_CHAR) + call salloc (size, DEF_SZPARS, TY_CHAR) + call salloc (qpname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (qpvalue, CQ_SZ_QPVALUE, TY_CHAR) + call salloc (qpunits, CQ_SZ_QPUNITS, TY_CHAR) + call salloc (qpformats, CQ_SZ_QPFMTS, TY_CHAR) + call salloc (query, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (buf, DEF_SZBUF, TY_CHAR) + + # Get the parameters. + call clgstr ("catalog", Memc[catalog], SZ_FNAME) + call clgstr ("output", Memc[output], SZ_FNAME) + call clgstr ("ra", Memc[ra], DEF_SZPARS) + call clgstr ("dec", Memc[dec], DEF_SZPARS) + call clgstr ("size", Memc[size], DEF_SZPARS) + call clgstr ("catdb", Memc[catdb], SZ_FNAME) + + # Map the catalog configuration file. + cq = cq_map (Memc[catdb], READ_ONLY) + if (cq == NULL) { + call eprintf ("Cannot open catalog configuration file %s\n") + call pargstr (Memc[catdb]) + call sfree (sp) + return + } + + # Locate the catalog record. + if (cq_setcat (cq, Memc[catalog]) <= 0) { + call eprintf ("Cannot locate catalog record %s\n") + call pargstr (Memc[catalog]) + call cq_unmap (cq) + call sfree (sp) + return + } + + # Connect to the HTTP server. + call cq_fgwrd (cq, "address", Memc[str], SZ_LINE) + iferr (fd = ndopen (Memc[str], READ_WRITE)) { + call eprintf ("Cannot access catalog %s at host %s\n") + call pargstr (Memc[catalog]) + call pargstr (Memc[str]) + call cq_unmap (cq) + call sfree (sp) + return + } + + # Open the output file. + ofd = open (Memc[output], NEW_FILE, TEXT_FILE) + + # Format the query without worrying about coordinate systems, + # or formats. Just assume that the user types in ra, dec, and + # size in the form expected by the server. + call cq_fgstr (cq, "query", Memc[query], SZ_LINE) + nqpars = cq_nqpars (cq) + call sprintf (Memc[str], SZ_LINE, Memc[query]) + do i = 1, nqpars { + + # Get description of each query parameter. + parno = cq_gqparn (cq, i, Memc[qpname], CQ_SZ_QPNAME, + Memc[qpvalue], CQ_SZ_QPVALUE, Memc[qpunits], CQ_SZ_QPUNITS, + Memc[qpformats], CQ_SZ_QPFMTS) + + # Pass the parameters to the query string. + if (streq (Memc[qpname], "ra")) { + call pargstr (Memc[ra]) + } else if (streq (Memc[qpname], "dec")) { + call pargstr (Memc[dec]) + } else if (streq (Memc[qpname], "width")) { + call pargstr (Memc[size]) + } else if (streq (Memc[qpname], "xwidth")) { + call pargstr (Memc[size]) + } else if (streq (Memc[qpname], "ywidth")) { + call pargstr (Memc[size]) + } else if (streq (Memc[qpname], "rawidth")) { + call pargstr (Memc[size]) + } else if (streq (Memc[qpname], "decwidth")) { + call pargstr (Memc[size]) + } else if (streq (Memc[qpname], "hwidth")) { + call pargstr (Memc[size]) + } else if (streq (Memc[qpname], "xhwidth")) { + call pargstr (Memc[size]) + } else if (streq (Memc[qpname], "yhwidth")) { + call pargstr (Memc[size]) + } else if (streq (Memc[qpname], "xrawidth")) { + call pargstr (Memc[size]) + } else if (streq (Memc[qpname], "ydecwidth")) { + call pargstr (Memc[size]) + } else if (streq (Memc[qpname], "radius")) { + call pargstr (Memc[size]) + } else { + call pargstr (Memc[qpvalue]) + } + + } + + # Send the query. + call fprintf (fd, "%s") + call pargstr (Memc[str]) + call flush (fd) + call fseti (fd, F_CANCEL, OK) + + # Read the reply. Skip the HTTP header assuming it ends with a \n or + # a \r\n. + call cq_fgwrd (cq, "protocol", Memc[str], SZ_LINE) + if (streq (Memc[str], "http")) { + repeat { + nchars = getline (fd, Memc[buf]) + if (nchars <= 0) + break + Memc[buf+nchars] = EOS + } until ((Memc[buf] == '\r' && Memc[buf+1] == '\n') || + (Memc[buf] == '\n')) + } + + # Read the reply. + repeat { + nchars = read (fd, Memc[buf], DEF_SZBUF) + if (nchars > 0) { + Memc[buf+nchars] = EOS + call write (ofd, Memc[buf], nchars) + done = false + } else { + done = true + } + } until (done) + call flush (ofd) + + # Close the output. + call close (ofd) + + # Close the network connection. + call close (fd) + + # Unmap the database. + call cq_unmap (cq) + + call sfree (sp) +end diff --git a/noao/astcat/src/debug/t_adumpim.x b/noao/astcat/src/debug/t_adumpim.x new file mode 100644 index 00000000..e214b8fd --- /dev/null +++ b/noao/astcat/src/debug/t_adumpim.x @@ -0,0 +1,163 @@ +include <mach.h> +include <fset.h> +include <pkg/cq.h> + +define DEF_SZPARS 15 +define DEF_SZBUF 28800 + +# T_ADUMPIM -- Image survey access debugging routines. + +procedure t_adumpim() + +pointer sp, imsurvey, output, ra, dec, size, imdb, query, buf, str +pointer qpname, qpvalue, qpunits, qpformats, cq +int i, fd, ofd, nqpars, parno, nchars +bool done + +pointer cq_map() +int cq_setcat(), ndopen(), open(), cq_nqpars(), cq_gqparn(), strlen() +int getline(), read() +bool streq() +errchk cq_fgeti() + +begin + # Allocate some working space. + call smark (sp) + call salloc (imsurvey, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (imdb, SZ_FNAME, TY_CHAR) + call salloc (ra, DEF_SZPARS, TY_CHAR) + call salloc (dec, DEF_SZPARS, TY_CHAR) + call salloc (size, DEF_SZPARS, TY_CHAR) + call salloc (query, SZ_LINE, TY_CHAR) + call salloc (qpname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (qpvalue, CQ_SZ_QPVALUE, TY_CHAR) + call salloc (qpunits, CQ_SZ_QPUNITS, TY_CHAR) + call salloc (qpformats, CQ_SZ_QPFMTS, TY_CHAR) + call salloc (buf, 2*DEF_SZBUF, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the parameters. + call clgstr ("imsurvey", Memc[imsurvey], SZ_FNAME) + call clgstr ("output", Memc[output], SZ_FNAME) + call clgstr ("ra", Memc[ra], DEF_SZPARS) + call clgstr ("dec", Memc[dec], DEF_SZPARS) + call clgstr ("size", Memc[size], DEF_SZPARS) + call clgstr ("imdb", Memc[imdb], SZ_FNAME) + + # Map the image surfvey configuration file. + cq = cq_map (Memc[imdb], READ_ONLY) + if (cq == NULL) { + call eprintf ("Cannot open image survey configuration file %s\n") + call pargstr (Memc[imdb]) + call sfree (sp) + return + } + + # Locate the image survey record. + if (cq_setcat (cq, Memc[imsurvey]) <= 0) { + call eprintf ("Cannot locate image survey record %s\n") + call pargstr (Memc[imsurvey]) + call cq_unmap (cq) + call sfree (sp) + return + } + + # Connect to the HTTP server. + call cq_fgwrd (cq, "address", Memc[str], SZ_LINE) + iferr (fd = ndopen (Memc[str], READ_WRITE)) { + call eprintf ("Cannot access image server %s at host %s\n") + call pargstr (Memc[imsurvey]) + call pargstr (Memc[str]) + call cq_unmap (cq) + call sfree (sp) + return + } + + # Open the output file. + #ofd = open (Memc[output], NEW_FILE, BINARY_FILE) + ofd = open (Memc[output], NEW_FILE, TEXT_FILE) + + # Format the query without worrying about coordinate systems, + # or formats. Just assume that the user types in ra, dec, and + # size in the form expected by the server. + + call cq_fgstr (cq, "query", Memc[query], SZ_LINE) + nqpars = cq_nqpars (cq) + call sprintf (Memc[str], SZ_LINE, Memc[query]) + do i = 1, nqpars { + + # Get description of each query parameter. + parno = cq_gqparn (cq, i, Memc[qpname], CQ_SZ_QPNAME, + Memc[qpvalue], CQ_SZ_QPVALUE, Memc[qpunits], CQ_SZ_QPUNITS, + Memc[qpformats], CQ_SZ_QPFMTS) + + # Pass the parameters to the query string. + if (streq (Memc[qpname], "ra")) { + call pargstr (Memc[ra]) + } else if (streq (Memc[qpname], "dec")) { + call pargstr (Memc[dec]) + } else if (streq (Memc[qpname], "width")) { + call pargstr (Memc[size]) + } else if (streq (Memc[qpname], "xwidth")) { + call pargstr (Memc[size]) + } else if (streq (Memc[qpname], "ywidth")) { + call pargstr (Memc[size]) + } else if (streq (Memc[qpname], "radius")) { + call pargstr (Memc[size]) + } else { + call pargstr (Memc[qpvalue]) + } + + } + + # Send the query. Note that since the communication mode and output + # file type are binary the command must be converted from IRAF chars + # type byte chars. Leave as text for now since it works for FITS + # files. + + nchars = strlen (Memc[str]) + #call chrpak (Memc[str], 1, Memc[str], 1, nchars) + #call awriteb (fd, Memc[str], nchars, 1) + #nread = awaitb (fd) + call write (fd, Memc[str], nchars) + call flush (fd) + call fseti (fd, F_CANCEL, OK) + + # Read the reply. Skip the HTTP header assuming it ends with a \n or + # a \r\n. + call cq_fgstr (cq, "protocol", Memc[str], SZ_LINE) + if (streq (Memc[str], "http")) { + repeat { + nchars = getline (fd, Memc[buf]) + if (nchars <= 0) + break + Memc[buf+nchars] = EOS + } until ((Memc[buf] == '\r' && Memc[buf+1] == '\n') || + (Memc[buf] == '\n')) + } + + repeat { + nchars = read (fd, Memc[buf], DEF_SZBUF) + if (nchars > 0) { + Memc[buf+nchars] = EOS + call write (ofd, Memc[buf], nchars) + done = false + } else { + done =true + } + } until (done) + + call flush (ofd) + + # Close the output image. + call close (ofd) + + # Close the network connection. + call close (fd) + + # Unmap the database. + call cq_unmap (cq) + + call sfree (sp) +end diff --git a/noao/astcat/src/debug/zzdebug.x b/noao/astcat/src/debug/zzdebug.x new file mode 100644 index 00000000..3ee5ad24 --- /dev/null +++ b/noao/astcat/src/debug/zzdebug.x @@ -0,0 +1,142 @@ +include <fset.h> + +# T_TEST2 -- Test Doug's idea of how to access a piece of memory as a +# binary file using the pushback technique. This works but is a bit +# inefficient. + +procedure t_test2() + +pointer inbuf, outbuf +int i, fd, nchars, ntimes +int open(), read() + +begin + # Allocate a char array. + call malloc (inbuf, 1000, TY_CHAR) + call malloc (outbuf, 200, TY_CHAR) + do i = 1, 1000 + Memc[inbuf+i-1] = i + + # Open char array as a binary file. + fd = open ("dev$null", READ_ONLY, BINARY_FILE) + call fseti (fd, F_PBBSIZE, 1008) + call unread (fd, Memc[inbuf], 1000) + + # Try to read the data. + ntimes = 1 + nchars = read (fd, Memc[outbuf], 200) + while (nchars != EOF) { + call printf ("ntimes=%d nchars=%d firstchar = %d\n") + call pargi (ntimes) + call pargi (nchars) + call pargi (int(Memc[outbuf])) + nchars = read (fd, Memc[outbuf], 200) + ntimes = ntimes + 1 + } + + call close (fd) + + # Free char array. + call mfree (inbuf, TY_CHAR) + call mfree (outbuf, TY_CHAR) +end + + +# T_TEST3 -- Test Doug's idea of how to access a piece of memory as a +# binary file using the spool file technique. This works but is still a bit +# inefficient. + +procedure t_test3() + +pointer inbuf, outbuf +int i, fd, ntimes, nchars +int open(), read() + +begin + # Allocate a char array. + call malloc (inbuf, 1000, TY_CHAR) + call malloc (outbuf, 200, TY_CHAR) + do i = 1, 1000 + Memc[inbuf+i-1] = i + + # Open char array as a binary file. + fd = open ("dev$null", READ_WRITE, SPOOL_FILE) + call write (fd, Memc[inbuf], 1000) + call seek (fd, BOF) + + # Try to read the data. + ntimes = 1 + nchars = read (fd, Memc[outbuf], 200) + while (nchars != EOF) { + call printf ("ntimes=%d nchars=%d firstchar = %d\n") + call pargi (ntimes) + call pargi (nchars) + call pargi (int(Memc[outbuf])) + nchars = read (fd, Memc[outbuf], 200) + ntimes = ntimes + 1 + } + + call close (fd) + + # Free char array. + call mfree (inbuf, TY_CHAR) + call mfree (outbuf, TY_CHAR) +end + +# T_TEST5 -- Test Doug's idea of how to access a piece of memory as a +# text file using the spool file technique. This works but is still a bit +# inefficient. + +procedure t_test5() + +pointer inbuf, outbuf +int i, fd, ntimes, nchars +long note() +int open(), getline() + +begin + # Allocate a char array. + call malloc (inbuf, 1000, TY_CHAR) + call malloc (outbuf, 200, TY_CHAR) + do i = 1, 200 + Memc[inbuf+i-1] = 'a' + Memc[inbuf+199] = '\n' + do i = 201, 400 + Memc[inbuf+i-1] = 'b' + Memc[inbuf+399] = '\n' + do i = 401, 600 + Memc[inbuf+i-1] = 'c' + Memc[inbuf+599] = '\n' + do i = 601, 800 + Memc[inbuf+i-1] = 'd' + Memc[inbuf+799] = '\n' + do i = 801, 1000 + Memc[inbuf+i-1] = 'e' + Memc[inbuf+999] = '\n' + + # Open char array as a binary file. + fd = open ("dev$null", READ_WRITE, SPOOL_FILE) + call write (fd, Memc[inbuf], 1000) + call seek (fd, BOF) + + # Try to read the data. + ntimes = 1 + #nchars = read (fd, Memc[outbuf], 200) + nchars = getline (fd, Memc[outbuf]) + while (nchars != EOF) { + call printf ("ntimes=%d nchars=%d firstchar = %c seek=%d\n") + call pargi (ntimes) + call pargi (nchars) + call pargc (Memc[outbuf]) + call pargl (note(fd)) + #nchars = read (fd, Memc[outbuf], 200) + nchars = getline (fd, Memc[outbuf]) + ntimes = ntimes + 1 + } + + call close (fd) + + # Free char array. + call mfree (inbuf, TY_CHAR) + call mfree (outbuf, TY_CHAR) +end diff --git a/noao/astcat/src/mkpkg b/noao/astcat/src/mkpkg new file mode 100644 index 00000000..05300d2b --- /dev/null +++ b/noao/astcat/src/mkpkg @@ -0,0 +1,28 @@ +# Make the ASTCAT package + +$call relink +$exit + +update: + $call relink + $call install + ; + +relink: + $set LIBS = "-lxtools -lslalib" + $update libpkg.a + $omake x_astcat.x + $link x_astcat.o libpkg.a $(LIBS) -o x_astcat.e + ; + +install: + $move x_astcat.e noaobin$x_astcat.e + ; + + +libpkg.a: + @agetcat + @attools + @awcs + @debug + ; diff --git a/noao/astcat/src/pltmodel/pltmodel.par b/noao/astcat/src/pltmodel/pltmodel.par new file mode 100644 index 00000000..61ecb7a0 --- /dev/null +++ b/noao/astcat/src/pltmodel/pltmodel.par @@ -0,0 +1,36 @@ +# PLTMODEL Parameters. + +# Image parameters. +ncols,i,h,2048,1,,Number of image columns +nlines,i,h,2048,1,,Number of image lines +ncgrid,i,h,10,1,,Number of grid columns +nlgrid,i,h,10,1,,Number of grid lines + +# Linear model parameters. +x_zero,r,h,INDEF,,,X origin in pixels +y_zero,r,h,INDEF,,,Y origin in pixels +xi_zero,r,h,INDEF,,,XI origin in arcseconds +eta_zero,r,h,INDEF,,,ETA origin in arcseconds +scale,r,h,INDEF,,,Scale in arcseconds / pixel +ratio,r,h,INDEF,,,Ratio of Y to Y scale +xrot,r,h,INDEF,,,X rotation angle in degrees +yrot,r,h,INDEF,,,Y rotation angle in degrees + +# Tangent point position. +ra_tan,r,h,INDEF,,,Ra of assumed tangent point in hours +dec_tan,r,h,INDEF,,,Dec of assumed tangent point in degrees + +# Tangent point error. +dra_tan,r,h,INDEF,,,Ra error of assumed tangent point in minutes +ddec_tan,r,h,INDEF,,,Dec error of assumed tangent point in minutes + +# Tilt error. +tra,r,h,INDEF,,,Ra offset of plate normal +tdec,r,h,INDEF,,,Dec offset of platenormal + +# Cubic distortion. +q3ra,r,h,INDEF,,,Ra offset of cubic distortion center in minutes +q3dec,r,h,INDEF,,,Dec offset of cubic distortion center in minutes +q3,r,h,INDEF,,,Cubic distortion coefficient + +mode,s,h,'ql' diff --git a/noao/astcat/src/pltmodel/t_pltmodel.x b/noao/astcat/src/pltmodel/t_pltmodel.x new file mode 100644 index 00000000..33c865e2 --- /dev/null +++ b/noao/astcat/src/pltmodel/t_pltmodel.x @@ -0,0 +1,196 @@ +include <math.h> + +task pltmodel = t_pltmodel + +procedure t_pltmodel() + +double x_zero, y_zero, xi_zero, eta_zero, ra_tan, dec_tan, scale, ratio +double xrot, yrot, dra_tan, ddec_tan, x, y, xstep, ystep, tra, tdec +double xpix[1000], ypix[1000], xi[1000], eta[1000], dxi[1000], deta[1000] +double cosd, sind, dra, ddec, c1, f1, b1, ddxi, ddeta, q1, q2, q3 +double rpix, theta, rstd, tstd +int i, j, ncols, nlines, ncgrid, nlgrid, npts +double clgetd() +int clgeti() + +begin + # Get the image size. + ncols = clgeti ("ncols") + nlines = clgeti ("nlines") + ncgrid = clgeti ("ncgrid") + nlgrid = clgeti ("nlgrid") + + # Get the image zero point in pixels. + x_zero = clgetd ("x_zero") + if (IS_INDEFD(x_zero)) + x_zero = (1.0d0 + ncols) / 2.0d0 + y_zero = clgetd ("y_zero") + if (IS_INDEFD(y_zero)) + y_zero = (1.0d0 + nlines) / 2.0d0 + xi_zero = clgetd ("xi_zero") + if (IS_INDEFD(xi_zero)) + xi_zero = 0.0d0 + eta_zero = clgetd ("eta_zero") + if (IS_INDEFD(eta_zero)) + eta_zero = 0.0d0 + + # Get the image scale in " / pixel and the ratio of x to y scales. + scale = clgetd ("scale") + if (IS_INDEFD(scale)) + scale = 1.0d0 + scale = DEGTORAD (scale / 3600.0d0) + ratio = clgetd ("ratio") + if (IS_INDEFD(ratio)) + ratio = 1.0d0 + + # Get the rotation and ske in degrees. + xrot = clgetd ("xrot") + if (IS_INDEFD(xrot)) + xrot = 0.0d0 + yrot = clgetd ("yrot") + if (IS_INDEFD(yrot)) + yrot = 0.0d0 + + # Get the assumed image tangent point in hours and degrees. + ra_tan = clgetd ("ra_tan") + if (IS_INDEFD(ra_tan)) + ra_tan = 0.0d0 + dec_tan = clgetd ("dec_tan") + if (IS_INDEFD(dec_tan)) + dec_tan = 0.0d0 + cosd = cos (DEGTORAD(dec_tan)) + sind = sin (DEGTORAD(dec_tan)) + + # Get the tangent point error. + dra_tan = clgetd ("dra_tan") + if (IS_INDEFD(dra_tan)) + dra_tan = 0.0d0 + ddec_tan = clgetd ("ddec_tan") + if (IS_INDEFD(ddec_tan)) + ddec_tan = 0.0d0 + + # Get the tilt error. + tra = clgetd ("tra") + if (IS_INDEFD(tra)) + tra = 0.0d0 + tdec = clgetd ("tdec") + if (IS_INDEFD(tdec)) + tdec = 0.0d0 + + # Get the cubic distortion term + q1 = clgetd ("q3ra") + if (IS_INDEFD(q1)) + q1 = 0.0d0 + q2 = clgetd ("q3dec") + if (IS_INDEFD(q2)) + q2 = 0.0d0 + q3 = clgetd ("q3") + if (IS_INDEFD(q3)) + q3 = 0.0d0 + + # Compute the x and y grid. + xstep = (ncols - 1.0d0) / (ncgrid - 1.0d0) + ystep = (nlines - 1.0d0) / (nlgrid - 1.0d0) + npts = 0 + y = 1.0d0 + do j = 1, nlgrid { + x = 1.0d0 + do i = 1, ncgrid { + npts = npts + 1 + xpix[npts] = x + ypix[npts] = y + dxi[npts] = 0.0d0 + deta[npts] = 0.0d0 + x = x + xstep + } + y = y + ystep + } + + # Compute the linear part of the plate solution. + do i = 1, npts { + xi[i] = xi_zero + scale * (xpix[i] - x_zero) * + cos (DEGTORAD(xrot)) - scale * ratio * (ypix[i] - y_zero) * + sin(DEGTORAD(yrot)) + eta[i] = eta_zero + scale * (xpix[i] - x_zero) * + sin(DEGTORAD(xrot)) + scale * ratio * (ypix[i] - y_zero) * + cos(DEGTORAD(yrot)) + } + + # Estimate the tilt terms. + dra = DEGTORAD(tra / 60.0d0) + ddec = DEGTORAD(tdec / 60.0d0) + c1 = cosd * dra + f1 = ddec + do i = 1, npts { + ddxi = c1 * xi[i] ** 2 + f1 * xi[i] * eta[i] + ddeta = f1 * xi[i] * eta[i] + c1 * eta[i] ** 2 + dxi[i] = dxi[i] + ddxi + deta[i] = deta[i] + ddeta + } + + # Compute the components of the centering error. + dra = DEGTORAD(dra_tan / 60.0d0) + ddec = DEGTORAD(ddec_tan / 60.0d0) + c1 = cosd * dra + b1 = sind * dra + f1 = ddec + do i = 1, npts { + ddxi = c1 - b1 * eta[i] + c1 * xi[i] ** 2 + f1 * xi[i] * + eta[i] + ddeta = f1 + b1 * xi[i] + f1 * eta[i] ** 2 + c1 * xi[i] * + eta[i] + dxi[i] = dxi[i] + ddxi + deta[i] = deta[i] + ddeta + } + + # Compute the radial distortion terms + dra = DEGTORAD(q1 / 60.0d0) + ddec = DEGTORAD(q2 / 60.0d0) + c1 = -cosd * dra * q3 + f1 = -ddec * q3 + do i = 1, npts { + ddxi = c1 * (3.0d0 * xi[i] ** 2 + eta[i] ** 2) + 2.0d0 * f1 * + xi[i] * eta[i] + q3 * xi[i] * (xi[i] ** 2 + eta[i] ** 2) + ddeta = 2.0d0 * c1 * xi[i] * eta[i] + f1 * (xi[i] ** 2 + 3.0d0 * + eta[i] ** 2) + q3 * eta[i] * (xi[i] ** 2 + eta[i] ** 2) + dxi[i] = dxi[i] - ddxi + deta[i] = deta[i] - ddeta + } + + + # Estimate the refraction and aberration terms. + + # Compute the cubic distortion correction. + # Do the correction + do i = 1, npts { + xi[i] = xi[i] + dxi[i] + eta[i] = eta[i] + deta[i] + } + + # Print the results. + do i = 1, npts { + rpix = sqrt ((xpix[i] - x_zero) ** 2 + (ypix[i] - y_zero) ** 2) + if (ypix[i] == y_zero && xpix[i] == x_zero) + theta = 0.0d0 + else + theta = RADTODEG(atan2 (ypix[i] - y_zero, xpix[i] - x_zero)) + #if (theta < 0.0d0) + #theta = theta + 360.0d0 + rstd = sqrt ((xi[i] - xi_zero) ** 2 + (eta[i] - eta_zero) ** 2) + if (eta[i] == eta_zero && xi[i] == xi_zero) + tstd = 0.0d0 + else + tstd = RADTODEG(atan2 (eta[i] - eta_zero, xi[i] - xi_zero)) + #if (tstd < 0.0d0) + #tstd = tstd + 360.0d0 + call printf ("%12g %12g %12g %12g %12g %12g %12g %12g\n") + call pargd (xpix[i]) + call pargd (ypix[i]) + call pargd (RADTODEG(xi[i]) * 3600.0d0) + call pargd (RADTODEG(eta[i]) * 3600.0d0) + call pargd (rpix) + call pargd (theta) + call pargd (RADTODEG(rstd) * 3600.0d0) + call pargd (tstd) + } +end diff --git a/noao/astcat/src/x_astcat.x b/noao/astcat/src/x_astcat.x new file mode 100644 index 00000000..8feeb9c4 --- /dev/null +++ b/noao/astcat/src/x_astcat.x @@ -0,0 +1,12 @@ +task aclist = t_aclist, + agetcat = t_agetcat, + aimfind = t_aimfind, + afiltcat = t_afiltcat, + aslist = t_aslist, + agetim = t_agetim, + ahedit = t_ahedit, + adumpcat = t_adumpcat, + acqctest = t_acqctest, + acqftest = t_acqftest, + acqitest = t_acqitest, + adumpim = t_adumpim |