aboutsummaryrefslogtreecommitdiff
path: root/noao/astcat/src/attools
diff options
context:
space:
mode:
authorJoe Hunkeler <jhunkeler@gmail.com>2015-08-11 16:51:37 -0400
committerJoe Hunkeler <jhunkeler@gmail.com>2015-08-11 16:51:37 -0400
commit40e5a5811c6ffce9b0974e93cdd927cbcf60c157 (patch)
tree4464880c571602d54f6ae114729bf62a89518057 /noao/astcat/src/attools
downloadiraf-osx-40e5a5811c6ffce9b0974e93cdd927cbcf60c157.tar.gz
Repatch (from linux) of OSX IRAF
Diffstat (limited to 'noao/astcat/src/attools')
-rw-r--r--noao/astcat/src/attools/atalloc.x288
-rw-r--r--noao/astcat/src/attools/atcathdr.x262
-rw-r--r--noao/astcat/src/attools/atdefpars.x305
-rw-r--r--noao/astcat/src/attools/atdtype.x55
-rw-r--r--noao/astcat/src/attools/atfnames.x748
-rw-r--r--noao/astcat/src/attools/atinpars.x408
-rw-r--r--noao/astcat/src/attools/atoutpars.x258
-rw-r--r--noao/astcat/src/attools/atset.x509
-rw-r--r--noao/astcat/src/attools/atshow.x375
-rw-r--r--noao/astcat/src/attools/atsort.x76
-rw-r--r--noao/astcat/src/attools/atstat.x506
-rw-r--r--noao/astcat/src/attools/atvectors.x66
-rw-r--r--noao/astcat/src/attools/atwrdstr.x57
-rw-r--r--noao/astcat/src/attools/liststr.gx496
-rw-r--r--noao/astcat/src/attools/liststr.x833
-rw-r--r--noao/astcat/src/attools/mkpkg39
16 files changed, 5281 insertions, 0 deletions
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
+ ;
generated by cgit (git 2.34.1) at 2025-09-20 11:28:00 -0400