diff options
Diffstat (limited to 'pkg/tbtables/tbfnew.x')
| -rw-r--r-- | pkg/tbtables/tbfnew.x | 436 |
1 files changed, 436 insertions, 0 deletions
diff --git a/pkg/tbtables/tbfnew.x b/pkg/tbtables/tbfnew.x new file mode 100644 index 00000000..227bae58 --- /dev/null +++ b/pkg/tbtables/tbfnew.x @@ -0,0 +1,436 @@ +# This file contains tbfnew and tbfroot. + +include <tbset.h> +include "tbtables.h" +include "tblfits.h" # defines SZ_FTTYPE, FITS_INDEFI, FITS_ORIGIN, etc + +# tbfnew -- create a new FITS table +# If the FITS file doesn't exist it will be created. If it does exist +# a new BINTABLE extension will be created at the end of the file (or +# one will be replaced, if overwrite=yes). +# +# Note that the TABLE extension (ASCII) is not supported. +# +# The unit number used by the FITSIO interface is gotten and assigned to +# what would be the fd file number for ordinary iraf I/O. +# +# If an EXTNAME was included in the file name (i.e. root.fits[extname]), +# that name will be used for the value of EXTNAME in the new extension. +# added to the header of the new extension. +# If an extension number was explicitly given in the file name, then +# the number must match the actual number of the extension to be created. +# It is not necessary to specify either a name or a number. +# +# If overwrite = YES was specified, an existing extension will be searched +# for and deleted, then the new table will be written in its place. +# +# On input to this routine, TB_HDU is either an explicit number or a flag +# (as is the case for tbfopn). On output, the number of the newly created +# extension will be assigned to TB_HDU. +# +# If we're creating a new FITS file, an NEXTEND keyword with a value of 1 +# will be added to the primary header. If we're appending a new extension +# to an existing FITS file, NEXTEND will be added or updated in the primary +# header if the primary data unit is null (i.e. NAXIS = 0). If overwrite=yes, +# then NEXTEND will not be modified, and it will not be added if it is not +# already present. +# +# Note that in calls to fsmahd, the HDU number is given as a number plus one. +# This is to emphasize the different numbering convention between FITSIO and +# the stsdas tables package. +# +# Phil Hodge, 6-Jul-1995 Subroutine created +# Phil Hodge, 2-Feb-1996 Use tbffnd to find table in file; allow overwrite. +# Phil Hodge, 10-Apr-1997 Write FILENAME to PHU if new file (call tbfroot). +# Phil Hodge, 29-Jul-1997 Set nrows to zero instead of one. +# Phil Hodge, 14-Aug-1997 Set EXTEND = T in PHU if appending a new extension. +# Phil Hodge, 5-Mar-1998 fnroot and fnextn are functions, not subroutines. +# Phil Hodge, 5-Mar-1999 Move 'TB_FILE(tp) = fd' to after fsopen or fsinit. +# Phil Hodge, 12-Mar-1999 When 'TB_FILE(tp) = fd' was moved, it was to a +# point that was too far down; move it to the points immediately after +# the calls to fsopen and fsinit. +# Phil Hodge, 22-Mar-1999 Use TB_OS_FILENAME(tp) instead of TB_NAME(tp) as +# the name of the file to open. +# Change macro names SZ_FITS_TTYPE, SZ_FITS_TFORM and SZ_FITS_TUNIT +# to SZ_FTTYPE, SZ_FTFORM and SZ_FTUNIT respectively. +# Phil Hodge, 1-Jun-1999 Use both TB_FILE and TB_FILE2; +# fd is a two-element array, eight-byte aligned. +# Phil Hodge, 7-Jun-1999 Set TB_SUBTYPE instead of TB_HDUTYPE. +# Phil Hodge, 8-Sep-1999 Update NEXTEND in the primary header. +# Phil Hodge, 23-Jun-2000 Use COL_TDTYPE instead of COL_DTYPE, and add +# COL_TSCAL & COL_TZERO to the header if COL_TDTYPE != COL_DTYPE. + +procedure tbfnew (tp) + +pointer tp # i: pointer to table descriptor +#-- +pointer sp +pointer errmess +pointer ttype, tform, tunit # for arrays to be passed to fsibin +pointer extname # for extension name, if any +pointer tdisp # for print format +pointer keyword # for keyword name (e.g. TDISPn) +pointer filename # name without directory prefix +pointer comment # returned by fsgkyj and ignored +pointer cp # pointer to a column descriptor +int blocksize +int bitpix, naxis, naxes[2] +bool simple, extend +int status # zero is OK +int hdu # HDU number (zero is primary header) +int fd[2] # unit number for FITS file; cfitsio pointer +double dfd # to force alignment of fd +#equivalence (fd, dfd) # to force alignment of fd +int hdutype # type of current HDU +int extver # value of EXTVER from existing header, or -1 +int ncols # number of columns, but min of 1 (for allocating space) +int nrows # dummy number of rows +int nfields # number of columns to define +int vsize # size of area for variable-length data (zero) +int i +int ival # undefined value for int, short, bool +int ttype0, tform0, tunit0 # offsets into 2-D char arrays +int tdtype # "true" data type, i.e. not scaled by tscal, tzero +char dtype_c # data type char: 'D', 'E', 'J', 'I', 'L', 'A' +int nelem # array length +bool append # append new hdu at end of file? +bool done +pointer tbcnum() +int access() +int tbpsta(), tbcigi() +int tbffnd() +errchk tbffnd, tbfptf, tbferr + +begin + status = 0 + + append = true # reset if overwrite = yes + nfields = tbpsta (tp, TBL_NCOLS) + ncols = max (nfields, 1) + + call smark (sp) + call salloc (ttype, (SZ_FTTYPE+1) * ncols, TY_CHAR) + call salloc (tform, (SZ_FTFORM+1) * ncols, TY_CHAR) + call salloc (tunit, (SZ_FTUNIT+1) * ncols, TY_CHAR) + call salloc (extname, SZ_LINE, TY_CHAR) + call salloc (keyword, SZ_FNAME, TY_CHAR) + call salloc (tdisp, SZ_FNAME, TY_CHAR) + + # Get a unit number. + # This call does nothing if linked with CFITSIO. In that case, + # fd is output from fsopen or fsinit, and fd is actually a C pointer. + fd[2] = 0 # not needed for four-byte C pointers + call fsgiou (fd, status) + if (status != 0) + call tbferr (status) + + # See if the FITS file already exists. + if (access (TB_NAME(tp), 0, 0) == YES) { + + # Open the file read/write. + call fsopen (fd, TB_OS_FILENAME(tp), 1, blocksize, status) + if (status != 0) + call tbferr (status) + + TB_FILE(tp) = fd[1] + TB_FILE2(tp) = fd[2] + + # If overwrite=yes, find the specified extension and delete it. + # Then move to the previous hdu and set a flag (append=false) + # indicating that the hdu to be created should be inserted + # following that hdu. + if (TB_OVERWRITE(tp) == YES) { + + hdu = tbffnd (tp, Memc[extname], SZ_LINE, extver, hdutype) + if (hdu == EOF) { + call salloc (errmess, SZ_LINE, TY_CHAR) + call sprintf (Memc[errmess], SZ_LINE, + "table not found in FITS file `%s'") + call pargstr (TB_NAME(tp)) + call error (status, Memc[errmess]) + } else { + call fsdhdu (fd, hdutype, status) + if (status != 0) + call tbferr (status) + # move to previous hdu, fitsio number (hdu-1) + 1 + call fsmahd (fd, hdu, hdutype, status) + if (status != 0) + call tbferr (status) + append = false + } + + } else { + + # Go to the primary header and make sure EXTEND = T. + call fsmahd (fd, 1, hdutype, status) # phdu + extend = true + call fsukyl (fd, "EXTEND", + extend, "There may be standard extensions", status) + if (status != 0) + call tbferr (status) + + # Find out how many extensions there currently are in the file. + done = false + hdu = 0 # incremented in the loop + while (!done) { + # Move forward one HDU. + hdu = hdu + 1 + call fsmahd (fd, hdu+1, hdutype, status) + if (status != 0) { # we've reached EOF + status = 0 + call ftcmsg() + done = true + } + } + # Return to the primary header, and update NEXTEND to the + # value it should be after we add a new extension. + call fsmahd (fd, 1, hdutype, status) + # check that the primary header is _just_ a header + call malloc (comment, SZ_FNAME, TY_CHAR) + call fsgkyj (fd, "NAXIS", naxis, Memc[comment], status) + call mfree (comment, TY_CHAR) + if (naxis == 0) { + call fsukyj (fd, "NEXTEND", + hdu, "number of extensions in file", status) + if (status != 0) + call tbferr (status) + } + + # Move back to the last existing HDU in the file; + # hdu is the number of the extension that we'll add later. + call fsmahd (fd, (hdu-1)+1, hdutype, status) + if (status != 0) + call tbferr (status) + } + + # Zero or -1 mean append at end of file. + if (TB_HDU(tp) <= 0) + TB_HDU(tp) = hdu # user-interface convention + + # Note that hdu is the last existing extension and is one indexed, + # while TB_HDU is the number of the new extension and is currently + # zero indexed. + + # If an HDU number was specified, it ought to agree with + # what we've found. + if (TB_HDU(tp) != hdu) { + call salloc (errmess, SZ_LINE, TY_CHAR) + call sprintf (Memc[errmess], SZ_LINE, + "extension %d was specified, but %s currently has %d extensions") + call pargi (TB_HDU(tp)) + call pargstr (TB_NAME(tp)) + call pargi (hdu-1) + call error (status, Memc[errmess]) + } + + } else { + + # Create a new FITS file. + blocksize = 2880 + + if (TB_HDU(tp) <= 1) { + TB_HDU(tp) = 1 # user interface numbering + } else { + call salloc (errmess, SZ_LINE, TY_CHAR) + call sprintf (Memc[errmess], SZ_LINE, + "extension number in new FITS file (%s) can't be greater than one") + call pargstr (TB_NAME(tp)) + call error (1, Memc[errmess]) + } + + call fsinit (fd, TB_OS_FILENAME(tp), blocksize, status) + if (status != 0) + call tbferr (status) + + TB_FILE(tp) = fd[1] + TB_FILE2(tp) = fd[2] + + # Create the primary header unit (with no data). + simple = true + bitpix = 16 + naxis = 0 + naxes[1] = 0 + extend = true + call fsphpr (fd, simple, bitpix, naxis, naxes, + 0, 1, extend, status) + if (status != 0) + call tbferr (status) + + # Add the ORIGIN keyword to the primary header. + call fspkys (fd, "ORIGIN", FITS_ORIGIN, FITS_ORIGIN_CMT, status) + if (status != 0) + call tbferr (status) + + # Add the FILENAME keyword to the primary header. + call salloc (filename, SZ_FNAME, TY_CHAR) + call tbfroot (TB_NAME(tp), Memc[filename], SZ_FNAME) + call fspkys (fd, "FILENAME", Memc[filename], "name of file", status) + if (status != 0) + call tbferr (status) + + # Since this is a new file, set NEXTEND to one. + call fspkyj (fd, "NEXTEND", + 1, "number of extensions in file", status) + if (status != 0) + call tbferr (status) + } + + # Create a new empty HDU following the last extension that we + # have accessed. We skip this for now if overwrite = yes. + if (append) { + call fscrhd (fd, status) + if (status != 0) + call tbferr (status) + } + + TB_SUBTYPE(tp) = TBL_SUBTYPE_BINTABLE + + # Create a BINTABLE extension, not ASCII table, and write + # the required header keywords for this extension. + + # First fill the arrays of column names, etc. + ttype0 = 0 + tform0 = 0 + tunit0 = 0 + do i = 1, nfields { + cp = tbcnum (tp, i) + tdtype = COL_TDTYPE(cp) # "true" data type + nelem = tbcigi (cp, TBL_COL_LENDATA) + switch (tdtype) { # get TFORM code + case TY_DOUBLE: + dtype_c = 'D' + case TY_REAL: + dtype_c = 'E' + case TY_INT: + dtype_c = 'J' + case TY_SHORT: + dtype_c = 'I' + case TY_BOOL: + dtype_c = 'L' + default: + dtype_c = 'A' + } + call tbcigt (cp, TBL_COL_NAME, Memc[ttype+ttype0], SZ_FTTYPE) + call tbcigt (cp, TBL_COL_UNITS, Memc[tunit+tunit0], SZ_FTUNIT) + if (tdtype > 0) { + call sprintf (Memc[tform+tform0], SZ_FTFORM, "%d%c") + call pargi (nelem) + call pargc (dtype_c) + } else if (nelem > 1) { # array of char strings + call sprintf (Memc[tform+tform0], SZ_FTFORM, "%d%c%d") + call pargi (-tdtype * nelem) # FITSIO special convention + call pargc (dtype_c) + call pargi (-tdtype) + } else { # character string + call sprintf (Memc[tform+tform0], SZ_FTFORM, "%d%c") + call pargi (-tdtype) + call pargc (dtype_c) + } + ttype0 = ttype0 + SZ_FTTYPE + 1 # +1 for EOS + tform0 = tform0 + SZ_FTFORM + 1 + tunit0 = tunit0 + SZ_FTUNIT + 1 + } + nrows = 0 + vsize = 0 + + if (append) { + # Write required keywords in newly appended hdu. + call fsphbn (fd, nrows, nfields, Memc[ttype], Memc[tform], + Memc[tunit], TB_EXTNAME(tp), vsize, status) + } else { # insert + # Insert an hdu following the current one, and write keywords + # that define a binary table extension. + call fsibin (fd, nrows, nfields, Memc[ttype], Memc[tform], + Memc[tunit], TB_EXTNAME(tp), vsize, status) + } + if (status != 0) + call tbferr (status) + + # Add version number to header, if it was specified. + if (TB_EXTVER(tp) > 0) { + call fspkyj (fd, "EXTVER", + TB_EXTVER(tp), "extension version number", status) + if (status != 0) + call tbferr (status) + } + + # Write the display format and undefined value keywords. + do i = 1, nfields { + + cp = tbcnum (tp, i) + tdtype = COL_TDTYPE(cp) + + call sprintf (Memc[keyword], SZ_FNAME, "TDISP%d") + call pargi (i) + call tbcigt (cp, TBL_COL_FMT, Memc[tdisp], SZ_FNAME) + call tbfptf (Memc[tdisp], Memc[tdisp], SZ_FNAME) + call fspkys (fd, Memc[keyword], Memc[tdisp], "display format", + status) + if (status != 0) + call tbferr (status) + + # Create TNULL string, and add to header. + if (tdtype == TY_INT || tdtype == TY_SHORT) { + + call sprintf (Memc[keyword], SZ_FNAME, "TNULL%d") + call pargi (i) + if (tdtype == TY_INT) + ival = FITS_INDEFI + else if (tdtype == TY_SHORT) + ival = FITS_INDEFS + call fspkyj (fd, Memc[keyword], + ival, "undefined value for column", status) + if (status != 0) + call tbferr (status) + } + + # Add scaling parameters to header, if the true data type + # is not the same as the apparent data type. + if (tdtype != COL_DTYPE(cp)) { + + call sprintf (Memc[keyword], SZ_FNAME, "TSCAL%d") + call pargi (i) + call fspkyd (fd, Memc[keyword], + COL_TSCAL(cp), 14, "scale factor for column", status) + if (status != 0) + call tbferr (status) + + call sprintf (Memc[keyword], SZ_FNAME, "TZERO%d") + call pargi (i) + call fspkyd (fd, Memc[keyword], + COL_TZERO(cp), 14, "zero offset for column", status) + if (status != 0) + call tbferr (status) + } + } + + call fsrdef (fd, status) # shouldn't be needed + + call sfree (sp) +end + +procedure tbfroot (fullname, fname, maxch) + +char fullname[ARB] # i: full file name, possibly including directory +char fname[maxch] # o: root+extension, no directory prefix +int maxch # i: allocated size of fname +#-- +pointer sp +pointer extn # scratch +int nchar, fnroot(), fnextn() +errchk fnroot, fnextn + +begin + call smark (sp) + call salloc (extn, maxch, TY_CHAR) + + nchar = fnroot (fullname, fname, maxch) # extract root + nchar = fnextn (fullname, Memc[extn], maxch) # extract extension + + if (Memc[extn] != EOS) { + call strcat (".", fname, maxch) + call strcat (Memc[extn], fname, maxch) # append extension + } + + call sfree (sp) +end |