diff options
Diffstat (limited to 'sys/imio/iki')
117 files changed, 15438 insertions, 0 deletions
diff --git a/sys/imio/iki/README b/sys/imio/iki/README new file mode 100644 index 00000000..14b0f3f5 --- /dev/null +++ b/sys/imio/iki/README @@ -0,0 +1,383 @@ + Image Kernel Interface (IKI) + Doug Tody + 08 May 1986 + + +1. INTRODUCTION + + The IKI is the interface between IMIO and some particular image storage +format. IMIO itself has no knowledge of the storage format. The primary +function of the IKI is to access image headers, mapping the host header +storage format into the IMIO image header descriptor and vice versa. +The IKI is responsible for all image management operations, including +opening/creating/updating headers, opening/creating pixfiles (pixel storage +files), deleting, renaming, and copying images, checking for the existence +of images, and so on. + +The IKI can support an arbitrary number of different storage formats. +Each format requires a set of format dependent driver subroutines implementing +the standard IKI functions. The IKI will dynamically select the driver to be +used to access a particular format at runtime. New drivers may be dynamically +loaded at runtime, in a way similar to that used for FIO. While IMIO directly +accesses the pixel storage file via binary FIO for efficiency reasons, the +pixfile is opened by the IKI driver, hence a special driver may be used if +desired. For example, this feature may be used to access image display frame +as a pixfile, or an image stored in archival format on an optical disk. + + +2. STRUCTURE + + The role played by the IKI and format specific IKI drivers in the image +i/o subsystem is illustrated in the figure below. + + + IMIO Format independent; primarily does i/o to + | the pixel file. The image header is read + | into a dynamically allocated descriptor at + | open time. + | + IKI Selects driver to be used. Maintains table + | of open images, handles cleanup during error + | recovery. + | + (drivers) Physically accesses/creates/deletes etc. an + image stored in a particular format. Maps + the header stored in some particular external + format into the standardized IMIO descriptor. + Responsible for opening/creating the pixfile, + returning a FIO file descriptor to IMIO, which + directly accesses the pixel data. + + +The format specific driver packages are written in SPP using only standard +VOS i/o facilities, e.g., FIO and MEMIO. This is necessary due to the use +of an SPP descriptor structure to maintain the incore version of the image +header, due to the need to return an FIO file descriptor to IMIO, and so on. +To add support for a new format, one need only add a new driver to the IKI +and relink the system. + + +3. LOGICAL SCHEMA + + The logical schema of the current IKI is highly constrained by the fact +that the IKI is an add-on to the existing IMIO interface. It is not worthwhile +in this revision to try to address the limitations/design flaws of the initial +IMIO interface, hence our intention is to add the IKI in such a way that few +changes are required to IMIO, and no changes are required to programs which +use IMIO. One or two further major revisions are planned before the final +interface is realized. The concept of the IKI is here to stay, but the current +interface attempts only to address the immediate need to support multiple +image formats with the least impact on current software. + +An image consists of a header and a pixel array stored in a random access +binary file. Images may be grouped together into an array or "cluster" of +images, with the individual images being accessed by a one indexed subscript +appended to the cluster name, e.g., "pix[3]" refers to image 3 of the cluster +"pix". To create a cluster containing more than one image a / followed by +the cluster size may be included in the cluster index, e.g., "pix[3/10]" to +create a cluster of 10 images and write into image 3. An image section may +optionally be appended to access some subset of the pixels in the image, e.g., +"pix[3][*,5]". Lastly, if the image is stored as a disk file, the filename +extension of the header file may be given to explicitly indicate the image +format (IKI driver) to be used to access the image. + +A full specification (referencing an existing image) might therefore be +"pix.hhh[3][*,5]", where the ".hhh" extension indicates that the cluster is +physically stored in an SDAS GEIS (group format) data structure, the "[3]" +indicates image 3, and the "[*,5]" is a conventional IMIO image section. +If the minimal specification "pix" were given, the IKI would determine that +"pix" was a GEIS format image, accessing the entire contents of image [1]. +As an aside, note that image sections are handled entirely by IMIO and are +not seen at the IKI level. Likewise, the cluster subscript is parsed by +IMIO and passed to the IKI as an integer argument. + + + IM_PIXTYPE int pixel type (usilrdx) + IM_NDIM int number of axes (0:7) + IM_LEN long[7] logical length of each axis (>=1) + IM_PHYSLEN long[7] physical length of each axis (>=1) + IM_CLINDEX int index of image in cluster + IM_CLSIZE int number of images in cluster + IM_PIXOFF long char file offset to the pixels + IM_CTIME long image creation time + IM_MTIME long most recent image modification time + IM_LIMTIME long time when max/min last updated + IM_MAX real maximum pixel value + IM_MIN real minimum pixel value + IM_PIXFILE char*80 pathname of pixel file (optional) + IM_TITLE char*80 image title string + + +The important fields of the IMIO image descriptor are summarized above, along +with their datatype and length in the case of arrays. This is from the original +IMIO design and has not been modified in any way, except for the addition of the +cluster fields to the runtime descriptor. The IKI drivers directly read and +write these fields in the image descriptor. + +In addition to these standard fields (for which the IKI driver must supply +reasonable values at open time) the image descriptor contains a "user area" +containing an arbitrary sequence of keyword=value parameters encoded in +FITS character format. The FITS cards are trimmed at the right and +concatenated into an EOS delimited string with newline characters delimiting +each card. All host format specific header parameters should be passed to +IMIO in the user area. In the case of group format images, the user area +will contain both the group parameters (parameters shared by the entire group +of images) and the group header parameters (parameters for the individual +image in the group specified at open time). IMIO makes no distinction +between the two types of parameters. All header parameters are available +to the high level applications code via the IMIO/IDBI interface. + + +4. IKI INTERFACE PROCEDURES + + The IMIO code calls only the IKI procedures and has no knowledge of the +IKI drivers, or of which driver has been connected to a particular image +descriptor. The high level IKI procedures are summarized below. The interface +is fairly small due to the use of the descriptor to maintain all information +describing the image, and due to the fact that IMIO directly accesses the +pixel data via FIO. + + + iki_open (im, image, group, gcount, acmode, o_im) + iki_close (im) + iki_opix (im) # open/create pixfile + iki_updhdr (im) # update image header + + iki_copy (oldname, newname) # fast copy of entire group + iki_delete (group) # delete entire group + iki_rename (oldname, newname) # rename entire group + + k = iki_access (image, acmode) # test existence, legal extn + iki_lddriver (open,close, # install new driver + opix,updhdr, access,copy,delete,rename) + + +The OPEN procedure opens or creates the indicated image in the named cluster. +In the case of a new image or new copy image, only the header is created by +the open call; the pixfile is not created until the OPIX routine is called, +allowing the high level code time to set the image dimensions, datatype, +number of groups, etc., in the image descriptor. Once OPIX has been called +to create a new group, the number of axes, size of each axis, pixel type, +etc. is fixed. + +In the case of image stored in the SDAS/GEIS group format, all of the images +in a cluster (group) must be of the same size, must have the same header +parameters, and the header parameters must be defined when the group is +created (new parameters or images cannot be added to the group later). +The first open call for a image will allocate space for all images in the +cluster, but only the indicated image will be initialized in the first call. +Multiple images may be simultaneously open in the same cluster, and the same +image may be multiply opened on independent logical FIO file descriptors. + +The high level IRAF software has little or no knowledge of the physical +association of images into clusters. In particular, the high level software +is ignorant about the SDAS/GEIS image storage format, but this need not +prevent processing of these images. The main limitations of the group +format derive from the fact that new images can neither be added to nor +deleted from to a group format cluster, and new parameters cannot be added +to a group header. To create a group format image via IMIO, one will normally +make a NEW_COPY copy of an existing group format image (to define the fields +of the group headers), specifing the number of images in the new group in +the cluster size field of the image name specification. For example, writing +to the new image "pix[3/10]" will cause a cluster of 10 images to be created +and image 3 to be initialized. Subsequent calls to write to either "pix[I]" +or "pix[I/10]" will be necessary to initialize the remaining images in the +cluster. + + +5. KERNEL PROCEDURES + + Each supported image format requires a dedicated set of kernel procedures +to be called by the IKI to access images stored in that format. The calling +sequences for these procedures are shown below. + + + xxx_open (im, root, extn, cl_index, cl_size, acmode, status) + xxx_close (im, status) + xxx_opix (im, status) + xxx_updhdr (im, status) + + xxx_access (root, extn, acmode, status) + xxx_copy (old_root, old_extn, new_root, new_extn, status) + xxx_delete (root, extn, status) + xxx_rename (old_root, old_extn, new_root, new_extn, status) + + +Here, the package prefix "xxx" is OIF for the old IRAF image format, and STF +for the STScI/SDAS GEIS format. Note that the OPEN procedure fills in selected +fields in a preallocated image descriptor rather than allocating the descriptor +itself. Image names are parsed into root, extension, cl_index, etc. fields by +the IKI or higher level code, to further simplify the kernel code. The IKI +verifies the existence or nonexistence of all operand images before calling +a kernel procedure, hence the kernel procedures need not perform these +functions. The kernel procedures should return an ERR status if they cannot +perform their function for some reason (rather than take an error action). +The locpr() entry point addresses of the kernel procedures are saved in a +runtime table maintained by the IKI. + +The syntax and semantics of the kernel procedures are discussed in detail below. +Since the interface routines have full access to the IMIO descriptors, it is +important to realize what does and does not have to be set. + + +5.1 IMAGE OPEN PRIMITIVE + +include <imhdr.h> +include <imio.h> +include "xxx.h" + +# XXX_OPEN -- Open/create an image. + +procedure oif_open (im, root, extn, cl_index, cl_size, acmode, status) + +pointer im # image descriptor (allocated by IMIO) +char root[ARB] # root image name +char extn[ARB] # extension, if any +int cl_index # index of image to be opened +int cl_size # number of images in cluster +int acmode # access mode +int status # return status (OK|ERR) + +begin + 1. Construct the filename of the header file and open or create the + image header file. + + 2. If opening an existing image, read the image header and fill in + the following fields of the IMIO image header descriptor. If + creating a new image set only the field IM_HDRFILE. + + IM_PIXTYPE # datatype of the pixels ** + IM_NDIM # number of dimensions ** + IM_LEN # length of the dimensions ** + + IM_CTIME # time of image creation + IM_MTIME # time of last modify + IM_LIMTIME # time min,max computed + IM_MAX # max pixel value + IM_MIN # min pixel value + IM_PIXFILE # name of pixel storage file + IM_HDRFILE # name of header storage file + IM_TITLE # image name string + IM_HISTORY # history comment string + + The really essential fields are marked with a ** at the right. + CTIME, PIXFILE, HDRFILE, TITLE, and HISTORY are for information + only. MTIME and LIMTIME are used to determine if the min/max + pixel values are up to date, and the actual values do not matter + provided the conclusion about the min/max values is correct. + + 3. If opening an existing image, call IMIO to set those fields of the + image header/descriptor describing the format in which the pixels + are stored in the pixel storage file. + + [] call imioff (im, pixoff, COMPRESS, blklen) + + where + pixoff FIO file offset of first pixel. + compress Set to NO to enable alignment of image + lines on block boundaries, to YES for + compressed byte stream image. + blklen Device block size, chars. Set to 1 to + defeat all block alignment. + + If opening a new image, this step may be left until the OPIX + primitive is called. + + 3. If the kernel procedures use their own internal descriptor, + allocate and initialize the descriptor and save a pointer to + it in IM_KDES(im). + + 4. Set return status. +end + + +5.2 OPEN PIXEL FILE PRIMITIVE + +include <imhdr.h> +include <imio.h> +include "xxx.h" + +# XXX_OPIX -- Open (or create) the pixel storage file. Call IMIO to set the +# file offsets and buffer sizes. + +procedure xxx_opix (im, status) + +pointer im # image descriptor +int status # return status + +begin + 1. Opening existing image: + 1.1 Open pixel file read only or read write. + + 2. Opening (creating) new image: + 2.1 Call IMIO to set the offset parameters, assuming this was not + already done in the OPEN primitive: + + [] call imioff (im, pixoff, COMPRESS, blklen) + + 2.2 Using the file size computed by imioff or determined by more + format specific means, open (falloc) the pixel storage file. + The IM_HGMOFF field of the image header is set by imioff + to the file offset of the end of the image. + + 3. Call IMIO to set the i/o buffer parameters: + + [] call imsetbuf (pfd, im) + + This sets the FIO buffer size and the IM_FAST parameter. + The buffer size should be set before doing any i/o on the + pixel file. If in doubt, skip the call and simply set + IM_FAST(im) = NO (i/o will be suboptimal but not too bad). + + 4. Save the pixfile FIO file descriptor (required for pixel i/o) + in the image descriptor: + + [] IM_PFD(im) = pfd +end + + +5.3 UPDATE HEADER PRIMITIVE + +include <imhdr.h> +include <imio.h> + +# XXX_UPDHDR -- Update the image header. + +procedure xxx_updhdr (im, status) + +pointer im # image descriptor +int status # return status + +begin + 1. Update the values of the standard logical image header fields + in the physical image header, e.g., PIXTYPE, NDIM, LEN, and CTIME + (for new images), MTIME, LIMTIME, MIN, MAX (any image). + + 2. Save the "user fields" in the physical image header. Some of + these may have been inserted in the user area by the kernel open + procedure, others may have been added by IRAF programs or by + the user since the image was opened. +end + + +5.4 CLOSE IMAGE PRIMITIVE + +include <imio.h> + +# XXX_CLOSE -- Close an image. + +procedure xxx_close (im, status) + +pointer im # image descriptor +int status + +begin + 1. If the pixel file has been opened, close it. Note that if no + pixel i/o was done to the image, the pixel file will never have + been opened. + + 2. If the header file is still open, close it. + + 3. If a special kernel descriptor was allocated at image open time + by the kernel, deallocate it. +end diff --git a/sys/imio/iki/fxf/Notes b/sys/imio/iki/fxf/Notes new file mode 100644 index 00000000..2a2fd74d --- /dev/null +++ b/sys/imio/iki/fxf/Notes @@ -0,0 +1,81 @@ +Fits kernel notes / unresolved issues +---------------------------------------------------------------------------- + +Extraneous env variables - put in fkinit + + ENV_DEFIMTYPE "imtype" + ENV_FITSCACHE "fitscache" + + +Rename + + minhdrlns + + +Cache + + hard upper limit - is this a restriction? + convert from common to dynamic descriptor + referenced: open delete rename rfits updhdr + +Extensions + should not use imtype to set extension (this is copied from STF which + also has the same problem) + +Defaults / ksection / fkinit + should overwrite be allowed in fkinit? (fxfopen) + +check on file clobber + + +---------------------------------------------------------------------------- +Extension, default image type + +imtype + The purpose of imtype is to control the types of images automatically + created by the system if no image extension is specified. + + new image - determines default image type + new copy - determines default image type if noinherit + no extn - up to kernel whether this is legal + + imtype = [(oif|fxf|plf|qpf|stf) | <any-valid-extn>] [[no]inherit] + + save format codes ("oif" etc) in driver descriptors + extensions are mapped to drivers using imextn + + +imextn + map file extensions to image type (kernel) + default extension for new images of a given type + + imextn = "oif:imh stf:hhh,??h fits:,fits,fit + + or possibly imextn = "imh:oif hhh,??h:stf fits,fit:fit + + kernels: oif fxf plf qpf stf + + iki_extninit (imtype, def_imtype, imextn, def_imextn) + iki_validextn (kernel, extn) + status = iki_getextn (kernel, index, extn, maxch) + + Initialize extension processing stuff at iki_init time - only once when + the process starts up. + + nextn + { kernel extn patbuf } + sbuf, sbufused + defimtype + inherit + +IKI - add kernel arg to: + access + copy + delete + open + rename + + + + + diff --git a/sys/imio/iki/fxf/README b/sys/imio/iki/fxf/README new file mode 100644 index 00000000..9c723b94 --- /dev/null +++ b/sys/imio/iki/fxf/README @@ -0,0 +1,5 @@ +# IKI/FXF -- Fits extension image kernel. +# There is a document describing the differents FK supported parameters: +# iraf.noao.edu/iraf/web/docs/fitsuserguide.html +# A PS file of this can be found in iraf.noao.edu/iraf/docs/fitsuserguide.ps.Z + diff --git a/sys/imio/iki/fxf/fxf.h b/sys/imio/iki/fxf/fxf.h new file mode 100644 index 00000000..c4e6188b --- /dev/null +++ b/sys/imio/iki/fxf/fxf.h @@ -0,0 +1,172 @@ +# FITS.H -- IKI/FITS internal definitions. + +define FITS_ORIGIN "NOAO-IRAF FITS Image Kernel July 2003" + +define FITS_LENEXTN 4 # max length imagefile extension +define SZ_DATATYPE 16 # size of datatype string (eg "REAL*4") +define SZ_EXTTYPE 20 # size of exttype string (eg BINTABLE) +define SZ_KEYWORD 8 # size of a FITS keyword +define SZ_EXTRASPACE (81*32) # extra space for new cards in header +define DEF_PHULINES 0 # initial allocation for PHU +define DEF_EHULINES 0 # initial allocation for EHU +define DEF_PADLINES 0 # initial value for extra lines in HU +define DEF_PLMAXLEN 32768 # default max PLIO encoded line length +define DEF_PLDEPTH 0 # default PLIO mask depth + +define FITS_BLOCK_BYTES 2880 # FITS logical block length (bytes) +define FITS_BLOCK_CHARS 1440 # FITS logical block length (spp chars) +define FITS_STARTVALUE 10 # first column of value field +define FITS_ENDVALUE 30 # last column of value field +define FITS_SZVALSTR 21 # nchars in value string +define LEN_CARD 80 # length of FITS card. +define LEN_UACARD 81 # size of a Userarea line. +define LEN_OBJECT 63 # maximum length of a FITS string value +define LEN_FORMAT 40 # maximum length of a TFORM value +define NO_KEYW -1 # indicates no keyword is present. + +define MAX_OFFSETS 100 # max number of offsets per cache entry. +define MAX_CACHE 60 # max number of cache entries. +define DEF_CACHE 10 # default number of cache entries. + +define DEF_HDREXTN "fits" # default header file extension +define ENV_FKINIT "fkinit" # FITS kernel initialization + +define DEF_ISOCUTOVER 0 # date when ISO format dates kick in +define ENV_ISOCUTOVER "isodates" # environment override for default + +define FITS_BYTE 8 # Bits in a FITS byte +define FITS_SHORT 16 # Bits in a FITS short +define FITS_LONG 32 # Bits in a FITS long +define FITS_REAL -32 # 32 Bits FITS IEEE float representation +define FITS_DOUBLE -64 # 64 Bits FITS IEEE double representation + +define COL_VALUE 11 # Starting column for parameter values +define NDEC_REAL 7 # Precision of real +define NDEC_DOUBLE 14 # Precision of double + +define FITS_LEN_CHAR (((($1) + 1439)/1440)* 1440) + +# Extension subtypes. +define FK_PLIO 1 + +# Mapping of FITS Keywords to IRAF image header. All unrecognized keywords +# are stored here. + +#define UNKNOWN Memc[($1+IMU-1)*SZ_MII_INT+1] +define UNKNOWN Memc[($1+IMU-1)*SZ_STRUCT+1] + + +# FITS image descriptor, used internally by the FITS kernel. The required +# header parameters are maintained in this descriptor, everything else is +# simply copied into the user area of the IMIO descriptor. + +define LEN_FITDES 500 +define LEN_FITBASE 400 + +define FIT_ACMODE Memi[$1] # image access mode +define FIT_PFD Memi[$1+1] # pixel file descriptor +define FIT_PIXOFF Memi[$1+2] # pixel offset +define FIT_TOTPIX Memi[$1+3] # size of image in pixfile, chars +define FIT_IO Memi[$1+4] # FITS I/O channel +define FIT_ZCNV Memi[$1+5] # set if on-the-fly conversion needed +define FIT_IOSTAT Memi[$1+6] # i/o status for zfio routines +define FIT_TFORMP Memi[$1+7] # TFORM keyword value pointer +define FIT_TTYPEP Memi[$1+8] # TTYPE keyword value pointer +define FIT_TFIELDS Memi[$1+9] # number of fields in binary table +define FIT_PCOUNT Memi[$1+10] # PCOUNT keyword value + # extra space +define FIT_BSCALE Memd[P2D($1+16)] +define FIT_BZERO Memd[P2D($1+18)] +define FIT_BITPIX Memi[$1+20] # bits per pixel +define FIT_NAXIS Memi[$1+21] # number of axes in image +define FIT_LENAXIS Memi[$1+22+$2-1]# 35:41 = [7] max +define FIT_ZBYTES Memi[$1+30] # Status value for FIT_ZCNV mode +define FIT_HFD Memi[$1+31] # Header file descriptor +define FIT_PIXTYPE Memi[$1+32] +define FIT_CACHEHDR Memi[$1+33] # Cached main header unit's address. +define FIT_CACHEHLEN Memi[$1+34] # Lenght of the above. +define FIT_IM Memi[$1+35] # Has the 'im' descriptor value +define FIT_GROUP Memi[$1+36] +define FIT_NEWIMAGE Memi[$1+37] # Newimage flag +define FIT_HDRPTR Memi[$1+38] # Header data Xtension pointer +define FIT_PIXPTR Memi[$1+39] # Pixel data Xtension pointer +define FIT_NUMOFFS Memi[$1+40] # Number of offsets in cache header. +define FIT_EOFSIZE Memi[$1+41] # Size in char of file before append. +define FIT_XTENSION Memi[$1+42] # Yes, if an Xtension has been read. +define FIT_INHERIT Memi[$1+43] # INHERIT header keyword value. +define FIT_EXTVER Memi[$1+44] # EXTVER value (integer only) +define FIT_EXPAND Memi[$1+45] # Expand the header? +define FIT_MIN Memr[P2R($1+46)]# Minimum pixel value +define FIT_MAX Memr[P2R($1+47)]# Maximum pixel value +define FIT_MTIME Meml[$1+48] # Time of last mod. for FITS unit +define FIT_SVNANR Memr[P2R($1+49)] +define FIT_SVNAND Memd[P2D($1+50)] +define FIT_SVMAPRIN Memi[$1+52] +define FIT_SVMAPROUT Memi[$1+53] +define FIT_SVMAPDIN Memi[$1+54] +define FIT_SVMAPDOUT Memi[$1+55] +define FIT_EXTEND Memi[$1+56] # FITS extend keyword +define FIT_PLMAXLEN Memi[$1+57] # PLIO maximum linelen + # extra space +define FIT_EXTTYPE Memc[P2C($1+70)] # extension type +define FIT_FILENAME Memc[P2C($1+110)] # FILENAME value +define FIT_EXTNAME Memc[P2C($1+150)] # EXTNAME value +define FIT_DATATYPE Memc[P2C($1+190)] # datatype string +define FIT_TITLE Memc[P2C($1+230)] # title string +define FIT_OBJECT Memc[P2C($1+270)] # object string +define FIT_EXTSTYPE Memc[P2C($1+310)] # FITS extension subtype + # extra space + +# The FKS terms carry the fkinit or kernel section arguments. +define FKS_APPEND Memi[$1+400] # YES, NO append an extension +define FKS_INHERIT Memi[$1+401] # YES, NO inherit the main header +define FKS_OVERWRITE Memi[$1+402] # YES, NO overwrite an extension +define FKS_DUPNAME Memi[$1+403] # YES, NO allow duplicated EXTNAME +define FKS_EXTVER Memi[$1+404] # YES, NO allow duplicated EXTNAME +define FKS_EXPAND Memi[$1+405] # YES, NO expand the header +define FKS_PHULINES Memi[$1+406] # Allocated lines in PHU +define FKS_EHULINES Memi[$1+407] # Allocated lines in EHU +define FKS_PADLINES Memi[$1+408] # Additional lines for HU +define FKS_NEWFILE Memi[$1+409] # YES, NO force newfile +define FKS_CACHESIZE Memi[$1+410] # size of header cache +define FKS_SUBTYPE Memi[$1+411] # BINTABLE subtype +define FKS_EXTNAME Memc[P2C($1+412)] # EXTNAME value + # extra space + + +# Reserved FITS keywords known to this code. + +define FK_KEYWORDS "|bitpix|datatype|end|naxis|naxisn|simple|bscale|bzero\ +|origin|iraf-tlm|filename|extend|irafname|irafmax|irafmin|datamax\ +|datamin|xtension|object|pcount|extname|extver|nextend|inherit\ +|zcmptype|tform|ttype|tfields|date|" + +define KW_BITPIX 1 +define KW_DATATYPE 2 +define KW_END 3 +define KW_NAXIS 4 +define KW_NAXISN 5 +define KW_SIMPLE 6 +define KW_BSCALE 7 +define KW_BZERO 8 +define KW_ORIGIN 9 +define KW_IRAFTLM 10 +define KW_FILENAME 11 +define KW_EXTEND 12 +define KW_IRAFNAME 13 +define KW_IRAFMAX 14 +define KW_IRAFMIN 15 +define KW_DATAMAX 16 +define KW_DATAMIN 17 +define KW_XTENSION 18 +define KW_OBJECT 19 +define KW_PCOUNT 20 +define KW_EXTNAME 21 +define KW_EXTVER 22 +define KW_NEXTEND 23 +define KW_INHERIT 24 +define KW_ZCMPTYPE 25 +define KW_TFORM 26 +define KW_TTYPE 27 +define KW_TFIELDS 28 +define KW_DATE 29 diff --git a/sys/imio/iki/fxf/fxfaccess.x b/sys/imio/iki/fxf/fxfaccess.x new file mode 100644 index 00000000..860724f0 --- /dev/null +++ b/sys/imio/iki/fxf/fxfaccess.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "fxf.h" + + +# FXF_ACCESS -- Test the accessibility or existence of an existing image, or +# the legality of the name of a new image. Returns status = YES or NO. + +procedure fxf_access (kernel, root, extn, acmode, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #I extension (SET on output if none specified) +int acmode #I access mode (0 to test only existence) +int status #O status code + +int i +pointer sp, fname, kextn +int access(), iki_validextn(), iki_getextn(), btoi() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (kextn, FITS_LENEXTN, TY_CHAR) + + # If new image, test only the legality of the given extension. + # This is used to select a kernel given the imagefile extension. + + if (acmode == NEW_IMAGE || acmode == NEW_COPY) { + status = btoi (iki_validextn (kernel, extn) > 0) + call sfree (sp) + return + } + + status = NO + + # If no extension was given, look for a file with the default + # extension, and return the actual extension if an image with the + # default extension is found. + + if (extn[1] == EOS) { + do i = 1, ARB { + if (iki_getextn (kernel, i, Memc[kextn], FITS_LENEXTN) <= 0) + break + call iki_mkfname (root, Memc[kextn], Memc[fname], SZ_PATHNAME) + if (access (Memc[fname], acmode, 0) == YES) { + call strcpy (Memc[kextn], extn, FITS_LENEXTN) + status = YES + break + } + } + } else if (iki_validextn (kernel, extn) == kernel) { + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + if (access (Memc[fname], acmode, 0) == YES) + status = YES + } + + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfaddpar.x b/sys/imio/iki/fxf/fxfaddpar.x new file mode 100644 index 00000000..ce7849f5 --- /dev/null +++ b/sys/imio/iki/fxf/fxfaddpar.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <mach.h> +include "fxf.h" + +# FXF_ADDPAR -- Encode a parameter in FITS format and add it to the FITS format +# IMIO userarea. + +procedure fxf_addpar (im, pname, dtype, pval) + +pointer im #I image descriptor +char pname[ARB] #I parameter name +int dtype #I SPP datatype of parameter +char pval[ARB] #I string encoded parameter value + +bool bval +real rval +double dval +short sval +long lval +int ival, ip, junk +int ctoi(), ctor(), ctod() +errchk imadds, imaddl, imaddr, imaddd, imastr + +begin + ip = 1 + + switch (dtype) { + case TY_BOOL: + bval = (pval[1] == 'T') + call imaddb (im, pname, bval) + case TY_SHORT: + junk = ctoi (pval, ip, ival) + sval = ival + call imadds (im, pname, sval) + case TY_INT, TY_LONG: + junk = ctoi (pval, ip, ival) + lval = ival + call imaddl (im, pname, lval) + case TY_REAL: + junk = ctor (pval, ip, rval) + call imaddr (im, pname, rval) + case TY_DOUBLE: + junk = ctod (pval, ip, dval) + call imaddd (im, pname, dval) + default: + call imastr (im, pname, pval) + } +end diff --git a/sys/imio/iki/fxf/fxfcache.com b/sys/imio/iki/fxf/fxfcache.com new file mode 100644 index 00000000..c38317aa --- /dev/null +++ b/sys/imio/iki/fxf/fxfcache.com @@ -0,0 +1,24 @@ +# FXFCACHE.COM -- Named common block used to cache filenames and image +# extension information. +# +# ##### This should be reimplemented to use a small package (i.e. functions) +# ##### rather than global common. rf_fname below is using a lot of memory. +# ##### Dynamic memory allocation or a packed string buffer should be used +# ##### instead. Not worth fixing though until the cache code is redone. + +int rf_cachesize +pointer rf_fit[MAX_CACHE] # FITS descriptor +pointer rf_hdrp[MAX_CACHE] # Fits headers pointer +pointer rf_pixp[MAX_CACHE] # Fits pixels pointer +pointer rf_pextn[MAX_CACHE] # EXTNAME pointer +pointer rf_pextv[MAX_CACHE] # EXTVER pointer +int rf_lru[MAX_CACHE] # Lowest value is oldest slot +long rf_time[MAX_CACHE] # Time when entry was cached +long rf_mtime[MAX_CACHE] # Modify time of file in cache +int rf_hdr[MAX_CACHE] # FITS Primary header data +int rf_fitslen[MAX_CACHE] # Size Primary header data +char rf_fname[SZ_PATHNAME,MAX_CACHE] # Header file pathname + +common /fxflcachec/ rf_time, rf_mtime +common /fxfcachec/ rf_cachesize, rf_fit, rf_hdrp, rf_pixp, rf_pextn, + rf_pextv, rf_lru, rf_hdr, rf_fitslen, rf_fname diff --git a/sys/imio/iki/fxf/fxfclose.x b/sys/imio/iki/fxf/fxfclose.x new file mode 100644 index 00000000..72313316 --- /dev/null +++ b/sys/imio/iki/fxf/fxfclose.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "fxf.h" + +# FXF_CLOSE -- Close a FITS format image. There is little for us to do, since +# IMIO will already have updated the header if necessary and flushed any pixel +# output. Neither do we have to deallocate the IMIO descriptor, since it was +# allocated by IMIO. + +procedure fxf_close (im, status) + +pointer im #I image descriptor +int status #O status value + +pointer fit +errchk close + +begin + fit = IM_KDES(im) + + # Reset the IEEE interface to its original state. + switch (IM_ACMODE(im)) { + case READ_ONLY, READ_WRITE, WRITE_ONLY: + call ieesnanr (FIT_SVNANR(fit)) + call ieesmapr (FIT_SVMAPRIN(fit), FIT_SVMAPROUT(fit)) + call ieesnand (FIT_SVNAND(fit)) + call ieesmapd (FIT_SVMAPDIN(fit), FIT_SVMAPDOUT(fit)) + default: + ; + } + + # Close the fits file. + if (IM_PFD(im) != NULL) + call close (IM_PFD(im)) + + # Deallocate the FIT descriptor. + call mfree (fit, TY_STRUCT) + + status = OK +end diff --git a/sys/imio/iki/fxf/fxfcopy.x b/sys/imio/iki/fxf/fxfcopy.x new file mode 100644 index 00000000..3fb4d51b --- /dev/null +++ b/sys/imio/iki/fxf/fxfcopy.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> + +# FXF_COPY -- Copy an image. A special operator is provided for fast, blind +# copies of entire images. + +procedure fxf_copy (kernel, oroot, oextn, nroot, nextn, status) + +int kernel #I IKI kernel +char oroot[ARB] #I old image root name +char oextn[ARB] #I old image extn +char nroot[ARB] #I new image root name +char nextn[ARB] #I old image extn +int status + +pointer sp +pointer ohdr_fname, nhdr_fname + +begin + call smark (sp) + call salloc (ohdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (nhdr_fname, SZ_PATHNAME, TY_CHAR) + + # Generate filenames. + call iki_mkfname (oroot, oextn, Memc[ohdr_fname], SZ_PATHNAME) + call iki_mkfname (nroot, nextn, Memc[nhdr_fname], SZ_PATHNAME) + + iferr (call fcopy (Memc[ohdr_fname], Memc[nhdr_fname])) + call erract (EA_WARN) + + call sfree (sp) + status = OK +end diff --git a/sys/imio/iki/fxf/fxfctype.x b/sys/imio/iki/fxf/fxfctype.x new file mode 100644 index 00000000..f916e344 --- /dev/null +++ b/sys/imio/iki/fxf/fxfctype.x @@ -0,0 +1,72 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include "fxf.h" + + +# FXF_CTYPE -- Determine the type of a FITS card. + +int procedure fxf_ctype (card, kwindex) + +char card[ARB] #I FITS card (or keyword) +int kwindex #O index number, if any + +pointer sp, kwname +char kw[SZ_KEYWORD] +int index, ch, i, ip +int strncmp(), strdic(), strlen(), ctoi() +string keywords FK_KEYWORDS + +begin + call smark (sp) + call salloc (kwname, LEN_CARD, TY_CHAR) + + # Check for a reference to one of the NAXIS keywords. + kwindex= 0 + if (card[1] == 'N') + if (strncmp (card, "NAXIS", 5) == 0) { + ch = card[6] + if (ch == EOS || (IS_DIGIT(ch) && card[7] == ' ')) { + kwindex = TO_INTEG(ch) + } + call sfree (sp) + return (KW_NAXIS) + } + + # See if it is one of the "T"-prefixed (binary table) keywords. + if (card[1] == 'T') { + ip = 6 + if (strncmp (card, "TFORM", 5) == 0) { + if (ctoi (card, ip, kwindex) < 1) + kwindex = 0 + call sfree (sp) + return (KW_TFORM) + } + if (strncmp (card, "TTYPE", 5) == 0) { + if (ctoi (card, ip, kwindex) < 1) + kwindex = 0 + call sfree (sp) + return (KW_TTYPE) + } + } + + # Get keyword name in lower case with no blanks. + do i = 1, SZ_KEYWORD { + if (IS_WHITE(card[i])) { + kw[i] = EOS + break + } else if (IS_UPPER(card[i])) + kw[i] = TO_LOWER (card[i]) + else + kw[i] = card[i] + } + + # Look up keyword in dictionary. Abbreviations are not permitted. + index = strdic (kw, Memc[kwname], LEN_CARD, keywords) + if (index != 0) + if (strlen(kw) != strlen(Memc[kwname])) + index = 0 + + call sfree (sp) + return (index) +end diff --git a/sys/imio/iki/fxf/fxfdelete.x b/sys/imio/iki/fxf/fxfdelete.x new file mode 100644 index 00000000..ae7fbffc --- /dev/null +++ b/sys/imio/iki/fxf/fxfdelete.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include "fxf.h" + +# FXF_DELETE -- Delete a FITS file. NOTE: it is not possible to delete an +# individual extension at this time. + +procedure fxf_delete (kernel, root, extn, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #I header file extension +int status #O status value + +int cindx +pointer sp, fname, im, tmp +pointer immapz() +bool streq() + +errchk syserrs +include "fxfcache.com" + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (tmp, SZ_PATHNAME, TY_CHAR) + + call fxf_init() + status = OK + + # Get the file extension if not given. + if (extn[1] == EOS) { + call fxf_access (kernel, root, extn, READ_ONLY, status) + if (status == NO) { + call sfree (sp) + status = ERR + return + } + } + + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + call strcpy (Memc[fname], Memc[tmp], SZ_PATHNAME) + call strcat ("[0]", Memc[tmp], SZ_PATHNAME) + iferr (im = immapz (Memc[tmp], READ_ONLY, 0)) + call syserrs (SYS_FXFDELMEF, Memc[fname]) + else + call imunmap (im) + + iferr (call delete (Memc[fname])) + call erract (EA_WARN) + + # Remove the image from the FITS cache if found. + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + if (streq (Memc[fname], rf_fname[1,cindx])) { + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fit[cindx] = NULL + rf_lru[cindx] = 0 + rf_fname[1,cindx] = EOS + } + } + + status = OK + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfencode.x b/sys/imio/iki/fxf/fxfencode.x new file mode 100644 index 00000000..ea2e83dd --- /dev/null +++ b/sys/imio/iki/fxf/fxfencode.x @@ -0,0 +1,348 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <time.h> +include "fxf.h" + +# FXFENCODE.X -- Routines to encode a keyword, its value and a comment into +# a FITS card. +# +# fxf_encode_axis (root, keyword, axisno) +# fxf_encode_date (ctime, datestr, szdate, format, cutover) +# +# fxf_encodeb (keyword, param, card, comment) +# fxf_encodei (keyword, param, card, comment) +# fxf_encodel (keyword, param, card, comment) +# fxf_encoder (keyword, param, card, comment, precision) +# fxf_encoded (keyword, param, card, comment, precision) +# fxf_encodec (keyword, param, maxch, card, comment) +# +# fxf_akwc (keyword, value, len, comment, pn) +# fxf_akwb (keyword, value, comment, pn) +# fxf_akwi (keyword, value, comment, pn) +# fxf_akwr (keyword, value, comment, precision, pn) +# fxf_akwd (keyword, value, comment, precision, pn) +# +# Encode_axis adds an axis number to a keyword ("rootXXX"). Encode_date +# encodes the current date as a string in the form "dd/mm/yy". + + +# FXF_ENCODEB -- Encode a boolean parameter into a FITS card. + +procedure fxf_encodeb (keyword, param, card, comment) + +char keyword[ARB] # FITS keyword +int param # integer parameter equal to YES/NO +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +char truth + +begin + if (param == YES) + truth = 'T' + else + truth = 'F' + + call sprintf (card, LEN_CARD, "%-8.8s= %20c / %-47.47s") + call pargstr (keyword) + call pargc (truth) + call pargstr (comment) +end + + +# FXF_ENCODEI -- Encode an integer parameter into a FITS card. + +procedure fxf_encodei (keyword, param, card, comment) + +char keyword[ARB] # FITS keyword +int param # integer parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20d / %-47.47s") + call pargstr (keyword) + call pargi (param) + call pargstr (comment) +end + + +# FXF_ENCODEL -- Encode a long parameter into a FITS card. + +procedure fxf_encodel (keyword, param, card, comment) + +char keyword[ARB] # FITS keyword +long param # long integer parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20d / %-47.47s") + call pargstr (keyword) + call pargl (param) + call pargstr (comment) +end + + +# FXF_ENCODER -- Encode a real parameter into a FITS card. + +procedure fxf_encoder (keyword, param, card, comment, precision) + +char keyword[ARB] # FITS keyword +real param # real parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment card +int precision # precision of real + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.*e / %-47.47s") + call pargstr (keyword) + call pargi (precision) + call pargr (param) + call pargstr (comment) +end + + +# FXF_ENCODED -- Encode a double parameter into a FITS card. + +procedure fxf_encoded (keyword, param, card, comment, precision) + +char keyword[ARB] # FITS keyword +double param # double parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string +int precision # FITS precision + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.*e / %-47.47s") + call pargstr (keyword) + call pargi (precision) + call pargd (param) + call pargstr (comment) +end + + +# FXF_ENCODE_AXIS -- Add the axis number to axis dependent keywords. + +procedure fxf_encode_axis (root, keyword, axisno) + +char root[ARB] # FITS root keyword +char keyword[ARB] # FITS keyword +int axisno # FITS axis number + +int len, strlen() + +begin + call strcpy (root, keyword, SZ_KEYWORD) + len = strlen (keyword) + call sprintf (keyword, SZ_KEYWORD, "%*.*s%d") + call pargi (-len) + call pargi (len) + call pargstr (root) + call pargi (axisno) +end + + +# FXF_ENCODEC -- Procedure to encode an IRAF string parameter into a FITS card. + +procedure fxf_encodec (keyword, param, maxch, card, comment) + +char keyword[LEN_CARD] # FITS keyword +char param[LEN_CARD] # FITS string parameter +int maxch # maximum chars in value string +char card[LEN_CARD+1] # FITS card image +char comment[LEN_CARD] # comment string + +int nblanks, maxchar, slashp + +begin + maxchar = max(8, min (maxch, LEN_OBJECT)) + slashp = 32 + nblanks = LEN_CARD - (slashp + 1) + if (maxchar >= 19) { + slashp = 1 + nblanks = max (LEN_OBJECT - maxchar - slashp+3, 1) + } + + call sprintf (card, LEN_CARD, "%-8.8s= '%*.*s' %*t/ %*.*s") + call pargstr (keyword) + call pargi (-maxchar) + call pargi (maxchar) + call pargstr (param) + call pargi (slashp) + call pargi (-nblanks) + call pargi (nblanks) + call pargstr (comment) +end + + +# FXF_ENCODE_DATE -- Encode the current date as a string value. +# +# New Y2K format: yyyy-mm-ddThh:mm:sec +# Old FITS format: dd/mm/yy +# Old TLM format: hh:mm:ss (dd/mm/yyyy) +# +# We still write the old format for dates 1999 or less. + +procedure fxf_encode_date (ctime, datestr, maxch, format, cutover) + +long ctime #I time value to be encoded +char datestr[ARB] #O string containing the date +int maxch #I number of chars in the date string +char format[ARB] #I desired date format for old dates +int cutover #I write new format for years >= cutover + +int tm[LEN_TMSTRUCT], nchars +int dtm_encode_hms() +long lsttogmt() +bool streq() + +begin + # Find out what year it is. + call brktime (ctime, tm) + + # Encode in ISO format for years >= cutover year. + + if (TM_YEAR(tm) >= cutover) { + # ISO format is used for all new date stamps. + call brktime (lsttogmt(ctime), tm) + nchars = dtm_encode_hms (datestr, maxch, + TM_YEAR(tm), TM_MONTH(tm), TM_MDAY(tm), + TM_HOUR(tm), TM_MIN(tm), double(TM_SEC(tm)), 0, 0) + + } else if (streq (format, "TLM")) { + # TLM format is for old-format DATE-TLM keywords. + call sprintf (datestr, maxch, "%02d:%02d:%02d (%02d/%02d/%d)") + call pargi (TM_HOUR(tm)) + call pargi (TM_MIN(tm)) + call pargi (TM_SEC(tm)) + call pargi (TM_MDAY(tm)) + call pargi (TM_MONTH(tm)) + call pargi (TM_YEAR(tm)) + + } else { + # The default otherwise is the old FITS format. + call sprintf (datestr, maxch, "%02d/%02d/%02d") + call pargi (TM_MDAY(tm)) + call pargi (TM_MONTH(tm)) + call pargi (mod(TM_YEAR(tm),100)) + + } +end + + +# FXF_AKWC -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure fxf_akwc (keyword, value, len, comment, pn) + +char keyword[SZ_KEYWORD] # keyword name +char value[ARB] # keyword value +int len # length of value +char comment[ARB] # comment +pointer pn # pointer to a char area +char card[LEN_CARD] + +begin + call fxf_encodec (keyword, value, len, card, comment) + call amovc (card, Memc[pn], LEN_CARD) + pn = pn + LEN_CARD +end + + +# FXF_AKWB -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure fxf_akwb (keyword, value, comment, pn) + +char keyword[SZ_KEYWORD] # I keyword name +int value # I Keyword value (YES, NO) +char comment[ARB] # I Comment +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark (sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call fxf_encodeb (keyword, value, Memc[pc], comment) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree (sp) +end + + +# FXF_AKWI -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure fxf_akwi (keyword, value, comment, pn) + +char keyword[SZ_KEYWORD] # I keyword name +int value # I Keyword value +char comment[ARB] # I Comment +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark (sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call fxf_encodei (keyword, value, Memc[pc], comment) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree (sp) +end + + +# FXF_AKWR -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure fxf_akwr (keyword, value, comment, precision, pn) + +char keyword[SZ_KEYWORD] # I keyword name +real value # I Keyword value +char comment[ARB] # I Comment +int precision +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark (sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call fxf_encoder (keyword, value, Memc[pc], comment, precision) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree (sp) +end + + +# FXF_AKWD -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure fxf_akwd (keyword, value, comment, precision, pn) + +char keyword[SZ_KEYWORD] # I keyword name +double value # I Keyword value +char comment[ARB] # I Comment +int precision +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark (sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call fxf_encoded (keyword, value, Memc[pc], comment, precision) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfexpandh.x b/sys/imio/iki/fxf/fxfexpandh.x new file mode 100644 index 00000000..9e00d582 --- /dev/null +++ b/sys/imio/iki/fxf/fxfexpandh.x @@ -0,0 +1,375 @@ +include <imio.h> +include <imhdr.h> +include <mii.h> +include <fset.h> +include <mach.h> +include <syserr.h> +include "fxf.h" + +define MIN_BUFSIZE 2880 + + +# FXF_EXPANDH -- Routine to expand all the headers of a MEF file. The calling +# routine only requires that extension 'group' be expanded but when dealing +# with large MEF files with many extensions this procedure can take a long +# time if the application code wants to expand more than one header. +# fxf_expandh will expand all the headers in the file so they will have at +# least 'nlines' blank cards. + +procedure fxf_expandh (in_fd, out_fd, nlines, group, nbks, hdroff, pixoff) + +int in_fd #I input file descriptor +int out_fd #I output file descriptor +int nlines #I minimum number of blank cards +int group #I group that initiated the expansion +int nbks #I numbers of blocks to expand group 'group' +int hdroff #O new offset for beginning of 'group' +int pixoff #0 new offset for beginning of data + +pointer hd, ip, op, buf +char line[80], endl[80] +int gn, newc, k, nchars, nbk, hsize +int fxf_xaddl(), read() + +int bufsize, psize, rem, hoffset, poffset +int note(), fstati() +errchk malloc, read, write + +begin + # In case nlines is zero set a minimum > 0. + nlines = max (nlines, 10) + + # Initialize a blank line. + call amovks (" ", line, LEN_CARD) + + # Initialize END card image. + call amovc ("END", endl, 3) + call amovks (" ", endl[4], LEN_CARD-3) + + call fseti (in_fd, F_ADVICE, SEQUENTIAL) + call fseti (out_fd, F_ADVICE, SEQUENTIAL) + + bufsize = max (MIN_BUFSIZE, fstati (in_fd, F_BUFSIZE)) + call malloc (buf, bufsize, TY_CHAR) + + gn = 0 + hd = buf + + repeat { + hd = buf + if (group == gn) + hdroff = note(out_fd) + + # Read and write header information. The last block must + # have the END card and is output from this routine. + + iferr (call fxf_xhrd (in_fd, out_fd, Memc[buf], bufsize, hoffset, + poffset, hsize)) + break + + # Determine the number of cards to expand. newc is in blocks + # of 36 cards. 0, 36, 72, ... + + newc = fxf_xaddl (buf, hsize, nlines) + + # expand the given group at least one block + if (newc == 0 && nbks > 0 && group == gn) + newc = nbks * 36 + + # OP points to the top of the last block read, IP to the bottom. + op = buf + hsize - FITS_BLOCK_BYTES + ip = buf + hsize + + if (newc == 0) { + # Leave space for the END card. + ip = ip - 80 + } else { + # Write current buffer before writing blanks. + call miipak (Memc[op], Memc[op], FITS_BLOCK_BYTES, + TY_CHAR,MII_BYTE) + call write (out_fd, Memc[op], FITS_BLOCK_CHARS) + + # Use the same buffer space since we are using blanks + ip = ip - FITS_BLOCK_BYTES + op = ip + } + + # Write the blank cards. + do k = 1, newc-1 { + call amovc (line, Memc[ip], LEN_CARD) + ip = ip + LEN_CARD + if (mod (k,36) == 0) { + # We have more than one block of blanks. + call miipak (Memc[op], Memc[op], nchars, TY_CHAR, MII_BYTE) + call write (out_fd, Memc[op], FITS_BLOCK_CHARS) + + # Notice we used the same buffer space + ip = ip - FITS_BLOCK_BYTES + op = ip + } + } + + # Finally the END card. + call amovc (endl, Memc[ip], LEN_CARD) + nchars = 2880 + call miipak (Memc[op], Memc[op], nchars, TY_CHAR, MII_BYTE) + call write (out_fd, Memc[op], nchars/2) + + # Get the number of blocks of pixel data to copy. We are not + # changing anything; it is straight copy. + + psize = (hoffset - poffset) + + nbk = psize / bufsize + rem = mod(psize,bufsize) + + if (group == gn) + pixoff = note(out_fd) + + do k = 1, nbk { + nchars = read (in_fd, Memc[buf], bufsize) + call write (out_fd, Memc[buf], bufsize) + } + if (rem > 0) { + nchars = read (in_fd, Memc[buf], rem) + call write (out_fd, Memc[buf], rem) + } + gn = gn + 1 + } + + call mfree (buf, TY_CHAR) +end + + +# FXF_XHRD -- Procedure to read 2880 bytes blocks of header from 'in' +# and copy them to 'out'. The last block read contains the END card +# and is pass to the calling routine which will write it out to 'out. + +procedure fxf_xhrd (in, out, buf, bufsize, hoffset, poffset, hsize) + +int in #I Input file descriptor +int out #I output file descriptor +char buf[ARB] #I Working buffer +int bufsize #I Workign buffer size +int hoffset #O Header offset for next group +int poffset #O Data offset for current group +int hsize #O Number of cards read in header + +pointer sp, hb +int nblks, totpix, i, j, ip, nchars +int strncmp(), note(), read() +bool end_card, fxf_xn_decode_blk1() + +include "fxfcache.com" +errchk syserr, read, write + +begin + call smark (sp) + call salloc (hb, 1440, TY_CHAR) + + hoffset = note (in) + + # Read first block of header. + nchars = read (in, Memc[hb], FITS_BLOCK_CHARS) + if (nchars == EOF) { + call sfree (sp) + call syserr (SYS_FXFRFEOF) + } + + call miiupk (Memc[hb], buf, FITS_BLOCK_BYTES, MII_BYTE,TY_CHAR) + end_card = fxf_xn_decode_blk1 (buf, totpix) + if (!end_card) { + call miipak (buf, Memc[hb], FITS_BLOCK_BYTES, TY_CHAR, MII_BYTE) + call write (out, Memc[hb], FITS_BLOCK_CHARS) + } + ip = FITS_BLOCK_BYTES + 1 + + nblks = 1 + if (!end_card) { + # Continue reading header until the block with END + # which is the last before the data block. + + while (read (in, Memc[hb], FITS_BLOCK_CHARS) != EOF) { + call miiupk (Memc[hb], buf[ip], FITS_BLOCK_BYTES, + MII_BYTE,TY_CHAR) + + # Look for the END card + do i = 0, 35 { + j = ip + i*LEN_CARD + if (buf[j] == 'E') { + if (strncmp (buf[j], "END ", 8) == 0) + end_card = true + } + } + nblks = nblks + 1 + if (end_card) + break + call miipak (buf[ip], Memc[hb], FITS_BLOCK_BYTES, + TY_CHAR, MII_BYTE) + call write (out, Memc[hb], FITS_BLOCK_CHARS) + ip = ip + FITS_BLOCK_BYTES + + # If the header is really big we can run out of + # buffer space. Revert back to the beginning. + + if (ip > bufsize) { + ip = 1 + nblks = 1 + } + } + } + + hsize = nblks * 36 * LEN_CARD + + # We are at the beginning of the pixel area. + poffset = note (in) + + # Get the beginnning of the next header. + hoffset = poffset + totpix + + call sfree (sp) +end + + +# FXF_XN_DECODE_BLK1 -- Function that return true if the 1st block of a header +# contains the END card. The size of the pixel are is also returned. + +bool procedure fxf_xn_decode_blk1 (buf, datalen) + +char buf[ARB] #I header data buffer +int datalen #O length of data area in chars + +char card[LEN_CARD] +int totpix, nbytes, index, k, i, pcount, bitpix, naxis, ip +int len_axis[7] +int fxf_ctype() +bool end_card +errchk syserr, syserrs + +begin + # Read successive lines of the 1st header block + pcount = 0 + + end_card = false + do k = 0, 35 { + ip = k*LEN_CARD + 1 + + # Copy into a one line buffer, we need to EOS mark. + call strcpy (buf[ip], card, LEN_CARD) + switch (fxf_ctype (card, index)) { + case KW_END: + end_card = true + break + case KW_PCOUNT: + call fxf_geti (card, pcount) + case KW_BITPIX: + call fxf_geti (card, bitpix) + case KW_NAXIS: + if (index == 0) { + call fxf_geti (card, naxis) + if (naxis < 0 ) + call syserr (SYS_FXFRFBNAXIS) + } else + call fxf_geti (card, len_axis[index]) + default: + ; + } + } + + # Calculate the length of the data area of the current extension, + # measured in SPP chars and rounded up to an integral number of FITS + # logical blocks. + + if (naxis != 0) { + totpix = len_axis[1] + do i = 2, naxis + totpix = totpix * len_axis[i] + + # Compute the size of the data area (pixel matrix plus PCOUNT) + # in bytes. Be careful not to overflow a 32 bit integer. + + nbytes = (totpix + pcount) * (abs(bitpix) / NBITS_BYTE) + + # Round up to fill the final 2880 byte FITS logical block. + nbytes = ((nbytes + 2880-1) / 2880) * 2880 + + datalen = nbytes / SZB_CHAR + + } else + datalen = 0 + + return (end_card) +end + + +# FXF_XADDL -- Algorithm to find the number of blank cards stored in the +# input buffer. This is the number from the end of the buffer up to the +# last non blank card (excluding the END card). The function returns the +# number of extra header cards (in multiple of 36) that is necessary to +# add to the current header. + +int procedure fxf_xaddl (hd, ncua, nlines) + +pointer hd #U header area pointer +int ncua #I number of characters in the user area +int nlines #I minimum number of header lines to be added + +int ip, nbc, k, ncards, nkeyw +int strncmp() + +begin + # Go to the end of buffer and get last line pointer + ip = hd + ncua - LEN_CARD + + # See if line is blank. + nbc = 0 + while (ip > hd) { + # Check for nonblank card + do k = 0, LEN_CARD-1 + if (Memc[ip+k] != ' ') + break + + # Since we are counting from the bottom, the first keyword + # (except END) would end counting. + + if (k != LEN_CARD && k != 0) # nonblank keyw card reached + break + else if (k == 0) { + # Just bypass END and continue looking for blank cards + if (strncmp ("END ", Memc[ip], 8) == 0) { + # Clear this card as it will be written at the + # end of the output header. + call amovkc (" ", Memc[ip], LEN_CARD) + ip = ip - LEN_CARD + next + } else + break + } else + nbc = nbc + 1 + ip = ip - LEN_CARD + } + + # Calculate the number of keywords right before the last blank + # card and right after the last non-blank keyword, excluding the + # END card + + nkeyw = (ip-hd)/80 + 1 + + ncards = ncua / LEN_CARD + + # Calculate the complement with respect to 36 + ncards = ((ncards + 35)/36)*36 - ncards + nbc = nbc + ncards + + + if (nbc < nlines) { + # Lets add nlines-nbc cards to the header + ncards = nlines - nbc + + # Adjust to a 36 cards boundary. + ncards = 36 - mod (ncards, 36) + ncards + } else + ncards = 0 + + return (ncards) +end diff --git a/sys/imio/iki/fxf/fxfget.x b/sys/imio/iki/fxf/fxfget.x new file mode 100644 index 00000000..87b80d4f --- /dev/null +++ b/sys/imio/iki/fxf/fxfget.x @@ -0,0 +1,182 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include "fxf.h" + +# FXFGET.X -- Procedures used to get (decode) typed values from FITS cards. +# +# fxf_get[bird] (card, value) +# fxf_gstr (card, outstr, maxch) +# fxf_getcmt (card, comment, maxch) +# fxf_gltm (time, date, limtime) +# +# The value is returned in the output argument. Zero is returned if the +# conversion fails. + + +# FXF_GETI -- Return the integer value of a FITS encoded card. + +procedure fxf_geti (card, ival) + +char card[ARB] # card to be decoded +int ival # receives integer value + +int ip, ctoi() +char sval[FITS_SZVALSTR] + +begin + call fxf_gstr (card, sval, FITS_SZVALSTR) + ip = 1 + if (ctoi (sval, ip, ival) <= 0) + ival = 0 +end + + +# FXF_GETR -- Return the real value of a FITS encoded card. + +procedure fxf_getr (card, rval) + +char card[ARB] # card to be decoded +real rval # receives integer value + +int ip, ctor() +char sval[FITS_SZVALSTR] + +begin + call fxf_gstr (card, sval, FITS_SZVALSTR) + ip = 1 + if (ctor (sval, ip, rval) <= 0) + rval = 0.0 +end + + +# FXF_GETD -- Return the double value of a FITS encoded card. + +procedure fxf_getd (card, dval) + +char card[ARB] # card to be decoded +double dval # receives integer value + +int ip, ctod() +char sval[FITS_SZVALSTR] + +begin + call fxf_gstr (card, sval, FITS_SZVALSTR) + ip = 1 + if (ctod (sval, ip, dval) <= 0) + dval = 0.0 +end + + +# FXF_GETB -- Return the boolean/integer value of a FITS encoded card. + +procedure fxf_getb (card, bval) + +char card[ARB] # card to be decoded +int bval # receives YES/NO + +char sval[FITS_SZVALSTR] + +begin + call fxf_gstr (card, sval, FITS_SZVALSTR) + if (sval[1] == 'T') + bval = YES + else + bval = NO +end + + +# FXF_GSTR -- Get the string value of a FITS encoded card. Strip leading +# and trailing whitespace and any quotes. + +procedure fxf_gstr (card, outstr, maxch) + +char card[ARB] # FITS card to be decoded +char outstr[ARB] # output string to receive parameter value +int maxch + +int ip, op +int ctowrd(), strlen() + +begin + ip = FITS_STARTVALUE + if (ctowrd (card, ip, outstr, maxch) > 0) { + # Strip trailing whitespace. + op = strlen (outstr) + while (op > 0 && (IS_WHITE(outstr[op]) || outstr[op] == '\n')) + op = op - 1 + outstr[op+1] = EOS + } else + outstr[1] = EOS +end + + +# FXF_GETCMT -- Get the comment field of a FITS encoded card. + +procedure fxf_getcmt (card, comment, maxch) + +char card[ARB] #I FITS card to be decoded +char comment[ARB] #O output string to receive comment +int maxch #I max chars out + +int ip, op +int lastch + +begin + # Find the slash which marks the beginning of the comment field. + ip = FITS_ENDVALUE + 1 + while (card[ip] != EOS && card[ip] != '\n' && card[ip] != '/') + ip = ip + 1 + + # Copy the comment to the output string, omitting the /, any + # trailing blanks, and the newline. + + lastch = 0 + do op = 1, maxch { + if (card[ip] == EOS) + break + ip = ip + 1 + comment[op] = card[ip] + if (card[ip] > ' ') + lastch = op + } + comment[lastch+1] = EOS +end + + +# FXF_GLTM -- Procedure to convert an input time stream with hh:mm:ss +# and date stream dd/mm/yy into seconds from jan 1st 1980. + +procedure fxf_gltm (time, date, limtime) + +char time[ARB], date[ARB] +int limtime + +int month_to_days[12], adays +int hr,mn,sec,days,month,year, ip, iy, days_per_year, ctoi(), i +data month_to_days / 0,31,59,90,120,151,181,212,243,273,304,334/ + +begin + + ip = 1; ip = ctoi (time, ip, hr) + ip = 1; ip = ctoi (time[4], ip, mn) + ip = 1; ip = ctoi (time[7], ip, sec) + + sec = sec + mn * 60 + hr * 3600 + + ip = 1; ip = ctoi (date, ip, days) + ip = 1; ip = ctoi (date[4], ip, month) + ip = 1; ip = ctoi (date[7], ip, year) + + days_per_year = 0 + iy = year + 1900 + do i = 1, iy - 1980 + days_per_year = days_per_year + 365 + + adays = (year - 80) / 4 + if (month > 2) + adays = adays + 1 + + days = adays + days-1 + days_per_year + month_to_days[month] + limtime = sec + days * 86400 +end diff --git a/sys/imio/iki/fxf/fxfhextn.x b/sys/imio/iki/fxf/fxfhextn.x new file mode 100644 index 00000000..7f8a879d --- /dev/null +++ b/sys/imio/iki/fxf/fxfhextn.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "fxf.h" + + +# FXF_GETHDREXTN -- Get the default header file extension. + +procedure fxf_gethdrextn (im, o_im, acmode, outstr, maxch) + +pointer im, o_im #I image descriptors +int acmode #I image access mode +char outstr[ARB] #O receives header extension +int maxch #I max chars out + +bool inherit +int kernel, old_kernel +int fnextn(), iki_getextn(), iki_getpar() + +begin + # Use the same extension as the input file if this is a new copy + # image of the same type as the input and inherit is enabled. + # If we have to get the extension using iki_getextn, the default + # extension for a new image is the first extension defined (index=1). + + kernel = IM_KERNEL(im) + + old_kernel = 0 + if (acmode == NEW_COPY && o_im != NULL) + old_kernel = IM_KERNEL(o_im) + + inherit = (iki_getpar ("inherit") == YES) + if (inherit && acmode == NEW_COPY && kernel == old_kernel) { + if (fnextn (IM_HDRFILE(im), outstr, maxch) <= 0) + call strcpy (DEF_HDREXTN, outstr, maxch) + } else if (iki_getextn (kernel, 1, outstr, maxch) < 0) + call strcpy (DEF_HDREXTN, outstr, maxch) +end diff --git a/sys/imio/iki/fxf/fxfksection.x b/sys/imio/iki/fxf/fxfksection.x new file mode 100644 index 00000000..cb37b4e5 --- /dev/null +++ b/sys/imio/iki/fxf/fxfksection.x @@ -0,0 +1,475 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <ctotok.h> +include <lexnum.h> +include <imhdr.h> +include "fxf.h" + +# FXFKSECTION.X -- Routines to parse the FITS kernel section into +# parameter names and values. + +define KS_EXTNAME 1 +define KS_EXTVER 2 +define KS_APPEND 3 +define KS_NOAPPEND 4 +define KS_OVERWRITE 5 +define KS_DUPNAME 6 +define KS_INHERIT 7 +define KS_NOINHERIT 8 +define KS_NODUPNAME 9 +define KS_NOOVERWRITE 10 +define KS_EXPAND 11 +define KS_PHULINES 12 +define KS_EHULINES 13 +define KS_PADLINES 14 +define KS_NOEXPAND 15 +define KS_CACHESIZE 16 +define KS_TYPE 17 +define ERROR -2 + + +# FXF_KSECTION -- Procedure to parse and analyze a string of the form: +# +# "keyword=value,keyword+,keyword-,..." +# e.g., +# "[extname=]name,[extver=]23,append,inherit+,overwrite+,dupname-" +# +# The 'extver' numeric field is position dependent if it does not have +# the parameter name. The 'group' output variable is not -1 when specified +# as the 1st number in the section. + +procedure fxf_ksection (ksection, fit, group) + +char ksection[ARB] #I String with kernel section +pointer fit #I Fits structure pointer +int group #O Extension number + +bool extn +char outstr[LEN_CARD] +char identif[LEN_CARD] +int ip, jp, nident, nexpr, junk, nch, ty, token, ival +int lex_type, fxf_ks_lex(), ctoi(), ctotok(), lexnum() +errchk syserr, syserrs + +begin + # The default values should have been already initialized + # with a call fxf_ksinit(). + + ip = 1 + nexpr = 0 + nident = 0 + extn = false + group = -1 + identif[1] = EOS + + repeat { + # Advance to the next keyword. + token = ctotok (ksection, ip, outstr, LEN_CARD) + + switch (token) { + case TOK_EOS: + break + case TOK_NEWLINE: + break + + case TOK_NUMBER: + if (nexpr != 1 && nexpr != 2 && extn) + call syserr (SYS_FXFKSNV) + jp = 1 + ty = lexnum (outstr, jp, nch) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + jp = 1 + junk = ctoi (outstr, jp, ival) + if (nexpr == 0) { + group = ival + identif[1] = 1 + } else + FKS_EXTVER(fit) = ival + nexpr = nexpr + 1 + + case TOK_PUNCTUATION: + if (outstr[1] == ',' && identif[1] == EOS) + call syserr (SYS_FXFKSSYN) + + case TOK_STRING: + if (nexpr != 0 && nexpr != 1) + call syserr (SYS_FXFKSSVAL) + call strcpy (outstr, FKS_EXTNAME(fit), LEN_CARD) + nexpr = nexpr + 1 + extn = true + + case TOK_IDENTIFIER: + nident = nident + 1 + call strcpy (outstr, identif, LEN_CARD] + call strlwr (outstr) + lex_type = fxf_ks_lex (outstr) + + # look for =<value>, + or - + if (lex_type > 0) { + call fxf_ks_gvalue (lex_type, ksection, ip, fit) + } else { + if (nexpr == 0 || nexpr == 1) + call strcpy (identif, FKS_EXTNAME(fit), LEN_CARD) + else + call syserr (SYS_FXFKSSVAL) + } + nexpr = nexpr + 1 + extn = true + + default: + call syserr (SYS_FXFKSSYN) + } + } +end + + +# FXF_KS_LEX -- Map an identifier into a FITS kernel parameter code. + +int procedure fxf_ks_lex (outstr) + +char outstr[ARB] + +int len, strlen(), strncmp() +errchk syserr, syserrs + +begin + len = strlen (outstr) + + # Allow for small string to be taken as extname values and not + # kernel paramaters; like 'ap' instead of 'ap(ppend)'. + if (len < 3) + return(0) + + # See if it is extname or extver. + if (strncmp (outstr, "ext", 3) == 0 && len < 8 ) { + if (len == 3) + call syserr (SYS_FXFKSEXT) + if (strncmp (outstr[4], "name", len-3) == 0) + return (KS_EXTNAME) + else if (strncmp (outstr[4], "ver", len-3) == 0) + return (KS_EXTVER) + + # Check for the "no" versions of selected keywords. + } else if (strncmp (outstr, "no", 2) == 0 && len < 12) { + if (strncmp (outstr[3], "append", len-2) == 0) + return (KS_NOAPPEND) + if (strncmp (outstr[3], "inherit", len-2) == 0) + return (KS_NOINHERIT) + if (strncmp (outstr[3], "overwrite", len-2) == 0) + return (KS_NOOVERWRITE) + if (strncmp (outstr[3], "dupname", len-2) == 0) + return (KS_NODUPNAME) + if (strncmp (outstr[3], "expand", len-2) == 0) + return (KS_NOEXPAND) + } + + # Other kernel keywords. + if (strncmp (outstr, "inherit", len) == 0) + return (KS_INHERIT) + if (strncmp (outstr, "overwrite", len) == 0) + return (KS_OVERWRITE) + if (strncmp (outstr, "dupname", len) == 0) + return (KS_DUPNAME) + if (strncmp (outstr, "append", len) == 0) + return (KS_APPEND) + if (strncmp (outstr, "noappend", len) == 0) + return (KS_NOAPPEND) + if (strncmp (outstr, "type", len) == 0) + return (KS_TYPE) + if (strncmp (outstr, "expand", len) == 0) + return (KS_EXPAND) + if (strncmp (outstr, "phulines", len) == 0) + return (KS_PHULINES) + if (strncmp (outstr, "ehulines", len) == 0) + return (KS_EHULINES) + if (strncmp (outstr, "padlines", len) == 0) + return (KS_PADLINES) + if (strncmp (outstr, "cachesize", len) == 0) + return (KS_CACHESIZE) + + return (0) # not recognized; probably a value +end + + +# FXF_KS_GVALUE -- Given a parameter code get its value at the 'ip' character +# position in the 'ksection' string. Put the values in the FKS structure. + +procedure fxf_ks_gvalue (param, ksection, ip, fit) + +int param #I parameter code +char ksection[ARB] #I Ksection +int ip #I Current parsing pointer in ksection +pointer fit #U Update the values in the FKS structure + +pointer sp, ln +int jp, token +int ctotok() +errchk syserr, syserrs + +begin + jp = ip + + call smark (sp) + call salloc (ln, LEN_CARD, TY_CHAR) + + # See if the parameter value is given as par=<value> or '+/-' + if (ctotok (ksection, jp, Memc[ln], LEN_CARD) == TOK_OPERATOR) { + if (Memc[ln] == '=' ) { + token = ctotok (ksection, jp, Memc[ln], LEN_CARD) + if (token != TOK_IDENTIFIER && + token != TOK_STRING && token != TOK_NUMBER) { + call syserr (SYS_FXFKSSYN) + } else { + call fxf_ks_val (Memc[ln], param, fit) + ip = jp + } + } else if (Memc[ln] == '+' || Memc[ln] == '-') { + call fxf_ks_pm (Memc[ln], param, fit) + ip = jp + } + } else { + switch (param) { + case KS_APPEND: + FKS_APPEND(fit) = YES + case KS_NOAPPEND: + FKS_APPEND(fit) = NO + case KS_OVERWRITE: + FKS_OVERWRITE(fit) = YES + case KS_NOOVERWRITE: + FKS_OVERWRITE(fit) = NO + case KS_DUPNAME: + FKS_DUPNAME(fit) = YES + case KS_INHERIT: + FKS_INHERIT(fit) = YES + case KS_NOINHERIT: + FKS_INHERIT(fit) = NO + case KS_EXPAND: + FKS_EXPAND(fit) = YES + case KS_NOEXPAND: + FKS_EXPAND(fit) = NO + default: + call syserr (SYS_FXFKSSYN) + } + } + + call sfree (sp) +end + + +# FXF_KS_VALUE -- Returns the value of a parameter in the kernel section. + +procedure fxf_ks_val (outstr, param, fit) + +char outstr[ARB] #I Input string with value +int param #I Parameter code +pointer fit #U Fits kernel descriptor + +int ty, ip, ival, nchars +int lexnum(), ctoi(), strcmp() +errchk syserr, syserrs + +begin + call strlwr (outstr) + if (strcmp (outstr, "yes") == 0) + ival = YES + else if (strcmp (outstr, "no") == 0) + ival = NO + else + ival = ERROR + + switch (param) { + case KS_EXTNAME: + call strcpy (outstr, FKS_EXTNAME(fit), LEN_CARD) + + case KS_TYPE: + call strlwr (outstr) + if (strcmp ("mask", outstr) == 0) + FKS_SUBTYPE(fit) = FK_PLIO + else + call syserrs (SYS_FXFKSINVAL, "type") + case KS_EXTVER: + ip = 1 + ty = lexnum (outstr, ip, nchars) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + ip = 1 + nchars = ctoi (outstr, ip, ival) + if (nchars <= 0) + call syserrs (SYS_FXFKSINVAL, "extver") + FKS_EXTVER(fit) = ival + + case KS_APPEND: + if (ival != ERROR) + FKS_APPEND(fit) = ival + else + call syserrs (SYS_FXFKSINVAL, "append") + + case KS_OVERWRITE: + if (ival != ERROR) + FKS_OVERWRITE(fit) = ival + else + call syserrs (SYS_FXFKSINVAL, "overwrite") + + case KS_DUPNAME: + if (ival != ERROR) + FKS_DUPNAME(fit) = ival + else + call syserrs (SYS_FXFKSINVAL, "dupname") + + case KS_INHERIT: + if (ival != ERROR) + FKS_INHERIT(fit) = ival + else + call syserrs (SYS_FXFKSINVAL, "inherit") + + case KS_EXPAND: + if (ival != ERROR) + FKS_EXPAND(fit) = ival + else + call syserrs (SYS_FXFKSINVAL, "expand") + + case KS_PHULINES: + ip = 1 + ty = lexnum (outstr, ip, nchars) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + ip = 1 + nchars = ctoi (outstr, ip, ival) + if (nchars <= 0 || ival < 0) + call syserrs (SYS_FXFKSPVAL, "phulines") + FKS_PHULINES(fit) = ival + + case KS_EHULINES: + ip = 1 + ty = lexnum (outstr, ip, nchars) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + ip = 1 + nchars = ctoi (outstr, ip, ival) + if (nchars <= 0 || ival < 0) + call syserrs (SYS_FXFKSPVAL, "ehulines") + FKS_EHULINES(fit) = ival + + case KS_PADLINES: + ip = 1 + ty = lexnum (outstr, ip, nchars) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + ip = 1 + nchars = ctoi (outstr, ip, ival) + if (nchars <= 0 || ival < 0) + call syserrs (SYS_FXFKSPVAL, "padlines") + FKS_PADLINES(fit) = ival + + case KS_CACHESIZE: + ip = 1 + ty = lexnum (outstr, ip, nchars) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + ip = 1 + nchars = ctoi (outstr, ip, ival) + if (nchars <= 0 || ival < 0) + call syserrs (SYS_FXFKSPVAL, "cachesize") + FKS_CACHESIZE(fit) = ival + + default: + call syserr (SYS_FXFKSSYN) + } +end + + +# FXF_KS_PM -- Return the character YES or NO based on the value '+' or '-' + +procedure fxf_ks_pm (pm, param, fit) + +char pm[1] #I contains "+" or "-" +int param #I Parameter code +pointer fit #U Fits kernel descriptor + +int ival +errchk syserr, syserrs + +begin + if (pm[1] == '+') + ival = YES + else + ival = NO + + switch (param) { + case KS_APPEND: + FKS_APPEND(fit) = ival + case KS_OVERWRITE: + FKS_OVERWRITE(fit) = ival + case KS_DUPNAME: + FKS_DUPNAME(fit) = ival + case KS_INHERIT: + FKS_INHERIT(fit) = ival + case KS_EXPAND: + FKS_EXPAND(fit) = ival + default: + call syserr (SYS_FXFKSSYN) + } +end + + +# FXF_KS_ERRORS -- Handle an error condition in the kernel section. + +procedure fxf_ks_errors (fit, acmode) + +pointer fit #I fits kernel descriptor +int acmode #I image access mode + +int group +errchk syserr, syserrs + +begin + group = FIT_GROUP(fit) + + if (FKS_OVERWRITE(fit) == YES) { + if (FIT_NEWIMAGE(fit) == YES) + iferr (call syserrs (SYS_FOPNNEXFIL, IM_HDRFILE(FIT_IM(fit)))) + call erract (EA_WARN) + if (acmode == APPEND) + call syserrs (SYS_FXFKSNOVR, "APPEND") + if (group == -1 && + (FKS_EXTNAME(fit) == EOS && IS_INDEFL(FKS_EXTVER(fit)))) + call syserr (SYS_FXFKSOVR) + } else { + switch (acmode) { + case NEW_COPY: + if (group != -1 && FKS_APPEND(fit) == NO) + call syserr (SYS_FXFKSBOP) + case NEW_IMAGE: + if (group != -1) + call syserrs (SYS_FXFKSNEXT, "NEW_IMAGE" ) + case APPEND: + if (group != -1) + call syserrs (SYS_FXFKSNEXT, "APPEND" ) + } + } +end + + +# FXF_KSINIT -- Initialize default values for ks parameters. + +procedure fxf_ksinit (fit) + +pointer fit #I fits kernel descriptor + +begin + FKS_EXTNAME(fit) = EOS + FKS_SUBTYPE(fit) = NO + FKS_EXTVER(fit) = INDEFL + FKS_APPEND(fit) = NO + FKS_OVERWRITE(fit) = NO + FKS_DUPNAME(fit) = NO + FKS_EXPAND(fit) = YES + FKS_PHULINES(fit) = DEF_PHULINES + FKS_EHULINES(fit) = DEF_EHULINES + FKS_PADLINES(fit) = DEF_PADLINES + FKS_INHERIT(fit) = YES + FKS_CACHESIZE(fit) = DEF_CACHE +end diff --git a/sys/imio/iki/fxf/fxfmkcard.x b/sys/imio/iki/fxf/fxfmkcard.x new file mode 100644 index 00000000..81bb3ab7 --- /dev/null +++ b/sys/imio/iki/fxf/fxfmkcard.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FXF_MK_CARD -- Fetch a single line from a string parameter, padding it to +# a maximum of maxcols characters and trimmimg the delim character. + +procedure fxf_make_card (instr, ip, card, col_out, maxcols, delim) + +char instr[ARB] #I input string +int ip #U input string pointer, updated at each call +char card[ARB] #O FITS card image +int col_out #I pointer to column in card +int maxcols #I maximum columns in card +int delim #I 1 character string delimiter + +int op + +begin + op = col_out + + # Copy string + while (op <= maxcols && instr[ip] != EOS && instr[ip] != delim) { + card[op] = instr[ip] + ip = ip + 1 + op = op + 1 + } + + # Fill remainder of card with blanks + while (op <= maxcols ) { + card[op] = ' ' + op = op + 1 + } + + if (instr[ip] == delim) + ip = ip + 1 +end diff --git a/sys/imio/iki/fxf/fxfnull.x b/sys/imio/iki/fxf/fxfnull.x new file mode 100644 index 00000000..ce3baece --- /dev/null +++ b/sys/imio/iki/fxf/fxfnull.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "fxf.h" + +# FXF_NULL -- Null driver entry point. + +procedure fxf_null() + +errchk syserr, syserrs + +begin + call syserr (SYS_FXFFKNULL) +end diff --git a/sys/imio/iki/fxf/fxfopen.x b/sys/imio/iki/fxf/fxfopen.x new file mode 100644 index 00000000..bceed618 --- /dev/null +++ b/sys/imio/iki/fxf/fxfopen.x @@ -0,0 +1,1014 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imio.h> +include <finfo.h> +include <fset.h> +include <mii.h> +include <mach.h> +include "fxf.h" + + +# FXF_OPEN -- Open/create a FITS format image with extensions. + +procedure fxf_open (kernel, im, o_im, root, extn, ksection, group, gc_arg, + acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I other descriptor for NEW_COPY image +char root[ARB] #I root image name +char extn[ARB] #I extension, if any +char ksection[ARB] #I [extname,extver,overwrite,append,inherit..] +int group #I index of group to be accessed +int gc_arg #I [NOT USED] +int acmode #I access mode +int status #O status flag to calling routine + +long fi[LEN_FINFO] +int newimage, i, gn, ksinh, type, fmode +pointer sp, path, fit_extn, ua, o_fit, fit +bool pre_read, fks_extn_or_ver, dyh, fsec, plio +int fxf_check_dup_extnv(), itoc(), strcmp(), strncmp() +int open(), access(), imgeti(), fstatl(), finfo(), fxf_header_size() +pointer pl_open() + +errchk fmkcopy, calloc, open, fxf_rheader, fxf_prhdr, fxf_gaccess +errchk fxf_fclobber, fxf_ksection, fxf_alloc, syserr, syserrs +errchk fxf_check_group +define duperr_ 91 +define err_ 92 + +begin + call smark (sp) + call salloc (path, SZ_PATHNAME, TY_CHAR) + call salloc (fit_extn, FITS_LENEXTN, TY_CHAR) + call fxf_init() + ua = IM_USERAREA(im) + + fmode = acmode + + # Allocate internal FITS image descriptor. + call fxf_alloc (fit) + + IM_KDES(im) = fit + IM_HFD(im) = NULL + FIT_IM(fit) = im + call amovki (1, FIT_LENAXIS(fit,1), IM_MAXDIM) + + # Generate full header file name. + if (extn[1] == EOS) { + call fxf_gethdrextn (im, o_im, fmode, Memc[fit_extn], FITS_LENEXTN) + call iki_mkfname (root, Memc[fit_extn], Memc[path], SZ_PATHNAME) + call strcpy (Memc[fit_extn], extn, FITS_LENEXTN) + } else + call iki_mkfname (root, extn, Memc[path], SZ_PATHNAME) + + # Header and pixel filename are the same. + call strcpy (Memc[path], IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (IM_HDRFILE(im), IM_PIXFILE(im), SZ_IMPIXFILE) + + newimage = NO + if (access (IM_HDRFILE(im), 0, 0) == NO) + newimage = YES + FIT_NEWIMAGE(fit) = newimage + + # Initialize kernel section default values. + call fxf_ksinit (fit) + + # For simplicity treat the APPEND mode as NEW_IMAGE. For the FK + # is the same. + + if (fmode == APPEND) + fmode = NEW_IMAGE + FIT_ACMODE(fit) = fmode + + # Read fkinit and ksection and check that the extension number + # specifications therein and the IMIO cluster index "group" are + # consistent. + + call fxf_check_group (im, ksection, fmode, group, ksinh) + + fks_extn_or_ver = FKS_EXTNAME(fit) != EOS || !IS_INDEFL(FKS_EXTVER(fit)) + + # Check if a file section is necessary. + fsec = (fks_extn_or_ver || group >= 0) + call fxf_gaccess (im, fsec) + + # The previous call could have changed FIT_NEWIMAGE; reset value. + newimage = FIT_NEWIMAGE(fit) + + if (fks_extn_or_ver) + FIT_GROUP(fit) = -1 + + # See if we want to write a dummy primary unit. + # + # For PLIO, if creating a new output file and we want to create a + # BINTABLE, create a dummy header. Otherwise see if a type is + # requested, in which case we would need to create a dummmy header + # if no file is present yet. + + type = 0 + if (FKS_SUBTYPE(fit) == FK_PLIO) + type = FK_PLIO + + dyh = false + if (newimage == YES && (fks_extn_or_ver || type > 0)) { + call fxf_dummy_header (im, status) + if (status == ERR) + goto err_ + newimage = NO + dyh = true + if (fmode == NEW_COPY && type == FK_PLIO) + FIT_PIXOFF(fit) = fxf_header_size(im) + FITS_BLOCK_CHARS + } + if (newimage == NO) { + if (finfo (IM_HDRFILE(im), fi) != ERR) + FIT_EOFSIZE(fit) = (FI_SIZE(fi)+SZB_CHAR-1)/SZB_CHAR + 1 + else + call syserrs (SYS_FOPEN, IM_HDRFILE(im)) + } + + if (newimage == YES) + FKS_OVERWRITE(fit) = NO + else + FIT_XTENSION(fit) = YES + + FIT_NEWIMAGE(fit) = newimage + + # If all these conditions are met then set the pre_read flag. + pre_read = (fks_extn_or_ver || + FKS_OVERWRITE(fit) == YES || FKS_INHERIT(fit) == YES) + + if (newimage == NO && fmode != READ_ONLY) { + # See that INHERIT makes sense if it has been set by + # 'fkinit' when reading a file with PHU (naxis != 0). + + if (FKS_INHERIT(fit) == YES && group != 0) { + gn = 0 + iferr (call fxf_prhdr (im, gn)) { + FKS_INHERIT(fit) = NO + + # Issue an error only if the inherit is in the filename. + if (fmode == NEW_COPY && ksinh == YES) + call syserr (SYS_FXFBADINH) + } else if (FIT_NAXIS(fit) != 0) + FKS_INHERIT(fit) = NO + + # Reset the pre_read flag. + pre_read = ((FKS_DUPNAME(fit) == NO && + FKS_INHERIT(fit) == YES) || FKS_OVERWRITE(fit) == YES) + } + + if (pre_read && fmode != NEW_COPY && !dyh) + call fxf_prhdr (im, group) + + if (access (IM_HDRFILE(im), fmode, 0) == NO) + call syserrs (SYS_FNOWRITEPERM, IM_HDRFILE(im)) + } + + switch (fmode) { + case NEW_IMAGE, APPEND: + if (newimage == NO) { + # Make sure the UA is empty when overwriting. + if (pre_read && FKS_OVERWRITE(fit) == YES) + Memc[ua] = EOS + + if (FKS_DUPNAME(fit) == NO) + if (fxf_check_dup_extnv (im, group) == YES) + goto duperr_ + } else { + # See if it is necessary to invalidate the cache entry for the + # current filename. It could happen that the user has deleted + # the filename and a new file with the same is created. + + call fxf_check_old_name (im) + } + + if (FKS_INHERIT(fit) == YES) + FIT_INHERIT(fit) = YES + + # Initialize a new copy of a PLIO image mask. + if (type == FK_PLIO) + IM_PL(im) = pl_open (NULL) + + case NEW_COPY: + # Completely new copy of an existing image. This could mean a + # new file or append a new image to an existing file. + + # Initialize a new copy of a PLIO image mask. + if (type == FK_PLIO) { + IM_PL(im) = pl_open (NULL) + if (IM_PL(o_im) != NULL) + call fxf_plpf (im) + } + + if (newimage == YES || FKS_APPEND(fit) == NO) + call fxf_check_old_name (im) + + # For a PLIO mask, make sure there are no SUBYTPE keywords in + # the UA since this will be rewritten by fxf_updhdr(). + + if (IM_PL(o_im) != NULL) + call fxf_clean_pl (im) + + if (IM_KDES(o_im) != NULL && IM_KERNEL(o_im) == IM_KERNEL(im)) { + o_fit = IM_KDES(o_im) + call strcpy (FIT_EXTTYPE(o_fit), FIT_EXTTYPE(fit), SZ_EXTTYPE) + call strcpy (FIT_EXTNAME(o_fit), FIT_EXTNAME(fit), LEN_CARD) + FIT_EXTVER(fit) = FIT_EXTVER(o_fit) + + # Reset the value of the keyword INHERIT in the new_copy + # image if the input has a no_inherit in the filename. + + FIT_INHERIT(fit) = NO + call fxf_filter_keyw (im, "INHERIT") + + # Change the value only if explicitly done in the output + # kernel section. + + if (FKS_INHERIT(fit) == YES) + FIT_INHERIT(fit) = YES + + } else { + # Reblock if old image is imh for example. + if (IM_UABLOCKED(im) != YES) + call fxf_reblock (im) + + # See if the old image have EXTNAME or EXTVER keywords. + # Notice that old image does not have to be of FITS type. + + iferr (call imgstr (o_im,"EXTNAME",FIT_EXTNAME(fit),LEN_CARD)) + FIT_EXTNAME(fit) = EOS + iferr (FIT_EXTVER(fit) = imgeti (o_im, "EXTVER")) + FIT_EXTVER(fit) = INDEFL + call strcpy ("IMAGE", FIT_EXTTYPE(fit), SZ_EXTTYPE) + } + + # Delete ORIGIN keyword, since we are going to put a new one. + call fxf_filter_keyw (im, "ORIGIN") + + # Now that we have a new_copy of the input FITS structure, + # initialize some of its members. + + FIT_HFD(fit) = NULL + FIT_NEWIMAGE(fit) = newimage + if (newimage == NO) + FIT_XTENSION(fit) = YES + FIT_ACMODE(fit) = fmode + if (FKS_APPEND(fit) != YES) + FIT_GROUP(fit) = group + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + + if (FKS_OVERWRITE(fit) == NO) { + if (FKS_EXTNAME(fit) == EOS) + call strcpy (FIT_EXTNAME(fit), FKS_EXTNAME(fit), LEN_CARD) + else + call imastr (im, "EXTNAME", FKS_EXTNAME(fit)) + + if (IS_INDEFL(FKS_EXTVER(fit))) + FKS_EXTVER(fit) = FIT_EXTVER(fit) + else + call imaddi (im, "EXTVER", FKS_EXTVER(fit)) + + # We need to pre_read extensions headers to check for + # duplicates with these extname and extver. + + if (FKS_EXTNAME(fit) != EOS ||!IS_INDEFL(FKS_EXTVER(fit))) + pre_read = true + } + + if (newimage == NO && !dyh) { + if (pre_read) { + iferr (call fxf_prhdr (im, group)) + ; + } + + # Check for duplicated EXTNAME and/or EXTVER if any of the + # following conditions are met. + + if (FKS_DUPNAME(fit) == NO && FKS_OVERWRITE(fit) == NO && + (fks_extn_or_ver || FIT_EXTNAME(fit) != EOS || + !IS_INDEFL(FIT_EXTVER(fit)))) { + if (fxf_check_dup_extnv (im, group) == YES) + goto duperr_ + } + } + + FIT_NAXIS(fit) = IM_NDIM(im) + do i = 1, IM_NDIM(im) + FIT_LENAXIS(fit,i) = IM_LEN(im,i) + + # Inherit datatype of input template image if specified, + # otherwise default datatype to real. + + if (IM_PIXTYPE(o_im) != NULL) + IM_PIXTYPE(im) = IM_PIXTYPE(o_im) + else + IM_PIXTYPE(im) = TY_REAL + + default: + # No Overwrite allowed in READ_ONLY or READ_WRITE. + FKS_OVERWRITE(fit) = NO + + # Check that we have single FITS file. + if (!fsec && group == -1) + group = 0 + + # Open an existing image. + iferr (call fpathname (IM_HDRFILE(im), Memc[path], SZ_PATHNAME)) + goto err_ + if (fmode == READ_WRITE) + IM_HFD(im) = open (Memc[path], READ_WRITE, BINARY_FILE) + else + IM_HFD(im) = open (Memc[path], READ_ONLY, BINARY_FILE) + + iferr (call fxf_rheader (im, group, fmode)) { + call close (IM_HFD(im)) + call mfree (fit, TY_STRUCT) + call sfree (sp) + status = ERR + call erract (EA_ERROR) + } + + if (group == 0) + FIT_XTENSION(fit) = NO + else + FIT_XTENSION(fit) = YES + + # Some non-iraf fits files might have keywords that are + # imcompatible with our header. For example if hediting the header, + # make sure that they are eliminated. + + if (fmode == READ_WRITE) + call fxf_discard_keyw (im) + + FIT_EOFSIZE(fit) = fstatl (IM_HFD(im), F_FILESIZE) + 1 + + # PLIO. If we read the header of a PLIO_1 compressed image file + # then it is a PL file; now read the data. + + plio = (strncmp (FIT_EXTSTYPE(fit), "PLIO_1", 6) == 0) + if (plio) { + call fxf_plread (im) + + # We need to setup the IMIO descriptor if we need to write + # over a section; in particular IM_PFD needs to be defined. + + if (fmode == READ_WRITE) + call fxf_plpf (im) + } + + # Close the header file. + call close (IM_HFD(im)) + IM_HFD(im) = NULL + + # Do not allow the user to see any non_IMAGE extensions. + if (strcmp ("IMAGE", FIT_EXTTYPE(fit)) != 0 && + strcmp ("SIMPLE", FIT_EXTTYPE(fit)) != 0 && !plio) + call syserrs (SYS_IKIEXTN, IM_NAME(im)) + } + + FIT_HFD(fit) = IM_HFD(im) + status = OK + + call sfree (sp) + return +duperr_ + i = itoc (group, Memc[path], LEN_CARD) + call syserrs (SYS_FXFOPEXTNV, Memc[path]) +err_ + status = ERR + call mfree (fit, TY_STRUCT) + call sfree (sp) +end + + +# FXF_ALLOC -- Initialize memory for the FIT descriptor. + +procedure fxf_alloc (fit) + +pointer fit #I input fits descriptor + +errchk calloc + +begin + call calloc (fit, LEN_FITDES, TY_STRUCT) + + FIT_GROUP(fit) = -1 + FIT_PIXTYPE(fit) = NULL + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + FIT_XTENSION(fit) = NO + FIT_INHERIT(fit) = NO + FIT_EOFSIZE(fit) = 0 + FIT_EXTNAME(fit) = EOS + FIT_EXTVER(fit) = INDEFL +end + + +# FXF_INIT -- Initialize any runtime FITS kernel descriptors to their +# process startup state. + +procedure fxf_init() + +int i +bool first_time +data first_time /true/ + +include "fxfcache.com" + +begin + # Disable the hdrcache until it is fully initialized in rfitshdr. + if (first_time) { + rf_cachesize = 0 + do i = 1, MAX_CACHE { + rf_fit[i] = 0 + } + + first_time = false + } +end + + +# FXF_KS_RDHDR -- Procedure to preread the FITS headers up to group +# 'group'. The idea is to have the offset pointers in memory since the +# can be overwritten or when no group (i.e. -1) is given and the extname or +# extver are specified. + +procedure fxf_prhdr (im, group) + +pointer im #I image descriptor +int group #I maximum group number to read + +int poff, extv +pointer fit, lim, lfit, sp, path +errchk fpathname, open, syserr, fxf_alloc, calloc +int open(), imgeti() + +begin + call smark (sp) + call salloc (path, SZ_PATHNAME, TY_CHAR) + + # We will use a local temporary imio and fit structures. +# call calloc (lim, LEN_IMDES+LEN_IMHDR+MIN_LENUSERAREA, TY_STRUCT) + call calloc (lim, LEN_IMDES+IM_LENHDRMEM(im), TY_STRUCT) + + call fxf_alloc (lfit) + + IM_KDES(lim) = lfit + fit = IM_KDES(im) + + FIT_GROUP(lfit) = group + FIT_ACMODE(lfit) = FIT_ACMODE(fit) + call strcpy (FKS_EXTNAME(fit), FKS_EXTNAME(lfit), LEN_CARD) + FKS_EXTVER(lfit) = FKS_EXTVER(fit) + + iferr (extv = imgeti (im, "EXTVER")) + extv = INDEFL + + FKS_OVERWRITE(lfit) = FKS_OVERWRITE(fit) + FKS_DUPNAME(lfit) = FKS_DUPNAME(fit) + FKS_INHERIT(lfit) = FKS_INHERIT(fit) + FKS_CACHESIZE(lfit) = FKS_CACHESIZE(fit) + + # Open an existing image. + call strcpy (IM_HDRFILE(im), IM_HDRFILE(lim), SZ_PATHNAME) + call strcpy (IM_NAME(im), IM_NAME(lim), SZ_PATHNAME) + + call fpathname (IM_HDRFILE(im), Memc[path], SZ_PATHNAME) + IM_HFD(lim) = open (Memc[path], READ_ONLY, BINARY_FILE) + + IM_LENHDRMEM(lim) = IM_LENHDRMEM(im) + + # If we want to inherit the global header we need to read + # the group specified in the filename. + + iferr (call fxf_rfitshdr (lim, group, poff)) { + call close (IM_HFD(lim)) + call mfree (lfit, TY_STRUCT) + call mfree (lim, TY_STRUCT) + call sfree (sp) + call erract (EA_ERROR) + + } else { + call close (IM_HFD(lim)) + call sfree (sp) + if (FKS_OVERWRITE(fit) == YES) + FIT_GROUP(fit) = FIT_GROUP(lfit) + group = FIT_GROUP(lfit) + + # Now set the offset pointers to the original 'fit' struct. + FIT_HDRPTR(fit) = FIT_HDRPTR(lfit) + FIT_PIXPTR(fit) = FIT_PIXPTR(lfit) + FIT_EXTEND(fit) = FIT_EXTEND(lfit) + + FIT_CACHEHDR(fit) = FIT_CACHEHDR(lfit) + FIT_CACHEHLEN(fit) = FIT_CACHEHLEN(lfit) + + FIT_NAXIS(fit) = FIT_NAXIS(lfit) + FIT_INHERIT(fit) = FIT_INHERIT(lfit) + FIT_PLMAXLEN(fit) = FIT_PLMAXLEN(lfit) + + IM_CTIME(im) = IM_CTIME(lim) + + call mfree (lfit, TY_STRUCT) + call mfree (lim, TY_STRUCT) + + if (extv != INDEFL) + call imaddi (im, "EXTVER", extv) + } +end + + +# FXF_DUMMY_HEADER -- Built a minimum Primary Fits header. This is +# necessary in case we are creating an IMAGE extension and we don't +# want to put any information in the PHU. + +procedure fxf_dummy_header (im, status) + +pointer im #I image descriptor +int status #O status flag + +char blank[1] +pointer sp, path, spp, mii, pn, n +int iso_cutover, fd, nblanks, size_rec + +int strlen(), open(), envgeti() +long clktime() + +begin + call smark (sp) + call salloc (spp, FITS_BLOCK_BYTES, TY_CHAR) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + call salloc (path, SZ_PATHNAME, TY_CHAR) + + status = OK + + iferr { + call fpathname (IM_HDRFILE(IM), Memc[path], SZ_PATHNAME) + fd = open (Memc[path], NEW_FILE, BINARY_FILE) + } then { + call sfree (sp) + status = ERR + return + } + + pn = spp + call fxf_akwb ("SIMPLE", YES, "FITS STANDARD", pn) + call fxf_akwi ("BITPIX", 8, "Character information", pn) + call fxf_akwi ("NAXIS", 0, "No image data array present", pn) + call fxf_akwb ("EXTEND", YES, "File may contain extensions", pn) + call fxf_akwc ("ORIGIN", FITS_ORIGIN, + strlen(FITS_ORIGIN), "FITS file originator", pn) + + # Dates after iso_cutover use ISO format dates. + iferr (iso_cutover = envgeti (ENV_ISOCUTOVER)) + iso_cutover = DEF_ISOCUTOVER + + # Encode the DATE keyword. + call fxf_encode_date (clktime(long(0)), Memc[path], LEN_CARD, + "ISO", 2000) + call fxf_akwc ("DATE", Memc[path], + strlen(Memc[path]), "Date FITS file was generated", pn) + + blank[1] = ' ' + call amovkc (blank[1], Memc[pn], LEN_CARD) + call amovc ("END", Memc[pn], 3) + pn = pn + LEN_CARD + + n = pn - spp + size_rec = FITS_BLOCK_CHARS + nblanks = FITS_BLOCK_BYTES - n + call amovkc (blank[1], Memc[spp+n], nblanks) + call miipak (Memc[spp], Memi[mii], size_rec*2, TY_CHAR, MII_BYTE) + call write (fd, Memi[mii], size_rec) + + call close (fd) + + call sfree (sp) +end + + +# FXF_CHECK_DUP_EXTN_VER --- Function to check for a duplicate EXTNAME or +# EXTVER in the FITS file open with NEW_COPY mode. The filename specification +# does not have EXTNAME nor EXTVER in the ksection. +# Returns YES if there are duplicates. + +int procedure fxf_check_dup_extnv (im, group) + +pointer im #I image descriptor +int group #O extension number where there is a duplicate + +int cindx +pointer extn, extv, sp, hdrfile, fit, poff +int fxf_extnv_error() +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + fit = IM_KDES(im) + + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + extn = rf_pextn[cindx] + extv = rf_pextv[cindx] + poff = rf_pixp[cindx] # pixel offset -1 if EOF + group = 1 + + # Now compare the input image FIT_EXT(NAME,VER) with + # the cache values of the NEW_COPY images. + + while (Memc[extn+LEN_CARD*group] != EOS || + !IS_INDEFL(Memi[extv+group]) || Memi[poff+group] != -1) { + if (fxf_extnv_error (fit, group, extn, extv) == YES) { + call sfree (sp) + if (FKS_OVERWRITE(fit) == YES) + return (NO) + else + return (YES) + } else + group = group + 1 + } + } + } + + call sfree (sp) + return (NO) +end + + +# FXF_CHECK_OLD_NAME -- Check is the filename is already in cache for a +# NEWIMAGE == YES mode; if so, make the entry obsolete. + +procedure fxf_check_old_name (im) + +pointer im #I image descriptor + +int cindx +pointer sp, hdrfile, fit +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + + fit = IM_KDES(im) + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + # Verify that we have the correct file. + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fit[cindx] = NULL + rf_mtime[cindx] = 0 # invalidate cache entry + rf_fname[1,cindx] = EOS + break + } + } + + call sfree (sp) +end + + +# FXF_REBLOCK -- If the user area is not blocked to fixed length records, e.g., +# as is possible in a new copy image, reblock it fixed length. + +procedure fxf_reblock (im) + +pointer im #I image descriptor + +pointer sp, lbuf, op, ua +int fd, spool, nlines, nchars, sz_userarea, len_hdrmem +errchk stropen, open, getline, putline, realloc, seek, fcopyo +int open(), stropen(), getline() + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + ua = IM_USERAREA(im) + fd = stropen (Memc[ua], ARB, READ_ONLY) + spool = open ("rb_spool", READ_WRITE, SPOOL_FILE) + + # Reblock into a spool file, counting the lines. + for (nlines=0; ; nlines=nlines+1) { + nchars = getline (fd, Memc[lbuf]) + if (nchars <= 0) + break + + for (op=nchars; op <= LEN_CARD; op=op+1) + Memc[lbuf+op-1] = ' ' + Memc[lbuf+LEN_CARD] = '\n' + Memc[lbuf+LEN_CARD+1] = EOS + call putline (spool, Memc[lbuf]) + } + + call close (fd) + + # Reallocate header the right size. + sz_userarea = nlines * (LEN_CARD+1) + SZ_EXTRASPACE + + IM_HDRLEN(im) = LEN_IMHDR + + (sz_userarea - SZ_EXTRASPACE + SZ_MII_INT-1) / SZ_MII_INT + len_hdrmem = LEN_IMHDR + + (sz_userarea+1 + SZ_MII_INT-1) / SZ_MII_INT + + if (IM_LENHDRMEM(im) < len_hdrmem) { + IM_LENHDRMEM(im) = len_hdrmem + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + } + + # Move spooled data back to user area. + ua = IM_USERAREA(im) + fd = stropen (Memc[ua], sz_userarea, NEW_FILE) + call seek (spool, BOFL) + call fcopyo (spool, fd) + + IM_UABLOCKED(im) = YES + call close (fd) + call close (spool) + call sfree (sp) +end + + +# FXF_FCLOBBER -- Clobber an existing FITS file. We use the environment +# variable 'clobber' rather than 'imclobber' because is a file and not +# an image. + +procedure fxf_fclobber (file) + +char file #I input filename to delete + +int cindx +bool streq() +include "fxfcache.com" + +begin + iferr (call delete (file)) + call filerr (file, SYS_FCANTCLOB) + + # Remove the name from the cache. + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + # Verify that we have the correct file. + if (streq (file, rf_fname[1,cindx])) { + if (rf_fit[cindx] != NULL) { + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fit[cindx] = NULL + } + } + } +end + + +# FXF_ACCESS -- Check if a file section is necessary to access any +# particular extension. + +procedure fxf_gaccess (im, fsec) + +pointer im #I image descriptor +bool fsec #I true if extname,extver or group have values + +bool mef +int acmode, fit, newimage, group +bool envgetb(), fnullfile() +errchk syserr, syserrs, fxf_fclobber + +begin + fit = IM_KDES(im) + acmode = FIT_ACMODE(fit) + newimage = FIT_NEWIMAGE(fit) + + if (acmode == READ_ONLY || acmode == READ_WRITE) { + # If no file section then see if it is a MEF by prereading an + # extension. + + if (!fsec) { + group = 1 + mef = false + ifnoerr (call fxf_prhdr (im, group)) + mef = true + else { + # Flag error if the group does not exist and overwrite+. + if (FKS_OVERWRITE(fit) == YES) + call syserrs (SYS_FXFEXTNF, IM_NAME(im)) + } + # Multi-extension file but no extension was specified. + if (mef) + call syserrs (SYS_FXFOPNOEXTNV, IM_NAME(im)) + FIT_GROUP(fit) = 0 + FIT_XTENSION(fit) = NO + } + } + + switch (acmode) { + case NEW_COPY, NEW_IMAGE, APPEND: + if (envgetb ("imclobber")) { + if (newimage == NO) { + if (FKS_APPEND(fit) != YES && FKS_OVERWRITE(fit) != YES) { + # Clobber the file. + call fxf_fclobber (IM_HDRFILE(im)) + FIT_NEWIMAGE(fit) = YES + } + } + } else { + if (newimage == NO) + if (FKS_APPEND(fit) != YES && FKS_OVERWRITE(fit) != YES) { + if (!fnullfile (IM_HDRFILE(im))) + call syserrs (SYS_IKICLOB, IM_HDRFILE(im)) + } + } + default: + ; + } + +end + + +# FXF_CHECK_GROUP -- Check for group specification from fkinit, ksection +# and cluster index are equal when specifified and they are also compatible +# when (extname,extver) is in the kernel sections. + +procedure fxf_check_group (im, ksection, acmode, group, ksinh) + +pointer im #I imio descriptor +char ksection[ARB] #I kernel section +int acmode #I fits unit extension mode +int group #U extension number in the image section +int ksinh #O INHERIT value from the filename ksection + +pointer sp, ks, fit +bool fks_extn_or_ver, inherit_override +int igroup, kgroup, fgroup, tgroup, sv_inherit, newimage, append +bool fnullfile() +int envgets() + +errchk syserrs, fxf_ks_error + +begin + call smark (sp) + call salloc (ks, SZ_LINE, TY_CHAR) + + fit = IM_KDES(im) + newimage = FIT_NEWIMAGE(fit) + + # Set the FKINIT defaults; these override the builtin defaults. + fgroup = -1 + igroup = -1 + + FKS_APPEND(fit) = NO_KEYW + if (envgets (ENV_FKINIT, Memc[ks], SZ_LINE) != 0) + call fxf_ksection (Memc[ks], fit, igroup) + + append = FKS_APPEND(fit) + + sv_inherit = FKS_INHERIT(fit) + FKS_INHERIT(fit) = NO_KEYW + FKS_APPEND(fit) = NO_KEYW + + # Parse the kernel section. + call fxf_ksection (ksection, fit, kgroup) + ksinh = FKS_INHERIT(fit) + + # Check for various error conditions. + if (FKS_OVERWRITE(fit) == YES && FKS_APPEND(fit) == YES) + call syserrs (SYS_FXFKSNOVR, "append") + + if (append == NO_KEYW && FKS_APPEND(fit) == NO_KEYW) + FKS_APPEND(fit) = NO + else if (append != NO_KEYW) + FKS_APPEND(fit) = append + + if (append == YES && FKS_OVERWRITE(fit) == YES) + FKS_APPEND(fit) = NO + + if (group != -1) { + if (kgroup != -1 && group != kgroup) + call syserrs (SYS_FXFKSBADGR, IM_NAME(im)) + else if (igroup != -1 && group != igroup) + call syserrs (SYS_FXFKSBADFKIG, IM_NAME(im)) + fgroup = group + } else if (kgroup != -1) { + if (group != -1 && group != kgroup) + call syserrs (SYS_FXFKSBADGR, IM_NAME(im)) + else if (igroup != -1 && group != igroup) + call syserrs (SYS_FXFKSBADFKIG, IM_NAME(im)) + fgroup = kgroup + } else if (igroup != -1) { + if ((group != -1 && group != igroup) || + (kgroup != -1 && kgroup != igroup)) + call syserrs (SYS_FXFKSBADFKIG, IM_NAME(im)) + fgroup = igroup + } + group = fgroup + + # Pre-read the data header. This is done after processing the user + # ksection as we need to get the extname/extver if any. + # EXTNAME or EXTVER has priority when defined over group. + + fks_extn_or_ver = + (FKS_EXTNAME(fit) != EOS || !IS_INDEFL(FKS_EXTVER(fit))) + + tgroup = fgroup + if (fks_extn_or_ver) + tgroup = -1 + + if (newimage == NO && !fnullfile (IM_HDRFILE(im))) { + iferr (call fxf_prhdr (im, tgroup)) { + # If group does not exist and over+, it is an error. + if (FKS_OVERWRITE(fit) == YES) + call syserrs (SYS_FXFEXTNF, IM_NAME(im)) + else + call erract (EA_ERROR) + } + } + + if (fgroup != -1 && tgroup != fgroup && fks_extn_or_ver) + call syserrs (SYS_FXFKSBADEXN, IM_NAME(im)) + + if (fgroup == -1 && fks_extn_or_ver) + group = tgroup + + FIT_EXPAND(fit) = FKS_EXPAND(fit) + + # For overwrite we need to force group to be the kernel section + # extension number. + + if (FKS_OVERWRITE(fit) == YES) + FIT_GROUP(fit) = max(kgroup,group) + else + FIT_GROUP(fit) = group + + if (FKS_APPEND(fit) == YES) + FIT_GROUP(fit) = -1 + + # See if there are some error conditions with the ksection. + call fxf_ks_errors (fit, acmode) + + # Check to see if the user ksection sets the inherit flag. If so + # this overrides all the defaults, including the data header. + + inherit_override = (FKS_INHERIT(fit) != NO_KEYW) + if (!inherit_override) + FKS_INHERIT(fit) = sv_inherit + + # A data header has precedence over the more global fkinit. + # If inherit is disabled in the data header don't enable it here. + + if (!inherit_override && FIT_INHERIT(fit) == NO) + FKS_INHERIT(fit) = NO + + call sfree (sp) +end + + +# FXF_CLEAN_PL -- Filter PLIO keywords from the UA. + +procedure fxf_clean_pl (im) + +pointer im #I image descriptor + +begin + #### (This is incredibly inefficient...) + call fxf_filter_keyw (im, "TFORM1") + call fxf_filter_keyw (im, "TFIELDS") + call fxf_filter_keyw (im, "ZIMAGE") + call fxf_filter_keyw (im, "ZCMPTYPE") + call fxf_filter_keyw (im, "ZBITPIX") + call fxf_filter_keyw (im, "ZNAXIS") + call fxf_filter_keyw (im, "ZNAXIS1") + call fxf_filter_keyw (im, "ZNAXIS2") + call fxf_filter_keyw (im, "ZTILE1") + call fxf_filter_keyw (im, "ZTILE2") + call fxf_filter_keyw (im, "ZNAME1") + call fxf_filter_keyw (im, "ZVAL1") +end diff --git a/sys/imio/iki/fxf/fxfopix.x b/sys/imio/iki/fxf/fxfopix.x new file mode 100644 index 00000000..0401601b --- /dev/null +++ b/sys/imio/iki/fxf/fxfopix.x @@ -0,0 +1,746 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imio.h> +include <mach.h> +include "fxf.h" +include <fset.h> + +define MIN_BUFSIZE 512 + + +# FXF_OPIX -- Open (or create) the pixel storage file. + +procedure fxf_opix (im, status) + +pointer im #I image descriptor +int status #O return status + +pointer sp, fn, fit +char pathname[SZ_PATHNAME] +int compress, blklen, pixoff, filesize +int i, hdr_size, sz_pixfile, sz_fitfile, junk, npix +extern fxfzop(), fxfzrd(), fxfzwr(), fxfzwt(), fxfzst(), fxfzcl() +int strncmp(), fxf_header_size(), fxf_totpix() +int strlen(), fopnbf(), fstatl(), itoc() + +include <szpixtype.inc> + +define err_ 91 +define endowr_ 92 + +begin + call smark (sp) + call salloc (fn, SZ_PATHNAME, TY_CHAR) + + status = OK + fit = IM_KDES(im) + + compress = YES + blklen = 1 + pixoff = 1 + + # Tell IMIO where the pixels are. Append the 'fit' mem descriptor + # to filename so that low level zfiofit routines can use it. + + call strcpy (IM_HDRFILE(im), Memc[fn], SZ_PATHNAME) + call strcat ("_", Memc[fn], SZ_PATHNAME) + i = strlen (Memc[fn]) + junk = itoc (fit, Memc[fn+i], SZ_PATHNAME) + iferr (call fpathname (Memc[fn], pathname, SZ_PATHNAME)) + goto err_ + + if (FKS_OVERWRITE(fit) == YES) { + call fxf_overwrite_unit (fit, im) + goto endowr_ + } + + switch (IM_ACMODE(im)) { + case READ_ONLY, READ_WRITE, WRITE_ONLY: + # Turn on IEEE mapping on input only. + call ieegnanr (FIT_SVNANR(fit)) + call ieegmapr (FIT_SVMAPRIN(fit), FIT_SVMAPROUT(fit)) + call ieegnand (FIT_SVNAND(fit)) + call ieegmapd (FIT_SVMAPDIN(fit), FIT_SVMAPDOUT(fit)) + call ieesnanr (0.0) + call ieemapr (YES, NO) + call ieesnand (0.0D0) + call ieemapd (YES, NO) + + # If the FIT datatype is BYTE or SHORT with scaling then + # convert to TY_SHORT and TY_REAL respectively before + # releasing the data to the upper level calls. This is + # because IMIO does not support BYTE datatype and the need + # to scale 16 bits to 32 bits. + + # Do not open pixel portion if it is empty or is not + # an IMAGE type. + + if ((strncmp (FIT_EXTTYPE(fit), "IMAGE", 5) != 0 && + strncmp (FIT_EXTTYPE(fit), "SIMPLE", 6) != 0) || + IM_NDIM(im) <= 0) { + + goto err_ + } + + FIT_IM(fit) = im + iferr (IM_PFD(im) = fopnbf (pathname, IM_ACMODE(im), + fxfzop, fxfzrd, fxfzwr, fxfzwt, fxfzst, fxfzcl)) { + IM_PFD(im) = NULL + goto err_ + } + + FIT_TOTPIX(fit) = fxf_totpix(im) + filesize = fstatl (IM_PFD(im), F_FILESIZE) + FIT_PFD(fit) = IM_PFD(im) + + case NEW_COPY, NEW_IMAGE, APPEND: + # See if the application has set the number of dimensions. + call fxf_chk_ndim (im) + FIT_PIXTYPE(fit) = IM_PIXTYPE(im) + npix = fxf_totpix (im) + FIT_NAXIS(fit) = IM_NDIM(im) + call amovi (IM_LEN(im,1), FIT_LENAXIS(fit,1), IM_NDIM(im)) + + call fxf_discard_keyw (im) + FIT_TOTPIX(fit) = npix + + # Do not allow BSCALE and BZERO in the UA when making a new copy or + # new image if bitpix is negative. Except for ushort + + if (IM_PIXTYPE(im) != TY_USHORT) { + call fxf_filter_keyw (im, "BSCALE") + call fxf_filter_keyw (im, "BZERO") + } + + # Hdr_size is in char units. (i.e. 1440 chars per FITS block). + hdr_size = fxf_header_size (im) + + # Reset the scaling parameter because in NEW_COPY mode there + # should not be scaled pixels. The previous call will get these + # values from the input image. + + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + + sz_pixfile = npix * pix_size[IM_PIXTYPE(im)] + + # The pixel file needs to be a multiple of 1440 chars. + sz_pixfile = FITS_LEN_CHAR (sz_pixfile) + sz_fitfile = sz_pixfile + hdr_size + + if (FIT_NEWIMAGE(fit) == YES) + call falloc (IM_PIXFILE(im), sz_fitfile) + + FIT_IM(fit) = im + + iferr (IM_PFD(im) = fopnbf (pathname, READ_WRITE, + fxfzop, fxfzrd, fxfzwr, fxfzwt, fxfzst, fxfzcl)) { + IM_PFD(im) = NULL + call erract (EA_FATAL) + goto err_ + } + + FIT_PFD(fit) = IM_PFD(im) + filesize = fstatl (IM_PFD(im), F_FILESIZE) + FIT_EOFSIZE(fit) = filesize + 1 + + if (FIT_NEWIMAGE(fit) == NO) { + # Now we are appending a new IMAGE extension. + # Write a blank header in order to append the + # pixels after it. + + pixoff = filesize + hdr_size + 1 + + # Update the offset for the blank write to follow which uses + # a local file driver tied to the IM_PFD descriptor and not + # the normal FIO. + FIT_PIXOFF(fit) = pixoff + + # Update filesize + filesize = filesize + sz_fitfile + call fxf_write_blanks (IM_PFD(im), hdr_size) + } else + pixoff = hdr_size + 1 + + FIT_PIXOFF(fit) = pixoff + call imioff (im, pixoff, compress, blklen) + + IM_HFD(im) = NULL + + default: + call imerr (IM_NAME(im), SYS_IMACMODE) + } + +endowr_ + FIT_PFD(fit) = IM_PFD(im) + FIT_HFD(fit) = IM_HFD(im) + + # The following statement is to pass the datatype at the low + # level fits read and write routines. The datatype value can + # change after the image is open. Hopefully the value of 'im' + # will remain static. + + FIT_IM(fit) = im + status = OK + + call sfree (sp) + return +err_ + status = ERR + call sfree (sp) +end + + +# FXF_HEADER_SIZE -- Function to calculate the header size that would go +# into the output file extension. + +int procedure fxf_header_size (im) + +pointer im #I Image descriptor + +bool inherit +int merge, hdr_size +pointer op, fit, sp, tb, pb +int nheader_cards, ualen, ulines, clines +int strlen() + +begin + fit = IM_KDES(im) + inherit = false + + # Fks_inherit is a combined value. + if (FKS_INHERIT(fit) == YES) + inherit = true + + call fxf_mandatory_cards (im, nheader_cards) + + if (FIT_NEWIMAGE(fit) == NO && inherit) { + # See if current UA keywords are in the global header, if not + # there put it in a spool file. At the end, the spool file size is + # the output extension header size to be use in fitupdhdr. + + # Check if the file is still in cache. We need CACHELEN and + # CACHEHDR. + + call fxf_not_incache (im) + + op = IM_USERAREA(im) + ualen = strlen (Memc[op]) + ulines = ualen / LEN_UACARD + clines = FIT_CACHEHLEN(fit) / LEN_UACARD + + call smark (sp) + call salloc (tb, ualen+1, TY_CHAR) + + merge = NO + pb = tb + + # Now select those lines from the UA (pointed by op) that are + # not in the cache and accumulate them in 'pb'. + + call fxf_match_str (op, ulines, FIT_CACHEHDR(fit), clines,merge,pb) + Memc[pb+1] = EOS + ualen = strlen (Memc[tb]) + + call sfree (sp) + + } else { + op = IM_USERAREA(im) + ualen = strlen (Memc[op]) + } + + ulines = ualen / LEN_UACARD + nheader_cards + FKS_PADLINES(fit) + + ##### Note: PHULINES is not currently used, should be implemented + ##### Not clear to me if this code here is used for the PHU since + ##### it is in opix! + + # See if the application has set a minumum number of card for the UA. + + ulines = max (ulines, FKS_EHULINES(fit)) + + # The user area contains new_lines (81 chars, LEN_UACARD). Scale to + # 80 chars (LEN_CARD). Ualen is in bytes. + + ualen = ulines * LEN_CARD + + # Calculate the number of header FITS blocks in chars. + hdr_size = FITS_LEN_CHAR (ualen / 2) + + return (hdr_size) +end + + +# FXF_BYTE_SHORT -- This routine is obsolete and has been deleted, but is +# being preserved for the V2.11.2 patch so that a new shared library version +# does not have to be created. It can be deleted in the next major release. + +procedure fxf_byte_short (im, fname) + +pointer im +char fname[ARB] + +begin +end + + +# FXF_WRITE_BLANKS --Procedure to append a blank header to an existing +# file, preparing to write data after it. + +procedure fxf_write_blanks (fd, size) + +int fd #I File descriptor +int size #I New size (chars) to allocate. + +pointer sp, bf +int nblocks,i, fits_lenc + +begin + call smark (sp) + + # Length of a FITS block (2880) in chars. + fits_lenc = FITS_BLOCK_BYTES/SZB_CHAR + call salloc (bf, fits_lenc, TY_INT) + call amovki (0, Memi[bf], fits_lenc) + + size = FITS_LEN_CHAR(size) + nblocks = size / fits_lenc + + call seek (fd, EOF) + do i = 1, nblocks + call write (fd, Memi[bf], fits_lenc) + + call sfree (sp) +end + + +# FXF_MANDATORY_CARDS -- Count the required FITS header cards. +# The cards for the Main Unit are: SIMPLE, BITPIX, NAXIS, +# EXTEND, ORIGIN, DATE, IRAF_TLM, OBJECT and END; +# 'IM_NDIM(im)', DATAMIN and DATAMAX will be put out +# only if the LIMTIME > MTIME. +# would take care of NAXISi. For an Extension unit, the cards are: +# XTENSION, BITPIX, NAXIS, PCOUNT, GCOUNT, ORIGIN, DATE, INHERIT, +# EXTNAME, IRAF_TLM, OBJECT and END; IM_NDIM(im) takes care of +# NAXISi. Same as above for DATAMIN, DATAMAX. +# If these cards are in the main header, reduce the number of +# mandatory cards that are going to be created at closing time +# (in fitupdhdr). + +procedure fxf_mandatory_cards (im, nheader_cards) + +pointer im #I im structure +int nheader_cards #O Number of mandatory cards in header. + +pointer ua +int ncards, rp, fit, acmode +int idb_findrecord() + +begin + ua = IM_USERAREA(im) + fit = IM_KDES(im) + + if (FIT_NEWIMAGE(fit) == YES) # create a PHU + ncards = 9 + IM_NDIM(im) + else # create an EHU + ncards = 12 + IM_NDIM(im) + + if (idb_findrecord (im, "PCOUNT", rp) > 0) { + if (FIT_XTENSION(fit) == YES) + ncards = ncards - 1 + else + call fxf_filter_keyw (im, "PCOUNT") + } + if (idb_findrecord (im, "GCOUNT", rp) > 0) { + if (FIT_XTENSION(fit) == YES) + ncards = ncards - 1 + else + call fxf_filter_keyw (im, "GCOUNT") + } + if (idb_findrecord (im, "EXTNAME", rp) > 0) { + if (FIT_XTENSION(fit) == YES) + ncards = ncards - 1 + else + call fxf_filter_keyw (im, "EXTNAME") + } + if (idb_findrecord (im, "INHERIT", rp) > 0) { + if (FIT_XTENSION(fit) == YES) + ncards = ncards - 1 + else + call fxf_filter_keyw (im, "INHERIT") + } + if (idb_findrecord (im, "EXTEND", rp) > 0) { + if (FIT_XTENSION(fit) == NO) { + ncards = ncards - 1 + } else { + # Delete the keyword from the UA because EXTEND is not + # recommended in XTENSION units. + + call fxf_filter_keyw (im, "EXTEND") + } + } + + if (idb_findrecord (im, "ORIGIN", rp) > 0) + ncards = ncards - 1 + if (idb_findrecord (im, "DATE", rp) > 0 ) + ncards = ncards - 1 + if (idb_findrecord (im, "IRAF-TLM", rp) > 0) + ncards = ncards - 1 + if (idb_findrecord (im, "OBJECT", rp) > 0) + ncards = ncards - 1 + + # See if we need to add one more mandatory card when an EXTVER value + # was specified when appending a new extension. + + if (FIT_NEWIMAGE(fit) == NO && idb_findrecord(im,"EXTVER",rp) == 0) { + # Keyword does not exist. + acmode = IM_ACMODE(im) + if ((acmode == NEW_IMAGE || acmode == NEW_COPY) && + FKS_EXTVER(fit) != INDEFL ) + ncards = ncards + 1 + } + + # We want to keep BSCALE and BZERO in the UA in case we are + # editing the values. Is up to the user or application + # responsability to deal with the change in pixel value when reading. + # If we are reading pixels the values will change according to the + # input BSCALE and BZERO. If we are adding BSCALE and BZERO before + # accessing any pixels, these will get scale. If adding or + # changing right before closing the image, the pixel value will be + # unchanged. + + # See if BSCALE and BZERO are in the UA for ushort, otherwise + # increase the number. + + if (IM_PIXTYPE(im) == TY_USHORT) { + if (idb_findrecord (im, "BSCALE", rp) == 0) + ncards = ncards + 1 + if (idb_findrecord (im, "BZERO", rp) == 0) + ncards = ncards + 1 + } + nheader_cards = ncards +end + + +# FXF_OVERWRITE_UNIT -- Overwrite an existent extension. A temporary file +# is created that contains the current file upto the extension before the +# one to be overwrite. + +procedure fxf_overwrite_unit (fit, im) + +pointer fit #I Fits descriptor +pointer im #I Image descriptor + +pointer sp, file, mii +int pixoff, compress, blklen, sz_fitfile, i, group, filesize +int junk, in_fd, out_fd, nblocks, nk, hdr_size, sz_pixfile +extern fxfzop(), fxfzrd(), fxfzwr(), fxfzwt(), fxfzst(), fxfzcl() +int fnroot(), open(), read(), fxf_totpix(), strncmp(), itoc() +int strlen(), fopnbf(), fstatl(), fxf_header_size() + +include <szpixtype.inc> + +errchk syserr, syserrs +define err_ 91 + +begin + group = FIT_GROUP(fit) + + # Do not overwrite extensions that are not IMAGE. + if (group != 0 && strncmp (FIT_EXTTYPE(fit), "IMAGE", 5) != 0 && + strncmp (FIT_EXTTYPE(fit), "SIMPLE", 6) != 0) { + + call syserr (SYS_FXFOVRBEXTN) + return + } + + call smark (sp) + call salloc (file, SZ_FNAME, TY_CHAR) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + + junk = fnroot (IM_HDRFILE(im), Memc[file], SZ_FNAME) + + # Keep the temporary filename in IM_PIXFILE(im). + call mktemp (Memc[file], IM_PIXFILE(im), SZ_PATHNAME) + call strcat (".fits", IM_PIXFILE(im), SZ_PATHNAME) + + # If we want to overwrite the first group there is nothing + # to copy first. + + if (group != 0) { + # Copy from the old file up to hdr_off[group] into a temporary file. + in_fd = open (IM_HDRFILE(im), READ_ONLY, BINARY_FILE) + out_fd = open (IM_PIXFILE(im), NEW_FILE, BINARY_FILE) + nblocks = Memi[FIT_HDRPTR(fit)+group]/ FITS_BLOCK_CHARS + do nk = 1, nblocks { + junk = read (in_fd, Memi[mii], FITS_BLOCK_CHARS) + call write (out_fd, Memi[mii], FITS_BLOCK_CHARS) + } + call close (in_fd) + call close (out_fd) + } + + FIT_NAXIS(fit) = IM_NDIM(im) + call amovi (IM_LEN(im,1), FIT_LENAXIS(fit,1), IM_NDIM(im)) + + FIT_TOTPIX(fit) = fxf_totpix(im) + + # Do not allow BSCALE and BZERO in the UA when making a new copy or + # new image if bitpix is negative. Except for ushort. + + if (IM_PIXTYPE(im) != TY_USHORT) { + call fxf_filter_keyw (im, "BSCALE") + call fxf_filter_keyw (im, "BZERO") + } + + # The new copy header should not have the following keywords: + # GROUPS, PSIZE and that could come from a GEIS file. + + call fxf_discard_keyw (im) + hdr_size = fxf_header_size (im) + + # Reset the scaling parameter because in NEW_COPY mode there + # should not be scaled pixels. The previous call will get these + # values from the input image. + + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + + call fpathname (IM_PIXFILE(im), Memc[file], SZ_PATHNAME) + call strcat("_", Memc[file], SZ_PATHNAME) + i = strlen(Memc[file]) + junk = itoc (fit, Memc[file+i], SZ_PATHNAME) + + # The pixel file needs to be a multiple of 1440 chars. + sz_pixfile = fxf_totpix(im) * pix_size[IM_PIXTYPE(im)] + sz_pixfile = FITS_LEN_CHAR(sz_pixfile) + sz_fitfile = sz_pixfile + hdr_size + + if (group == 0) + call falloc (IM_PIXFILE(im), sz_fitfile) + + FIT_IM(fit) = im + iferr (IM_PFD(im) = fopnbf (Memc[file], READ_WRITE, + fxfzop, fxfzrd, fxfzwr, fxfzwt, fxfzst, fxfzcl)) { + + IM_PFD(im) = NULL + goto err_ + } + + filesize = fstatl (IM_PFD(im), F_FILESIZE) + FIT_EOFSIZE(fit) = filesize + 1 + # Now write a blank header. + if (group != 0) { + call amovki (0, Memi[mii], FITS_BLOCK_CHARS) + nblocks = hdr_size/FITS_BLOCK_CHARS + FIT_HFD(fit) = -1 + + call seek (IM_PFD(im), EOF) + do nk = 1, nblocks + call write (IM_PFD(im), Memi[mii], FITS_BLOCK_CHARS) + + pixoff = filesize + hdr_size + 1 + filesize = filesize + sz_fitfile + } else + pixoff = hdr_size + 1 + + + FIT_PIXOFF(fit) = pixoff + IM_HFD(im) = NULL + + blklen = 1 + compress = YES + call imioff (im, pixoff, compress, blklen) + + FIT_PFD(fit) = IM_PFD(im) + FIT_HFD(fit) = IM_HFD(im) + + call sfree (sp) + return +err_ + call syserr (SYS_FXFOVRTOPN) + call sfree (sp) +end + + +# TOTPIX -- Calculate the total number of pixels in the image. + +int procedure fxf_totpix (im) + +pointer im #I image descriptor +int i, pix, ndim + +begin + ndim = IM_NDIM(im) + if (ndim == 0) + return (0) + + pix = IM_LEN(im,1) + do i = 2, ndim + pix = pix * IM_LEN(im,i) + + return (pix) +end + + +# FXF_DISCARD_FITS_KEYW -- Exclude certain keywords from a new copy image. + +procedure fxf_discard_keyw (im) + +pointer im #I image descriptor +pointer fit + +begin + fit = IM_KDES(im) + + call fxf_filter_keyw (im, "GROUPS") + call fxf_filter_keyw (im, "PSIZE") + call fxf_filter_keyw (im, "BLOCKED") + call fxf_filter_keyw (im, "IRAFNAME") + call fxf_filter_keyw (im, "IRAF-BPX") + call fxf_filter_keyw (im, "IRAFTYPE") + + if (FIT_NEWIMAGE(fit) == NO) + call fxf_filter_keyw (im, "EXTEND") + + # Create a PHU. + if (FIT_NEWIMAGE(fit) == YES) { + call fxf_filter_keyw (im, "PCOUNT") + call fxf_filter_keyw (im, "GCOUNT") + call fxf_filter_keyw (im, "INHERIT") + call fxf_filter_keyw (im, "EXTNAME") + call fxf_filter_keyw (im, "EXTVER") + call fxf_filter_keyw (im, "EXTLEVEL") + } +end + + +# FXF_FILTER_KEYW -- Delete the names keyword from the userarea. + +procedure fxf_filter_keyw (im, key) + +pointer im #I image descriptor +char key[ARB] #I keyword name to delete from USERAREA. + +pointer rp +int off +int idb_findrecord(), stridxs() + +begin + # Verify that the named user field exists. + if (idb_findrecord (im, key, rp) <= 0) + return + + # Delete the field. + off = stridxs ("\n", Memc[rp]) + if (off > 0) + call strcpy (Memc[rp+off], Memc[rp], ARB) + else + Memc[rp] = EOS +end + + +# FXF_FALLOC -- Preallocate space on disk by writing blanks. + +procedure fxf_falloc (fname, size) + +char fname[ARB] #I filename +int size #I size to preallocate in chars + +pointer sp, cp +int nb,i, fd +errchk open, write +int open() + +begin + call smark (sp) + call salloc (cp, FITS_BLOCK_CHARS, TY_CHAR) + + call amovkc (' ', Memc[cp], FITS_BLOCK_CHARS) + nb = size / FITS_BLOCK_CHARS + fd = open (fname, NEW_FILE, BINARY_FILE) + + do i = 1, nb + call write (fd, Memc[cp], FITS_BLOCK_CHARS) + + call flush (fd) + call close (fd) + call sfree (sp) +end + + +# FXF_CKH_NDIM -- Check that the application has indeed set the number +# of dimension, otherwise count the axes. + +procedure fxf_chk_ndim (im) + +pointer im #I imio descriptor +int ndim #I number of dimension for image + +begin + ndim = IM_NDIM(im) + + # If ndim was not explicitly set, compute it by counting the number + # of nonzero dimensions. + + if (ndim == 0) { + for (ndim=1; IM_LEN(im,ndim) > 0 && ndim <= IM_MAXDIM; ndim=ndim+1) + ; + ndim = ndim - 1 + IM_NDIM(im) = ndim + } +end + + +# FXF_NOT_INCACHE -- Procedure to find whether the file is in the +# cache. It could happen that the slot with the entry might have been +# freed to make room for another file. We want to have valid pointers +# for FIT_CACHEHDR and FIT_CACHELEN since the calling routine will use them. + +procedure fxf_not_incache (im) + +pointer im #I image descriptor + +int cindx, group, sfit[4] +pointer sp, hdrfile, fit +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + fit = IM_KDES(im) + + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + call sfree (sp) + return + } + } + sfit[1]= FIT_NAXIS(fit) + sfit[2] = FIT_INHERIT(fit) + sfit[3] = FIT_PLMAXLEN(fit) + sfit[4] = IM_CTIME(im) + + group = max (0, FIT_GROUP(fit)) + + call fxf_prhdr(im,group) + + FIT_NAXIS(fit) = sfit[1] + FIT_INHERIT(fit) = sfit[2] + FIT_PLMAXLEN(fit) = sfit[3] + IM_CTIME(im) = sfit[4] + + call sfree (sp) + return +end + diff --git a/sys/imio/iki/fxf/fxfpak.x b/sys/imio/iki/fxf/fxfpak.x new file mode 100644 index 00000000..01db148d --- /dev/null +++ b/sys/imio/iki/fxf/fxfpak.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <mach.h> +include "fxf.h" + + +# FXF_PAK_DATA -- Convert npix elements of type pixtype as needed for storage +# in a FITS file. All floating point data will be converted to IEEE format. +# The input and output buffers may be the same if desired. + +procedure fxf_pak_data (ibuf, obuf, npix, pixtype) + +char ibuf[ARB] #I input data buffer +char obuf[ARB] #I output data buffer +int npix #I number of pixels in buffer +int pixtype #I input pixel datatype + +int nbytes, nchars +errchk syserr + +include <szpixtype.inc> + +begin + ### Possibly the MII conversion routines should be used here as + ### they handle all these datatypes (except maybe ushort). + + nchars = npix * pix_size[pixtype] + nbytes = nchars * SZB_CHAR + + switch (pixtype) { + case TY_USHORT: + call fxf_altmu (ibuf, obuf, npix) + if (BYTE_SWAP2 == YES) + call bswap2 (obuf, 1, obuf, 1, nbytes) + + case TY_SHORT: + if (BYTE_SWAP2 == YES) + call bswap2 (ibuf, 1, obuf, 1, nbytes) + else + call amovc (ibuf, obuf, nchars) + + case TY_INT, TY_LONG: + if (BYTE_SWAP4 == YES) + call bswap4 (ibuf, 1, obuf, 1, nbytes) + else + call amovc (ibuf, obuf, nchars) + + case TY_REAL: + call ieevpakr (ibuf, obuf, npix) + + case TY_DOUBLE: + call ieevpakd (ibuf, obuf, npix) + + default: + call syserr (SYS_FXFPKDTYP) + } +end diff --git a/sys/imio/iki/fxf/fxfplread.x b/sys/imio/iki/fxf/fxfplread.x new file mode 100644 index 00000000..4d4c3e83 --- /dev/null +++ b/sys/imio/iki/fxf/fxfplread.x @@ -0,0 +1,160 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <plset.h> +include <imhdr.h> +include <imio.h> +include <mach.h> +include "fxf.h" + + +# FXF_PLREAD -- Read a PLIO mask stored in a FITS binary table extension +# and load it into an image descriptor. +# +# There is a builtin assumption in this code (also in fxf_plwrite) that +# masks will not be more than 3-dimensional. This could be generalized +# if necessary, but we have never seen a mask of dimensionality higher +# than 3. The dimensionality, size, and depth of the mask is preserved. + +procedure fxf_plread (im) + +pointer im #I image descriptor + +char kwname[SZ_KEYWORD] +pointer sp, fk, pl, lp, ip, ix +long data_offset, data_len, heap_offset, llen, loff +int naxes, axlen[IM_MAXDIM], depth, maxlen +int fd, i, j, nelem, nlines, v[PL_MAXDIM], maxoff, nbytes + +long note() +bool streq() +int imgeti(), pl_create(), miireadi(), miireads() +errchk imgeti, pl_create, miireadi, miireads, seek, pl_update, syserrs + +begin + call smark (sp) + + fk = IM_KDES(im) + fd = IM_HFD(im) + + # The maximum encoded line list length is (normally) passed in via + # the binary table format keywords, and stored in FIT_PLMAXLEN. + + maxlen = FIT_PLMAXLEN(fk) + if (maxlen <= 0) + maxlen = DEF_PLMAXLEN + + # Scratch buffer for encoded line lists. + call salloc (lp, maxlen, TY_SHORT) + + # Get the dimensionality and size of the stored mask. + call amovki (1, axlen, IM_MAXDIM) + naxes = imgeti (im, "ZNAXIS") + call fxf_filter_keyw (im, "ZNAXIS") + do i = 1, naxes { + call sprintf (kwname, LEN_CARD, "ZNAXIS%d") + call pargi(i) + axlen[i] = imgeti (im, kwname) + call fxf_filter_keyw (im, kwname) + call sprintf (kwname, LEN_CARD, "ZTILE%d") + call pargi(i) + call fxf_filter_keyw (im, kwname) + } + + # Get the mask depth, passed as compression algorithm parameter + # number 1 for a PLIO-compressed image. + + depth = DEF_PLDEPTH + ifnoerr (call imgstr (im, "ZNAME1", kwname, SZ_KEYWORD)) { + if (streq (kwname, "depth")) + iferr (depth = imgeti (im, "ZVAL1")) + depth = DEF_PLDEPTH + call fxf_filter_keyw (im, "ZNAME1") + call fxf_filter_keyw (im, "ZVAL1") + call fxf_filter_keyw (im, "ZBITPIX") + call fxf_filter_keyw (im, "ZIMAGE") + } + + # Create an initially empty mask of the given size. + pl = pl_create (naxes, axlen, depth) + + # Create a buffer for the line list index (maxdim 3 assumed). + nlines = axlen[3] * axlen[2] + call salloc (ix, nlines * 2, TY_INT) + + # Compute the file offsets of the table data and heap areas. The + # file position is assumed to be already positioned at the start + # of the data area of the file. + + data_offset = note (fd) + data_len = FIT_LENAXIS(fk,3) * FIT_LENAXIS(fk,2) * FIT_LENAXIS(fk,1) + heap_offset = data_offset + data_len/SZB_CHAR + + # Read the line list index from the input file. The index contains + # one entry for every line in the (possibly multidimensional) image. + # Each entry consists of two integer values, the length of the + # stored line list, and the heap offset (in bytes) of the stored list. + + nelem = miireadi (fd, Memi[ix], nlines * 2) + if (nelem != nlines * 2) + call syserrs (SYS_FXFRMASK, IM_NAME(im)) + + # Find out the maximum offset value to determine if they were + # written using the 2 byte units rather than the standard (byte unit) + + maxoff = 0 + ip = ix + do j = 1, axlen[3] { + do i = 1, axlen[2] { + maxoff = max (maxoff, Memi[ip+1]+2*Memi[ip]) + ip = ip + 2 + } + } + + if (maxoff < (FIT_PCOUNT(fk) - maxoff/2)) { + nbytes = 1 + } else { + nbytes = 2 + } + + # Read the line list data and insert it into the PLIO mask. + # pl_update will be called for each line of the mask even if multiple + # lines point to the same line list data, but pl_update will sort + # all this out and restore the multiple references as the mask is + # built. + + ip = ix + v[1] = 1 + + do j = 1, axlen[3] { + v[3] = j + do i = 1, axlen[2] { + v[2] = i + + llen = Memi[ip] + + # This offset on the table data is in byte units, convert + # to short. + + loff = Memi[ip+1] / nbytes + + call seek (fd, heap_offset + loff) + nelem = miireads (fd, Mems[lp], llen) + if (nelem != llen) + call syserrs (SYS_FXFRMASK, IM_NAME(im)) + + call pl_update (pl, v, Mems[lp]) + + ip = ip + 2 + } + } + + # Set up IMIO descriptor. + call amovl (axlen, IM_LEN(im,1), IM_MAXDIM) + call amovl (axlen, IM_PHYSLEN(im,1), IM_MAXDIM) + IM_NDIM(im) = naxes + IM_PIXTYPE(im) = TY_INT + IM_PL(im) = pl + + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfplwrite.x b/sys/imio/iki/fxf/fxfplwrite.x new file mode 100644 index 00000000..65909dcb --- /dev/null +++ b/sys/imio/iki/fxf/fxfplwrite.x @@ -0,0 +1,418 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <mach.h> +include <imio.h> +include <imhdr.h> +include <mii.h> +include <plset.h> +include <pmset.h> +include "fxf.h" + + +# FXFPLWRITE.X -- Routines to handle masks in FITS extensions. +# +# fxf_plwrite (im, fd) +# fxf_plinfo (im, maxlen, pcount, depth) +# fxf_pl_adj_heap (im, hdr_fd, pcount) +# fxf_copy_adj (im, in_fd, hdroff, poff, datasize) +# fxf_plpf (im) +# + + +# FXF_PLWRITE -- Write the data from a PLIO mask into the data area of a +# FITS compressed image (ZIMAGE) binary table extension. The data is +# written to the file pointed to by file descriptor FD. +# +# The data to be written consists of the data for the ZIMAGE binary table +# records, followed by the heap area of the BINTABLE extension, which +# contains the actual encoded line lists. For simplicity we assume that +# the table contains only one column, the COMPRESSED_DATA column, which is +# of type variable length integer array. Each element of this column is a +# BINTABLE variable length array descriptor which physically consists of two +# integer values: an integer giving the length of the stored array (encoded +# line list), followed by an integer (in byte unit) giving the offset of +# the array data (encoded line list) in the heap area. Multiple variable +# length array descriptors may point to the same stored array, and in +# fact PLIO uses this feature to implement compression in the Y direction +# (adjacent mask lines will point to the same encoded line list). +# The code here supports masks of up to 3 dimensions. + +procedure fxf_plwrite (im, fd) + +pointer im #I image descriptor +int fd #I output file descriptor + +int i, j, v_in[PL_MAXDIM], lp_len +int naxes, axlen[PL_MAXDIM], depth +int heap_offset, ep_off, lp_off, vararray[2] +pointer pl, lp, op, emptyline, lastline + +int pl_llen() +pointer pl_access(), pl_emptyline() +errchk pl_access + +begin + pl = IM_PL(im) + call pl_gsize (pl, naxes, axlen, depth) + + # Write the COMPRESSED_DATA table column. This is an index giving + # the length and heap offset of the encoded PLIO line list for each + # line of the image. Multiple image lines (index entries) may point + # to the same stored line list: this happens if a mask line is empty + # (the empty line) or if successive lines are all the same. For the + # sake of simplicity, only masks of up to 3 dimensions are supported. + + op = 0 + heap_offset = 0 + emptyline = pl_emptyline (pl) + ep_off = -1 + lastline = NULL + lp_off = -1 + call amovkl(long(1), v_in, PL_MAXDIM) + + do j = 1, axlen[3] { + v_in[3] = j + do i = 1, axlen[2] { + v_in[2] = i + lp = pl_access (pl, v_in) + lp_len = pl_llen (Mems[lp]) + + if (lp == emptyline && ep_off >= 0) + op = ep_off + else if (lp == lastline) + op = lp_off + else + op = heap_offset + + vararray[1] = lp_len + + # The offsets on the FITS BINTABLE is in byte unit + # as establish by the FITS standard. + + vararray[2] = op * 2 # Byte offset + + call miiwritei (fd, vararray, 2) + + lastline = lp + lp_off = op + if (lp == emptyline && ep_off < 0) + ep_off = op + + if (op == heap_offset) + heap_offset = heap_offset + lp_len + } + } + # Now write the line list data to the heap area. The logic here must + # follow that above or the line offsets won't match. + + ep_off = -1 + lp_off = -1 + lastline = NULL + + do j = 1, axlen[3] { + v_in[3] = j + do i = 1, axlen[2] { + v_in[2] = i + lp = pl_access (pl, v_in) + lp_len = pl_llen (Mems[lp]) + + if (lp == emptyline && ep_off >= 0) + next + else if (lp == lastline) + next + + call miiwrites (fd, Mems[lp], lp_len) + + lastline = lp + if (lp == emptyline && ep_off < 0) + ep_off = 0 + } + } +end + + +# FXF_PLINFO -- Examine a PLIO mask and compute the maximum length of an +# encoded line list, and the storage in bytes required to store the mask +# data in the heap area of a FITS binary table. + +procedure fxf_plinfo (im, maxlen, pcount, depth) + +pointer im #I image descriptor +int maxlen #O maximum line list length +int pcount #O storage required to store mask (bytes) +int depth #O mask depth + +int naxes, axlen[PL_MAXDIM] +int i, j, v_in[PL_MAXDIM], lp_len +int heap_offset, ep_off, lp_off +pointer pl, lp, op, emptyline, lastline + +int pl_llen() +pointer pl_access(), pl_emptyline() +errchk pl_access + +begin + pl = IM_PL(im) + call pl_gsize (pl, naxes, axlen, depth) + + op = 0 + maxlen = 0 + heap_offset = 0 + emptyline = pl_emptyline (pl) + ep_off = -1 + lastline = NULL + lp_off = -1 + call amovkl(long(1), v_in, PL_MAXDIM) + + # The following must duplicate the logic above for determining what + # gets written to the heap area. All we are doing here is computing + # the amount of heap storage required to store the compressed mask. + + do j = 1, axlen[3] { + v_in[3] = j + do i = 1, axlen[2] { + v_in[2] = i + lp = pl_access (pl, v_in) + lp_len = pl_llen (Mems[lp]) + maxlen = max (maxlen, lp_len) + + if (lp == emptyline && ep_off >= 0) + op = ep_off + else if (lp == lastline) + op = lp_off + else + op = heap_offset + + lastline = lp + lp_off = op + if (lp == emptyline && ep_off < 0) + ep_off = op + + if (op == heap_offset) + heap_offset = heap_offset + lp_len + } + } + + pcount = heap_offset * (SZ_SHORT * SZB_CHAR) +end + + +# FXF_PL_ADJ_HEAP -- Resize heap when we have a hole bigger than 2880 bytes +# or if we overwrite the next extension. + +procedure fxf_pl_adj_heap (im, hdr_fd, pcount) + +pointer im #I imio descriptor +int hdr_fd #U file descriptor +int pcount #I new heap size in bytes + +pointer fk, hdrp, pixp +int datasize, hdroff, diff, nb, group, i + +begin + fk = IM_KDES(im) + + # Calculate the size of the TABLE data. (8 bytes per line) + datasize = FIT_LENAXIS(fk,1)*FIT_LENAXIS(fk,2)* + FIT_LENAXIS(fk,3) + datasize = (datasize + pcount)/SZB_CHAR + + call fxf_not_incache(im) + hdrp = FIT_HDRPTR(fk) + pixp = FIT_PIXPTR(fk) + group = FIT_GROUP(fk) + + hdroff = Memi[hdrp+group] + + # Calculate the amount of space left or grown in the heap + # as a result of the READ-WRITE operation on the data. + + diff = datasize - (Memi[hdrp+group+1] - Memi[pixp+group]) + + # See if the new data overwrites the next unit or + # there is a hole with more than 2880 bytes. + + if ( (diff > 0) || ((-diff / 2880) > 0) ) { + + # Adjust the header and pixel offset for subsequent groups. + # Add header size. + datasize = datasize + Memi[pixp+group] - Memi[hdrp+group] + call fxf_copy_adj (im, hdr_fd, hdroff, Memi[hdrp+group+1], datasize) + + if (diff > 0) + nb = FITS_LEN_CHAR (diff) + else + nb = (diff / 1440) * 1440 + + # Update FK cache offset values + do i = group+1, FIT_NUMOFFS(fk) { + Memi[hdrp+i] = Memi[hdrp+i] + nb + if (Memi[pixp+i] > 0) { + Memi[pixp+i] = Memi[pixp+i] + nb + } else + break + } + } +end + + +# FXF_COPY_ADJ -- Make a copy of the input file extending or shrinking +# the heap area. + +procedure fxf_copy_adj (im, in_fd, hdroff, poff, datasize) + +pointer im #I Imio descriptor +int in_fd #I Input file descriptor +int hdroff #I Header offset +int poff #I Pixel offset +int datasize #I New FITS unit size + +pointer sp, tempfile, outname +int nchars, junk, inoff, out_fd, size +int fnldir(), fnroot(), open(), note() +errchk open, note, seek, close, delete, rename +errchk fxf_make_adj_copy, fxf_write_blanks + +begin + call smark (sp) + call salloc (tempfile, SZ_FNAME, TY_CHAR) + call salloc (outname, SZ_FNAME, TY_CHAR) + + nchars = fnldir (IM_HDRFILE(im), Memc[tempfile], SZ_FNAME) + junk = fnroot (IM_HDRFILE(im), Memc[tempfile+nchars], SZ_FNAME) + call mktemp (Memc[tempfile], Memc[outname], SZ_PATHNAME) + call strcat (".fits", Memc[outname], SZ_PATHNAME) + + inoff = note (in_fd) + out_fd = open (Memc[outname], NEW_FILE, BINARY_FILE) + + call fxf_make_adj_copy (in_fd, out_fd, hdroff, poff, datasize) + + # Pad to 2880 bytes block + size = note (out_fd) - 1 + size = mod(size, FITS_BLOCK_CHARS) + if (size != 0) { + size = FITS_BLOCK_CHARS - size + call fxf_write_blanks (out_fd, size) + } + + size = note (out_fd) - 1 + call close (in_fd) + call delete (IM_HDRFILE(im)) + call rename (Memc[outname], IM_HDRFILE(im)) + + in_fd = out_fd + call seek (in_fd, inoff) + call sfree (sp) +end + + +# FXF_PLPF -- Initialize IMIO dependencies when dealing with a PLIO +# image mask. + +procedure fxf_plpf (im) + +pointer im #I IMIO descriptor + +int pfd +pointer sp, imname, ref_im +int sv_acmode, sv_update, ndim, i, depth +errchk iki_opix, open +int open() + +begin + call smark (sp) + call salloc (imname, SZ_IMNAME, TY_CHAR) + + # Complete the initialization of a mask image. + ref_im = IM_PLREFIM(im) + + sv_acmode = IM_ACMODE(im) + sv_update = IM_UPDATE(im) + call strcpy (IM_NAME(im), Memc[imname], SZ_IMNAME) + + if (ref_im != NULL) { + # Create a mask the same size as the physical size of the + # reference image. Inherit any image section from the + # reference image. + + IM_NDIM(im) = IM_NDIM(ref_im) + IM_NPHYSDIM(im) = IM_NPHYSDIM(ref_im) + IM_SECTUSED(im) = IM_SECTUSED(ref_im) + call amovl (IM_LEN(ref_im,1), IM_LEN(im,1), IM_MAXDIM) + call amovl (IM_PHYSLEN(ref_im,1),IM_PHYSLEN(im,1),IM_MAXDIM) + call amovl (IM_SVLEN(ref_im,1), IM_SVLEN(im,1), IM_MAXDIM) + call amovl (IM_VMAP(ref_im,1), IM_VMAP(im,1), IM_MAXDIM) + call amovl (IM_VOFF(ref_im,1), IM_VOFF(im,1), IM_MAXDIM) + call amovl (IM_VSTEP(ref_im,1), IM_VSTEP(im,1), IM_MAXDIM) + + # Tell PMIO to use this image as the reference image. + call pm_seti (IM_PL(im), P_REFIM, im) + + } else if (sv_acmode == NEW_IMAGE || sv_acmode == NEW_COPY) { + # If ndim was not explicitly set, compute it by counting + # the number of nonzero dimensions. + + ndim = IM_NDIM(im) + if (ndim == 0) { + ndim = 1 + while (IM_LEN(im,ndim) > 0 && ndim <= IM_MAXDIM) + ndim = ndim + 1 + ndim = ndim - 1 + IM_NDIM(im) = ndim + } + + # Make sure dimension stuff makes sense. + if (ndim < 0 || ndim > IM_MAXDIM) + call imerr (IM_NAME(im), SYS_IMNDIM) + + do i = 1, ndim + if (IM_LEN(im,i) <= 0) + call imerr (IM_NAME(im), SYS_IMDIMLEN) + + # Set the unused higher dimensions to 1. This makes it + # possible to access the image as if it were higher + # dimensional, and in a way it truely is. + + do i = ndim + 1, IM_MAXDIM + IM_LEN(im,i) = 1 + + IM_NPHYSDIM(im) = ndim + call amovl (IM_LEN(im,1), IM_PHYSLEN(im,1), IM_MAXDIM) + call amovl (IM_LEN(im,1), IM_SVLEN(im,1), IM_MAXDIM) + if (sv_acmode == NEW_IMAGE) + call amovkl (long(1), IM_VSTEP(im,1), IM_MAXDIM) + + depth = PL_MAXDEPTH + if (and (IM_PLFLAGS(im), PL_BOOL) != 0) + depth = 1 + call pl_ssize (IM_PL(im), IM_NDIM(im), IM_LEN(im,1), depth) + + } + + call strcpy (Memc[imname], IM_NAME(im), SZ_IMNAME) + IM_ACMODE(im) = sv_acmode + IM_UPDATE(im) = sv_update + IM_PIXOFF(im) = 1 + IM_HGMOFF(im) = NULL + IM_BLIST(im) = NULL + IM_HFD(im) = NULL + + pfd = open ("dev$null", READ_WRITE, BINARY_FILE) + IM_PFD(im) = pfd + + # Execute this even if pixel file has already been opened. + call imsetbuf (IM_PFD(im), im) + + # "Fast i/o" in the conventional sense no IMIO buffering) + # is not permitted for mask images, since IMIO must buffer + # the pixels, which are generated at run time. + + if (IM_FAST(im) == YES) { + IM_PLFLAGS(im) = or (IM_PLFLAGS(im), PL_FAST) + IM_FAST(im) = NO + } + + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfrcard.x b/sys/imio/iki/fxf/fxfrcard.x new file mode 100644 index 00000000..e025283e --- /dev/null +++ b/sys/imio/iki/fxf/fxfrcard.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mii.h> +include "fxf.h" + +# FXF_READ_CARD -- Read a FITS header card. + +int procedure fxf_read_card (fd, ibuf, obuf, ncards) + +int fd #I Input file descriptor +char ibuf[ARB] #I input buffer +char obuf[ARB] #O Output buffer +int ncards #I ncards read so far + +int ip, nchars_read +int read() +errchk read + +begin + # We read one FITS block first, read card from it until 36 + # cards have been processed, where we read again. + + if (mod (ncards, 36) == 0) { + nchars_read = read (fd, ibuf, FITS_BLOCK_CHARS) + if (nchars_read == EOF) + return (EOF) + call miiupk (ibuf, ibuf, FITS_BLOCK_BYTES, MII_BYTE, TY_CHAR) + ip = 1 + } + + call amovc (ibuf[ip], obuf, LEN_CARD) + ip = ip + LEN_CARD + + return (LEN_CARD) +end diff --git a/sys/imio/iki/fxf/fxfrdhdr.x b/sys/imio/iki/fxf/fxfrdhdr.x new file mode 100644 index 00000000..7cfc7855 --- /dev/null +++ b/sys/imio/iki/fxf/fxfrdhdr.x @@ -0,0 +1,176 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include <mach.h> +include "fxf.h" + + +# FXF_RHEADER -- Read a FITS header into the image descriptor and the +# internal FITS descriptor. + +procedure fxf_rheader (im, group, acmode) + +pointer im #I image descriptor +int group #I group number to read +int acmode #I access mode + +long pixoff, mtime +pointer sp, fit, lbuf, poff +int compress, devblksz, i, impixtype +bool bfloat, lscale, lzero +bool fxf_fpl_equald() +int strncmp() + +errchk fxf_rfitshdr, realloc, syserr, syserrs + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + fit = IM_KDES(im) + + FIT_MAX(fit) = 0.0 + FIT_MIN(fit) = 0.0 + FIT_MTIME(fit) = 0.0 + FIT_IM(fit) = im + FIT_OBJECT(fit) = EOS + IM_CLSIZE(im) = 0 + + # Read the header unit number 'group', setting the values of the + # reserved fields in the FIT descriptor saving it in the FITS cache. + + call fxf_rfitshdr (im, group, poff) + + IM_MIN(im) = FIT_MIN(fit) + IM_MAX(im) = FIT_MAX(fit) + IM_MTIME(im) = FIT_MTIME(fit) + call strcpy (FIT_OBJECT(fit), IM_TITLE(im), LEN_CARD) + + # If there is no group specification in the filename, group is -1; + # new group number is in FIT_GROUP. + + group = FIT_GROUP(fit) + IM_CLINDEX(im) = group + + # Process the reserved keywords (set in the FIT descriptor) into the + # corresponding fields of the IMIO descriptor. + + if (acmode != NEW_COPY) { + IM_NDIM(im) = FIT_NAXIS(fit) # IM_NDIM + do i = 1, IM_NDIM(im) { # IM_LEN + IM_LEN(im,i) = FIT_LENAXIS(fit,i) + if (IM_LEN(im,i) == 0) { + IM_NDIM(im) = 0 + break + } + } + } + + lscale = fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 1) + lzero = fxf_fpl_equald (0.0d0, FIT_BZERO(fit), 1) + + # Determine if scaling is necessary. + bfloat = (!lscale || !lzero) + + FIT_PIXTYPE(fit) = NULL + FIT_ZCNV(fit) = NO + + switch (FIT_BITPIX(fit)) { + case 8: + FIT_PIXTYPE(fit) = TY_UBYTE + if (bfloat) + impixtype = TY_REAL + else + impixtype = TY_SHORT # convert from byte to short + FIT_ZCNV(fit) = YES + case 16: + FIT_PIXTYPE(fit) = TY_SHORT + if (bfloat) { + impixtype = TY_REAL + FIT_ZCNV(fit) = YES + } else + impixtype = TY_SHORT + + if ((strncmp ("USHORT", FIT_DATATYPE(fit), 6) == 0) || + (lscale && fxf_fpl_equald (32768.0d0, FIT_BZERO(fit),4))) { + impixtype = TY_USHORT + FIT_ZCNV(fit) = NO + } + case 32: + FIT_PIXTYPE(fit) = TY_INT + if (bfloat) + impixtype = TY_REAL + else + impixtype = TY_INT + case -32: + FIT_PIXTYPE(fit) = TY_REAL + impixtype = TY_REAL + case -64: + FIT_PIXTYPE(fit) = TY_DOUBLE + impixtype = TY_DOUBLE + default: + impixtype = ERR + } + + IM_PIXTYPE(im) = impixtype + + IM_NBPIX(im) = 0 # no. bad pixels + mtime = IM_MTIME(im) + + if (IM_MAX(im) > IM_MIN(im)) + IM_LIMTIME(im) = mtime + 1 # time max/min last updated + else + IM_LIMTIME(im) = mtime - 1 # Invalidate DATA(MIN,MAX) + IM_HISTORY(im) = EOS + + # Call up IMIO to set up the remaining image header fields used to + # define the physical offsets of the pixels in the pixfile. + + compress = YES # do not align image lines on blocks + devblksz = 1 # disable all alignment + + pixoff = Memi[poff+group] + FIT_PIXOFF(fit) = pixoff + call imioff (im, pixoff, compress, devblksz) + + call sfree (sp) +end + + +# FXF_FPL_EQUALD -- Compare 2 double precision quantities up to a precision +# given by a tolerance. + +bool procedure fxf_fpl_equald (x, y, it) + +double x, y #I Input quantities to be compare for equality +int it #I Tolerance factor of 10 to compare the values + +int ex, ey +double x1, x2, normx, normy, tol + +begin + # Check for the obvious first. + if (x == y) + return (true) + + # We can't normalize zero, so handle the zero operand cases first. + # Note that the case 0 equals 0 is handled above. + + if (x == 0.0D0 || y == 0.0D0) + return (false) + + # Normalize operands and do an epsilon compare. + call fp_normd (x, normx, ex) + call fp_normd (y, normy, ey) + + if (ex != ey) + return (false) + else { + tol = EPSILOND * 10.0D0 * it + x1 = 1.0D0 + abs (normx - normy) + x2 = 1.0D0 + tol + return (x1 <= x2) + } +end diff --git a/sys/imio/iki/fxf/fxfrename.x b/sys/imio/iki/fxf/fxfrename.x new file mode 100644 index 00000000..677c02dd --- /dev/null +++ b/sys/imio/iki/fxf/fxfrename.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include "fxf.h" + + +# FIT_RENAME -- Rename a fits file. NOTE: There is no prevision at this +# time to rename an extension. + +procedure fxf_rename (kernel, oroot, oextn, nroot, nextn, status) + +int kernel #I IKI kernel +char oroot[ARB] #I old image root name +char oextn[ARB] #I old image extn +char nroot[ARB] #I new image root name +char nextn[ARB] #I old image extn +int status #O status value + +pointer sp +int cindx +pointer ohdr_fname, nhdr_fname +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (ohdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (nhdr_fname, SZ_PATHNAME, TY_CHAR) + + call fxf_init() + + # Generate filenames. + call iki_mkfname (oroot, oextn, Memc[ohdr_fname], SZ_PATHNAME) + call iki_mkfname (nroot, nextn, Memc[nhdr_fname], SZ_PATHNAME) + + if (!streq (Memc[ohdr_fname], Memc[nhdr_fname])) { + iferr (call rename (Memc[ohdr_fname], Memc[nhdr_fname])) + call erract (EA_WARN) + + # Update the cache with the new name. + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + # Rename the cached entry. + if (streq (Memc[ohdr_fname], rf_fname[1,cindx])) + call strcpy (Memc[nhdr_fname], rf_fname[1,cindx], SZ_FNAME) + } + } + + status = OK + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfrfits.x b/sys/imio/iki/fxf/fxfrfits.x new file mode 100644 index 00000000..30a8d5f7 --- /dev/null +++ b/sys/imio/iki/fxf/fxfrfits.x @@ -0,0 +1,1322 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <time.h> +include <ctype.h> +include <imhdr.h> +include <imio.h> +include <finfo.h> +include <fset.h> +include <mach.h> +include <imset.h> +include <error.h> +include "fxf.h" + +# FXFRFITS.X -- Routines to load FITS header in memory and set up the cache +# mechanism. + +define LEN_UACARD_100 8100 +define LEN_UACARD_5 405 + + +# FXF_RFITSHDR -- Procedure to read one or more FITS header while caching +# the primary header, set the FITS memory structure for each +# filename, the header and pixel offset from the beginning +# and the EXTNAME and EXTVER value for each extension. + +procedure fxf_rfitshdr (im, group, poff) + +pointer im #I image descriptor +int group #I Group number to read +int poff #O char offset the the pixel area in the FITS image + +long fi[LEN_FINFO] +pointer hoff,totpix, extn, extv +pointer sp, fit, o_fit, lbuf, hdrfile, hdr +int cindx, cfit, user, fitslen, offs_count +int in, spool, slot, i, nrec1440, acmode + +bool initialized, reload, extname_or_ver, ext_append +data initialized /false/ +int rf_refcount + +bool streq() +long cputime(), fstatl() + +int finfo(), open(), stropen(), getline() + +errchk putline, syserrs, seek, calloc, realloc, syserr +errchk fpathname, calloc, fxf_load_header, fxf_skip_xtn, fxf_read_xtn + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + # Initialize the header file cache on the first call. The kernel + # doesn't appear to work with the cache completely deactivated, so + # the minimum cachesize is 1. + + if (!initialized) { + rf_refcount = 0 + do i = 1, MAX_CACHE + rf_fit[i] = 0 + rf_cachesize = max(1, min(MAX_CACHE, FKS_CACHESIZE(IM_KDES(im)))) + initialized = true + } else + rf_refcount = rf_refcount + 1 + + o_fit = IM_KDES(im) + reload = false + slot = 1 + # Get file system info on the desired header file. + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + + if (finfo (Memc[hdrfile], fi) == ERR) + call syserrs (SYS_FOPEN, IM_HDRFILE(im)) + + acmode = FIT_ACMODE(o_fit) + ext_append = (acmode == NEW_IMAGE || acmode == NEW_COPY) + repeat { + # Search the header file cache for the named image. + do cindx = 1, rf_cachesize { + if (rf_fit[cindx] == NULL) { + slot = cindx + next + } + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + # File is in cache; is cached entry still valid? + # If we are appending extension, do not reload from + # disk. + + if (FI_MTIME(fi) != rf_mtime[cindx] && !ext_append) { + # File modify date has changed, reuse slot. + slot = cindx + break + } + + # For every non-empty file the fxf_open() call + # pre reads every PHU, so that when the fxf_rdhdr() + # comes, the cache entry is already here. + + # Return the cached header. + rf_lru[cindx] = rf_refcount + cfit = rf_fit[cindx] + FIT_XTENSION(cfit) = FIT_XTENSION(o_fit) + FIT_ACMODE(cfit) = FIT_ACMODE(o_fit) + FIT_EXPAND(cfit) = FIT_EXPAND(o_fit) + + # Load Extend value from cache header entry to + # the current fit struct entry. + + FIT_EXTEND(o_fit) = FIT_EXTEND(cfit) + + call amovi (FIT_ACMODE(cfit), FIT_ACMODE(o_fit), + LEN_FITBASE) + hoff = rf_hdrp[cindx] + poff = rf_pixp[cindx] + extn = rf_pextn[cindx] + extv = rf_pextv[cindx] + FIT_GROUP(o_fit) = group + FIT_HDRPTR(o_fit) = hoff + FIT_PIXPTR(o_fit) = poff + + extname_or_ver = (FKS_EXTNAME(o_fit) != EOS || + !IS_INDEFL (FKS_EXTVER(o_fit))) + + # If the group number or extname_or_ver has not been + # specified we need to load the group number where there + # is data i.e., FIT_NAXIS != 0. The 'cfit' structure would + # have this group number. + + if (group == -1 && !extname_or_ver) { + if (FIT_GROUP(cfit) != -1) { + group = FIT_GROUP(cfit) + FIT_GROUP(o_fit) = group + + } else if (FIT_NAXIS(cfit) != 0) { + # See if the main FITS unit has data when + # group = -1 is specified. + + group = 0 + FIT_GROUP(cfit) = 0 + FIT_GROUP(o_fit) = 0 + } + } + + # The main header has already been read at this point, + # now merge with UA. + + if (group == 0) { + hdr = rf_hdr[cindx] + fitslen = rf_fitslen[cindx] + FIT_EXTEND(o_fit) = FIT_EXTEND(cfit) + call fxf_merge_w_ua (im, hdr, fitslen) + + } else { + # Read intermediate xtension headers if not in + # hoff and poff yet. + offs_count = FIT_NUMOFFS(cfit) + call fxf_read_xtn (im, + cfit, group, hoff, poff, extn, extv) + } + + # IM_CTIME takes the value of the DATE keyword + if (IM_CTIME(im)==0) { + IM_CTIME(im) = FI_CTIME(fi) + } + + # FIT_MTIME takes the value of keyword IRAF-TLM. + # If not present use the mtime from the finfo value. + + if (FIT_MTIME(cfit) == 0) { + FIT_MTIME(cfit) = FI_MTIME(fi) + } + + # Invalidate entry if cache is disabled. + if (rf_cachesize <= 0) + rf_time[cindx] = 0 + + call sfree (sp) + return # IN CACHE + + } else { + # Keep track of least recently used slot. + if (rf_lru[cindx] < rf_lru[slot]) + slot = cindx + } + } + + # Either the image header is not in the cache, or the cached + # entry is invalid. Prepare the given cache slot and read the + # header into it. + + # Free old save buffer and descriptor. + if (rf_fit[slot] != NULL) { + call mfree (rf_pextv[slot], TY_INT) + call mfree (rf_pextn[slot], TY_CHAR) + call mfree (rf_pixp[slot], TY_INT) + call mfree (rf_hdrp[slot], TY_INT) + call mfree (rf_fit[slot], TY_STRUCT) + call mfree (rf_hdr[slot], TY_CHAR) + rf_fit[slot] = NULL + rf_lru[slot] = 0 + rf_fname[1,slot] = EOS + } + + # Allocate a spool file for the FITS data. + spool = open ("spool", NEW_FILE, SPOOL_FILE) + + # Allocate cache version of FITS descriptor. + call calloc (fit, LEN_FITBASE, TY_STRUCT) + call calloc (hoff, MAX_OFFSETS, TY_INT) + call calloc (poff, MAX_OFFSETS, TY_INT) + call calloc (extn, MAX_OFFSETS*LEN_CARD, TY_CHAR) + call calloc (extv, MAX_OFFSETS, TY_INT) + + # Initialize the entries. + call amovki (INDEFL, Memi[extv], MAX_OFFSETS) + call aclrc (Memc[extn], MAX_OFFSETS) + call amovki (-1, Memi[poff], MAX_OFFSETS) + + FIT_GROUP(fit) = -1 + FIT_HDRPTR(fit) = hoff + FIT_PIXPTR(fit) = poff + FIT_NUMOFFS(fit) = MAX_OFFSETS + FIT_ACMODE(fit) = FIT_ACMODE(o_fit) + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + FIT_XTENSION(fit) = NO + FIT_EXTNAME(fit) = EOS + FIT_EXTVER(fit) = INDEFL + FIT_EXTEND(fit) = -3 + + # Initialize the cache entry. + call strcpy (Memc[hdrfile], rf_fname[1,slot], SZ_PATHNAME) + rf_fit[slot] = fit + rf_hdrp[slot] = hoff + rf_pixp[slot] = poff + rf_pextn[slot] = extn + rf_pextv[slot] = extv + rf_lru[slot] = rf_refcount + rf_mtime[slot] = FI_MTIME(fi) + + if (!reload) + rf_time[slot] = cputime (0) + + reload = true + + in = IM_HFD(im) + call seek (in, BOFL) + + # Read main FITS header and copy to spool fd. + FIT_IM(fit) = im + call amovki (1, FIT_LENAXIS(fit,1), IM_MAXDIM) + + call fxf_load_header (in, fit, spool, nrec1440, totpix) + + + # Record group 0 (PHU) as having just been read. + FIT_GROUP(fit) = 0 + + call seek (spool, BOFL) + fitslen = fstatl (spool, F_FILESIZE) + + # Prepare cache area to store the FITS header. + call calloc (hdr, fitslen, TY_CHAR) + user = stropen (Memc[hdr], fitslen, NEW_FILE) + rf_hdr[slot] = hdr + rf_fitslen[slot] = fitslen + FIT_CACHEHDR(fit) = hdr + FIT_CACHEHLEN(fit) = fitslen + + # Append the saved FITS cards to saved cache. + while (getline (spool, Memc[lbuf]) != EOF) + call putline (user, Memc[lbuf]) + + call close (user) + call close (spool) + + # Group 0 (i.e. Main Fits unit) + Memi[hoff] = 1 # beginning of primary h.u. + Memi[poff] = nrec1440 + 1 # first pixel data of main u. + + # Set group 1 offsets. + Memi[hoff+1] = Memi[poff] + totpix + Memi[poff+1] = -1 + } + + call sfree (sp) +end + + +# FXF_READ_XTN -- Procedure to read a FITS extension header and at the same +# time make sure that the EXTNAME and EXTVER values are not repeated +# with those in the cache. + +procedure fxf_read_xtn (im, cfit, igroup, hoff, poff, extn, extv) + +pointer im #I Image descriptor +pointer cfit #I Cached FITS descriptor +int igroup #I Group number to process +pointer hoff #I Pointer to header offsets array +pointer poff #I Pointer to pixel offsets array +pointer extn #I Pointer to extname's array +pointer extv #I Pointer to extver's array + +char messg[SZ_LINE] +pointer lfit, sp, po, ln +int spool, ig, acmode, i +int fitslen, xtn_hd, nrec1440, totpix, in, group +int strcmp(), getline() +long offset, fstatl() +int open(), fxf_extnv_error() +bool ext_append, get_group + +errchk fxf_load_header, fxf_skip_xtn, syserr, syserrs +define rxtn_ 91 + +begin + # Allocate a spool file for the FITS header. + spool = open ("FITSHDRX", READ_WRITE, SPOOL_FILE) + + lfit = IM_KDES(im) + group = FIT_GROUP(lfit) + acmode = FIT_ACMODE(lfit) + ext_append = (acmode == NEW_IMAGE || acmode == NEW_COPY) + + # If we have 'overwrite' in the ksection then look for the + # existent extname/extver we want to overwrite since we don't + # want to append. + + if (FKS_OVERWRITE(lfit) == YES) + ext_append = false + + # See if we want to look at an extension given the EXT(NAME,VER) + # field in the ksection. + + if (FKS_EXTNAME(lfit) != EOS || !IS_INDEFL (FKS_EXTVER(lfit))) { + ig = 1 + repeat { + call fseti (spool, F_CANCEL, YES) + xtn_hd = NO + + # Has last extension header been read? + if (Memi[poff+ig] <= 0) { + iferr { + call fxf_skip_xtn (im, + ig, cfit, hoff, poff, extn, extv, spool) + xtn_hd = YES + } then { + if (ext_append) { + # We have reach the end of extensions. + FIT_GROUP(lfit) = -1 # message for fxf_updhdr + return + } else { + call fxf_form_messg (lfit, messg) + call syserrs (SYS_FXFRFNEXTNV, messg) + } + } else { + # If we want to append an extension then. + if (ext_append && FKS_DUPNAME(lfit) == NO) + if (fxf_extnv_error (lfit, ig, extn, extv) == YES) { + call fxf_form_messg (lfit, messg) + call syserrs (SYS_FXFOPEXTNV, messg) + } + } + } + + if (fxf_extnv_error (lfit, ig, extn, extv) == YES) { + # We have matched either or both FKS_EXTNAME and FKS_EXTVER + # with the values in the cache. + + if (ext_append && FKS_DUPNAME(lfit) == NO) { + call fxf_form_messg (lfit, messg) + call syserrs (SYS_FXFOPEXTNV, messg) + } + group = ig + FIT_GROUP(lfit) = ig + goto rxtn_ + + } else { + ig = ig + 1 + next + } + } + + } else { + # No extname or extver specified. + # Read through the Extensions until group number is reached; + # if no number is supplied, read until EOF to load header and + # pixel offsets necessary to append and extension. + + if (igroup == -1 && FIT_GROUP(cfit) == -1) + group = MAX_INT + + # We are trying to get the first group that meets these condition. + get_group = (FIT_GROUP(cfit) == -1 && igroup == -1) + + do ig = 0, group { + xtn_hd = NO + + # Has last extension header been read? + if (Memi[poff+ig] <= 0 ) { + call fseti (spool, F_CANCEL, YES) + iferr { + call fxf_skip_xtn (im, + ig, cfit, hoff, poff, extn, extv, spool) + xtn_hd = YES + } then { + if (ext_append) { + # We have reach the end of extensions. + FIT_GROUP(lfit) = -1 # message for fxf_updhdr + return + } else { + call syserrs (SYS_FXFRFEOF, IM_NAME(im)) + return + } + } + + # Mark the first group that contains an image + # i.e. naxis != 0. + + if (FIT_NAXIS(lfit) != 0 && + strcmp ("IMAGE", FIT_EXTTYPE(lfit)) == 0) { + if (get_group) { + FIT_GROUP(cfit) = ig # save on cache fits struct + FIT_GROUP(lfit) = ig # also on current + break + } else if (FIT_GROUP(cfit) <= 0) + FIT_GROUP(cfit) = ig + } + } + } + } +rxtn_ + if (xtn_hd == NO) { + in = IM_HFD(im) + offset = Memi[hoff+group] + call seek (in, offset) + FIT_IM(lfit) = im + call fseti (spool, F_CANCEL, YES) + call fxf_load_header (in, lfit, spool, nrec1440, totpix) + } + + # If requested a non supported BINTABLE format, post an error + # message and return to the caller. + + if (strcmp(FIT_EXTTYPE(lfit), "BINTABLE") == 0) { + if (strcmp(FIT_EXTSTYPE(lfit), "PLIO_1") != 0) { + call close (spool) + call syserrs (SYS_IKIEXTN, IM_NAME(im)) + } + } + + # Merge Image Extension header to the user area. + fitslen = fstatl (spool, F_FILESIZE) + + # Copy the spool array into a static array. We cannot reliable + # get the pointer from the spool file. + call smark (sp) + call salloc (ln, LEN_UACARD, TY_CHAR) + + if (po != NULL) + call mfree(po, TY_CHAR) + call calloc (po, fitslen+1, TY_CHAR) + + i = po + call seek (spool, BOFL) + while (getline (spool, Memc[ln]) != EOF) { + + call amovc (Memc[ln], Memc[i], LEN_UACARD) + i = i + LEN_UACARD + } + Memc[i] = EOS + + # Make the user aware that they cannot use inheritance + # if the PDU contains a data array. + + if (Memi[poff] != Memi[hoff+1]) { + if (FKS_INHERIT(lfit) == YES) { + call syserr (SYS_FXFBADINH) + } + } else { + # Disable inheritance if PHDU has a DU. + if (Memi[poff+0] != Memi[hoff+1]) + FIT_INHERIT(lfit) = NO + } + + # Reset the value of FIT_INHERIT if FKS_INHERIT is set + if (FKS_INHERIT(lfit) != NO_KEYW) + FIT_INHERIT(lfit) = FKS_INHERIT(lfit) + + if (FIT_TFIELDS(lfit) > 0) { + fitslen = fitslen + FIT_TFIELDS(lfit)*LEN_UACARD + call realloc (po, fitslen, TY_CHAR) + } + + call fxf_merge_w_ua (im, po, fitslen) + + call mfree (po, TY_CHAR) + + call sfree (sp) + call close (spool) +end + + +# FXF_EXTNV_ERROR -- Integer boolean function (YES,NO) to find out if the +# value of kernel section parameter FKS_EXTNAME and FKS_EXTVER are not +# repeated in the cache pointed by extn and extv. + +int procedure fxf_extnv_error (fit, ig, extn, extv) + +pointer fit #I fit descriptor +int ig #I extension number +pointer extn, extv #I pointers to arrays for extname and extver + +bool bxtn, bxtv, bval, bxtn_eq, bxtv_eq +int fxf_strcmp_lwr() + +begin + bxtn = (FKS_EXTNAME(fit) != EOS) + bxtv = (!IS_INDEFL (FKS_EXTVER(fit))) + + if (bxtn) + bxtn_eq = + (fxf_strcmp_lwr(FKS_EXTNAME(fit), Memc[extn+LEN_CARD*ig]) == 0) + if (bxtv) + bxtv_eq = (FKS_EXTVER(fit) == Memi[extv+ig]) + + if (bxtn && bxtv) { + # Since both FKS_EXTNAME and FKS_EXTVER are defined, see if they + # repeated in the cache. + + bval = (bxtn_eq && bxtv_eq) + + } else if (bxtn && !bxtv) { + # We have a duplicated in this case when extver in the image + # header is INDEFL. + + bval = bxtn_eq + + } else if (!bxtn && bxtv) { + # If the FKS_EXTNAME is not defined (i.e. EOS) and the FKS_EXTVER + # value is the same as the cached, then we have a match. + + bval = bxtv_eq + + } else + bval = false + + if (bval) + return (YES) + else + return (NO) +end + + +# FXF_SKIP_XTN -- Skip over a FITS extension. The procedure will read the +# current extension header and calculates the respectives offset for later +# usage. + +procedure fxf_skip_xtn (im, group, cfit, hoff, poff, extn, extv, spool) + +pointer im #I image descriptor +int group #I groupheader number to read +pointer cfit #I cached fits descriptor +pointer hoff #I extension header offset +pointer poff #I extension data offset +pointer extn #I points to the array of extname +pointer extv #I points to the arrays of extver + +pointer sp, lfit, fit, hdrfile +bool streq() +int spool, in, nrec1440, totpix, i, k, cindx +long offset +errchk fxf_load_header +int strcmp() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (lfit, LEN_FITBASE, TY_STRUCT) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + call seek (spool, BOFL) + fit = IM_KDES(im) + + # Allocate more memory for offsets in case we are pass MAX_OFFSETS. + if (group >= FIT_NUMOFFS(cfit)) { + FIT_NUMOFFS(cfit) = FIT_NUMOFFS(cfit) + MAX_OFFSETS + call realloc (hoff, FIT_NUMOFFS(cfit), TY_INT) + call realloc (poff, FIT_NUMOFFS(cfit), TY_INT) + call realloc (extn, FIT_NUMOFFS(cfit)*LEN_CARD, TY_CHAR) + call realloc (extv, FIT_NUMOFFS(cfit), TY_INT) + + offset = FIT_NUMOFFS(cfit) - MAX_OFFSETS + call amovki (INDEFL, Memi[extv+offset], MAX_OFFSETS) + call amovki (-1, Memi[poff+offset], MAX_OFFSETS) + + do i = 0, MAX_OFFSETS-1 { + k = (offset+i)*LEN_CARD + Memc[extn+k] = EOS + } + + # Update the fits structure with the new pointer values + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + fit = IM_KDES(im) + do cindx = 1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + rf_pextn[cindx] = extn + rf_pextv[cindx] = extv + rf_hdrp[cindx] = hoff + rf_pixp[cindx] = poff + FIT_HDRPTR(fit) = hoff + FIT_PIXPTR(fit) = poff + } + } + } + + in = IM_HFD(im) + offset = Memi[hoff+group] + + call seek (in, offset) + lfit = IM_KDES(im) + FIT_IM(lfit) = im + call fxf_load_header (in, lfit, spool, nrec1440, totpix) + + # Record the first group that has NAXIS !=0 and is an IMAGE. + if (FIT_GROUP(cfit) == -1) { + if (FIT_NAXIS(lfit) != 0 && + strcmp ("IMAGE", FIT_EXTTYPE(lfit)) == 0) + FIT_GROUP(cfit) = group + } + + Memi[poff+group] = Memi[hoff+group] + nrec1440 + # The offset for the beginning of next group. + Memi[hoff+group+1] = Memi[poff+group] + totpix + + # Mark next group pixel offset in case we are at EOF. + Memi[poff+group+1] = -1 + call strcpy (FIT_EXTNAME(lfit), Memc[extn+LEN_CARD*group], LEN_CARD) + Memi[extv+group] = FIT_EXTVER(lfit) + + call sfree (sp) +end + + +# FXF_LOAD_HEADER -- Load a FITS header from a file descriptor into a +# spool file. + +procedure fxf_load_header (in, fit, spool, nrec1440, datalen) + +int in #I input FITS header file descriptor +pointer fit #I FITS descriptor +int spool #I spool output file descriptor +int nrec1440 #O number of 1440 char records output +int datalen #O length of data area in chars + +int ncols +pointer lbuf, sp, im, stime, fb, ttp +int totpix, nchars, nbytes, index, ncards, simple, i, pcount, junk +int fxf_read_card(), fxf_ctype(), ctoi(), strsearch() +bool fxf_fpl_equald() +errchk syserr, syserrs + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (stime, LEN_CARD, TY_CHAR) + call salloc (fb, FITS_BLOCK_BYTES, TY_CHAR) + + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + FIT_EXTNAME(fit) = EOS + FIT_EXTVER(fit) = INDEFL + im = FIT_IM(fit) + + # Read successive lines of the FITS header. + nrec1440 = 0 + pcount = 0 + ncards = 0 + + repeat { + # Get the next input line. + nchars = fxf_read_card (in, Memc[fb], Memc[lbuf], ncards) + if (nchars == EOF) { + call close (spool) + call syserrs (SYS_FXFRFEOF, IM_NAME(im)) + } + ncards = ncards + 1 + + # A FITS header card already has 80 chars, just add the newline. + Memc[lbuf+LEN_CARD] = '\n' + Memc[lbuf+LEN_CARD+1] = EOS + + # Process the header card. + switch (fxf_ctype (Memc[lbuf], index)) { + case KW_END: + nrec1440 = FITS_LEN_CHAR(ncards*40) + break + case KW_SIMPLE: + call strcpy ("SIMPLE", FIT_EXTTYPE(fit), SZ_EXTTYPE) + call fxf_getb (Memc[lbuf], simple) + FIT_EXTEND(fit) = NO_KEYW + if (simple == NO) + call syserr (SYS_FXFRFSIMPLE) + case KW_EXTEND: + call putline (spool, Memc[lbuf]) + call fxf_getb (Memc[lbuf], FIT_EXTEND(fit)) + case KW_XTENSION: + FIT_XTENSION(fit) = YES + call fxf_gstr (Memc[lbuf], FIT_EXTTYPE(fit), SZ_EXTTYPE) + case KW_EXTNAME: + call fxf_gstr (Memc[lbuf], FIT_EXTNAME(fit), LEN_CARD) + call putline (spool, Memc[lbuf]) + case KW_EXTVER: + call fxf_geti (Memc[lbuf], FIT_EXTVER(fit)) + call putline (spool, Memc[lbuf]) + case KW_ZCMPTYPE: + call fxf_gstr (Memc[lbuf], FIT_EXTSTYPE(fit), SZ_EXTTYPE) + case KW_PCOUNT: + call fxf_geti (Memc[lbuf], pcount) + call putline (spool, Memc[lbuf]) + FIT_PCOUNT(fit) = pcount + case KW_INHERIT: + call fxf_getb (Memc[lbuf], FIT_INHERIT(fit)) + call putline (spool, Memc[lbuf]) + case KW_BITPIX: + call fxf_geti (Memc[lbuf], FIT_BITPIX(fit)) + case KW_DATATYPE: + call fxf_gstr (Memc[lbuf], FIT_DATATYPE(fit), SZ_DATATYPE) + case KW_NAXIS: + if (index == 0) { + call fxf_geti (Memc[lbuf], FIT_NAXIS(fit)) + if (FIT_NAXIS(fit) < 0 ) + call syserr (SYS_FXFRFBNAXIS) + } else + call fxf_geti (Memc[lbuf], FIT_LENAXIS(fit,index)) + case KW_BSCALE: + call fxf_getd (Memc[lbuf], FIT_BSCALE(fit)) + # If BSCALE is like 1.00000011 reset to 1.0. + if (fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 4)) + FIT_BSCALE(fit) = 1.0d0 + call putline (spool, Memc[lbuf]) + case KW_BZERO: + call fxf_getd (Memc[lbuf], FIT_BZERO(fit)) + # If BZERO is like 0.00000011 reset to 0.0. + if (fxf_fpl_equald (0.0d0, FIT_BZERO(fit), 4)) + FIT_BZERO(fit) = 0.0d0 + call putline (spool, Memc[lbuf]) + case KW_DATAMAX: + call fxf_getr (Memc[lbuf], FIT_MAX(fit)) + call putline (spool, Memc[lbuf]) + case KW_DATAMIN: + call fxf_getr (Memc[lbuf], FIT_MIN(fit)) + call putline (spool, Memc[lbuf]) + case KW_TFIELDS: + # Allocate space for TFORM and TTYPE keyword values + call fxf_geti (Memc[lbuf], ncols) + FIT_TFIELDS(fit) = ncols + if (FIT_TFORMP(fit) != NULL) { + call mfree (FIT_TFORMP(fit), TY_CHAR) + call mfree (FIT_TTYPEP(fit), TY_CHAR) + } + call calloc (FIT_TFORMP(fit), ncols*LEN_FORMAT, TY_CHAR) + call calloc (FIT_TTYPEP(fit), ncols*LEN_OBJECT, TY_CHAR) + case KW_TFORM: + call fxf_gstr (Memc[lbuf], Memc[stime], LEN_CARD) + if (index == 1) { + # PLMAXLEN is used to indicate the maximum line list + # length for PLIO masks in bintables. The syntax + # "PI(maxlen)" is used in bintables to pass the max + # vararray length for a column. + + i = strsearch (Memc[stime], "PI(") + if (i > 0) + junk = ctoi (Memc[stime], i, FIT_PLMAXLEN(fit)) + } + case KW_TTYPE: + ttp = FIT_TTYPEP(fit) + (index-1)*LEN_OBJECT + call fxf_gstr (Memc[lbuf], Memc[ttp], LEN_CARD) + case KW_OBJECT: + # Since only OBJECT can go into the header and IM_TITLE has its + # values as well, we need to save both to see which one has + # changed at closing time. + + call fxf_gstr (Memc[lbuf], FIT_OBJECT(fit), LEN_CARD) + if (FIT_OBJECT(fit) == EOS) + call strcpy (" ", FIT_OBJECT(fit), SZ_KEYWORD) + call strcpy (FIT_OBJECT(fit), FIT_TITLE(fit), LEN_CARD) + call strcpy (FIT_OBJECT(fit), IM_TITLE(im), LEN_CARD) + call putline (spool, Memc[lbuf]) + case KW_IRAFTLM: + call fxf_gstr (Memc[lbuf], Memc[stime], LEN_CARD) + call fxf_date2limtime (Memc[stime], FIT_MTIME(fit)) + call putline (spool, Memc[lbuf]) + case KW_DATE: + call fxf_gstr (Memc[lbuf], Memc[stime], LEN_CARD) + call fxf_date2limtime (Memc[stime], IM_CTIME(im)) + call putline (spool, Memc[lbuf]) + default: + call putline (spool, Memc[lbuf]) + } + } + + # Calculate the length of the data area of the current extension, + # measured in SPP chars and rounded up to an integral number of FITS + # logical blocks. + + if (FIT_NAXIS(fit) != 0) { + totpix = FIT_LENAXIS(fit,1) + do i = 2, FIT_NAXIS(fit) + totpix = totpix * FIT_LENAXIS(fit,i) + + # Compute the size of the data area (pixel matrix plus PCOUNT) + # in bytes. Be careful not to overflow a 32 bit integer. + + nbytes = (totpix + pcount) * (abs(FIT_BITPIX(fit)) / NBITS_BYTE) + + # Round up to fill the final 2880 byte FITS logical block. + nbytes = ((nbytes + 2880-1) / 2880) * 2880 + + datalen = nbytes / SZB_CHAR + + } else + datalen = 0 + + call sfree (sp) +end + + +# FXF_MERGE_W_UA -- Merge a spool user area with the im_userarea. + +procedure fxf_merge_w_ua (im, userh, fitslen) + +pointer im #I image descriptor +int userh #I pointer to user area spool +int fitslen #I length in chars of the user area + +bool inherit +pointer sp, lbuf, ua, ln +int elen, elines, nbl, i, k +int sz_userarea, merge, len_hdrmem, fit, clines, ulines +bool fxf_is_blank() +int strlen() + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (ln, LEN_UACARD, TY_CHAR) + + fit = IM_KDES(im) + + # FIT_INHERIT has the logically combined value of the fkinit inherit's + # value, if any; the ksection value, if any and the INHERIT value in + # the extension header. + + inherit = (FIT_INHERIT(fit) == YES) + inherit = (inherit && (FIT_GROUP(fit) != 0)) + + # Reallocate the image descriptor to allow space for the spooled user + # FITS cards plus a little extra for new parameters. + + sz_userarea = fitslen + SZ_EXTRASPACE + # Add size of main header if necessary. + if (inherit) + sz_userarea = sz_userarea + FIT_CACHEHLEN(fit) + + IM_HDRLEN(im) = LEN_IMHDR + + (sz_userarea - SZ_EXTRASPACE + SZ_MII_INT-1) / SZ_MII_INT + len_hdrmem = LEN_IMHDR + + (sz_userarea+1 + SZ_MII_INT-1) / SZ_MII_INT + + if (IM_LENHDRMEM(im) < len_hdrmem) { + IM_LENHDRMEM(im) = len_hdrmem + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + } + + + # Copy the extension header to the USERAREA if not inherit or copy + # the global header plus the extension header if inherit is set. + + if (fitslen > 0) { + ua = IM_USERAREA(im) + elen = fitslen + + if (inherit) { + # First, copy those cards in the global header that + # are not in the current extension header. + + clines = strlen (Memc[FIT_CACHEHDR(fit)]) + ulines = strlen (Memc[userh]) + clines = clines / LEN_UACARD + ulines = ulines / LEN_UACARD + merge = YES + call fxf_match_str (FIT_CACHEHDR(fit), + clines, userh, ulines, merge, ua) + elen = LEN_UACARD * ulines + } + + # Append the extension header to the UA. + elines = elen / LEN_UACARD + k = userh + nbl = 0 + + do i = 1, elines { + call strcpy (Memc[k], Memc[ln], LEN_UACARD) + if (fxf_is_blank (Memc[ln])) + nbl = nbl + 1 + else { + # If there are blank cards, add them. + if (nbl > 0) + call fxf_blank_lines (nbl, ua) + call amovc (Memc[ln], Memc[ua], LEN_UACARD) + ua = ua + LEN_UACARD + } + k = k + LEN_UACARD + } + + Memc[ua] = EOS + } + call sfree (sp) +end + + +# FXF_STRCMP_LWR -- Compare 2 strings in lower case mode. + +int procedure fxf_strcmp_lwr (s1, s2) + +char s1[ARB], s2[ARB] #I strings to be compare for equality + +int istat +pointer sp, l1, l2 +int strcmp() + +begin + call smark (sp) + call salloc (l1, LEN_CARD, TY_CHAR) + call salloc (l2, LEN_CARD, TY_CHAR) + + call strcpy (s1, Memc[l1], LEN_CARD) + call strcpy (s2, Memc[l2], LEN_CARD) + call strlwr(Memc[l1]) + call strlwr(Memc[l2]) + istat = strcmp (Memc[l1], Memc[l2]) + + call sfree (sp) + return (istat) +end + + +# FXF_DATE2LIMTIME -- Convert the IRAF_TLM string (used to record the IMIO +# time of last modification of the image) into a long integer limtime +# compatible with routine cnvtime(). The year must be 1980 or later. +# The input date string has one of the following forms: +# +# Old format: "hh:mm:ss (dd/mm/yyyy)" +# New (Y2K/ISO) format: "YYYY-MM-DDThh:mm:ss + +procedure fxf_date2limtime (datestr, limtime) + +char datestr[ARB] #I fixed format date string +long limtime #O output limtime (LST seconds from 1980.0) + +double dsec +int hours,minutes,seconds,day,month,year +int status, iso, flags, ip, m, d, y +int dtm_decode_hms(), btoi(), ctoi() +long gmttolst() +double jd + +begin + iso = btoi (datestr[3] != ':') + status = OK + + if (iso == YES) { + status = dtm_decode_hms (datestr, + year,month,day, hours,minutes,dsec, flags) + + # If the decoded date string is old style FITS then the HMS + # values are indefinite, and we need to set them to zero. + + if (and(flags,TF_OLDFITS) != 0) { + hours = 0 + minutes = 0 + seconds = 0 + } else { + if (IS_INDEFD(dsec)) { + hours = 0 + minutes = 0 + seconds = 0 + } else + seconds = nint(dsec) + } + } else { + ip = 1; ip = ctoi (datestr, ip, hours) + ip = 1; ip = ctoi (datestr[4], ip, minutes) + ip = 1; ip = ctoi (datestr[7], ip, seconds) + ip = 1; ip = ctoi (datestr[11], ip, day) + ip = 1; ip = ctoi (datestr[14], ip, month) + ip = 1; ip = ctoi (datestr[17], ip, year) + } + + if (status == ERR || year < 1980) { + limtime = 0 + return + } + + seconds = seconds + minutes * 60 + hours * 3600 + + # Calculate the Julian day from jan 1, 1980. Algorithm taken + # from astutil/asttools/asttimes.x. + + y = year + if (month > 2) + m = month + 1 + else { + m = month + 13 + y = y - 1 + } + + # Original: jd = int (JYEAR * y) + int (30.6001 * m) + day + 1720995 + # -723244.5 is the number of days to add to get 'jd' from jan 1, 1980. + + jd = int (365.25 * y) + int (30.6001 * m) + day - 723244.5 + if (day + 31 * (m + 12 * y) >= 588829) { + d = int (y / 100) + m = int (y / 400) + jd = jd + 2 - d + m + } + jd = jd - 0.5 + day = jd + + limtime = seconds + day * 86400 + if (iso == YES) + limtime = gmttolst (limtime) +end + + +# FIT_MATCH_STR -- FITS header pattern matching algorithm. Match mostly one +# line of lenght LEN_UACARD with the buffer pointed by str; if pattern is not +# in str, put it in the 'out' buffer. + +procedure fxf_match_str (pat, plines, str, slines, merge, po) + +pointer pat #I buffer with pattern +int plines #I number of pattern +pointer str #I string to compare the pattern with +int slines #I number of lines in str +int merge #I flag to indicate merging or unmerge +pointer po #I matching pattern accumulation pointer + +char line[LEN_UACARD] +pointer sp, pt, tpt, tst, ps, pkp +int nbl, l, k, j, i, strncmp(), nbkw, nsb, cmplen +int stridxs() + +begin + call smark (sp) + call salloc (tpt, LEN_UACARD_100+1, TY_CHAR) + call salloc (tst, LEN_UACARD_5+1, TY_CHAR) + + Memc[tpt] = EOS + Memc[tst] = EOS + + # The temporary buffer is non blank only when it has a blank + # keyword following by a comentary: + + #1) ' ' / Comment to the block of keyw + #2) KEYWORD = Value + + nbl = 0 + nbkw = 0 + pt = pat - LEN_UACARD + + for (k=1; k <= plines; k=k+1) { + pt = pt + LEN_UACARD + call strcpy (Memc[pt], line, LEN_UACARD) + + # Do not pass these keywords if merging. + if (merge == YES) { + if (strncmp (line, "COMMENT ", 8) == 0 || + strncmp (line, "HISTORY ", 8) == 0 || + strncmp (line, "OBJECT ", 8) == 0 || + strncmp (line, "EXTEND ", 8) == 0 || + strncmp (line, "ORIGIN ", 8) == 0 || + strncmp (line, "IRAF-TLM", 8) == 0 || + strncmp (line, "DATE ", 8) == 0 ) { + + next + } + } + if (line[1] == ' ') { + call fxf_accum_bufp (line, tpt, nbkw, nbl) + next + } + + if (Memc[tpt] != EOS) { + nbkw = nbkw + 1 + call strcat (line, Memc[tpt], LEN_UACARD_100) + Memc[tst] = EOS + + # Now that we have a buffer with upto 100 lines, we take its + # last 5 card and we are going to compare it with upto 5 + # lines (that can contain blank lines in between). + + pkp = tpt + LEN_UACARD*(nbkw-1) + ps = str - LEN_UACARD + nsb = 0 + + do j = 1, slines { + ps = ps + LEN_UACARD + call strcpy (Memc[ps], line, LEN_UACARD) + + if (line[1] == ' ') { + call fxf_accum_buft (line, tst, nsb) + next + + } else if (Memc[tst] != EOS) { + nsb = nsb + 1 + call strcat (line, Memc[tst], LEN_UACARD_5) + + # To begin compare the first character in the + # keyword line. + + if (Memc[pkp] == line[1]) { + if (strncmp (Memc[pkp-LEN_UACARD*(nsb-1)], + Memc[tst], LEN_UACARD*nsb) == 0) { + nsb = 0 + break + } + } + + nsb = 0 + Memc[tst] = EOS + } + } + + if (j == slines+1) { + if (nbl > 0) + call fxf_blank_lines (nbl, po) + i = tpt + do l = 1, min(100, nbkw) { + call amovc (Memc[i], Memc[po], LEN_UACARD) + i = i + LEN_UACARD + po = po + LEN_UACARD + } + } else { + pt = pt - LEN_UACARD # push back last line + k = k - 1 + } + + Memc[tpt] = EOS + nbkw = 0 + nbl = 0 + + } else { + # One line to compare. + ps = str - LEN_UACARD + cmplen = min (stridxs("=", Memc[pt]), LEN_UACARD) + if (cmplen == 0) + cmplen = LEN_UACARD + +# if (merge == YES) +# cmplen = SZ_KEYWORD + + do j = 1, slines { + ps = ps + LEN_UACARD + if (Memc[ps] == Memc[pt]) { + if (merge == NO) + cmplen = LEN_CARD + if (strncmp (Memc[ps], Memc[pt], cmplen) == 0) { + nbl = 0 + break + } + } + } + + if (j == slines+1) { + if (nbl > 0) + call fxf_blank_lines (nbl, po) + + call amovc (line, Memc[po], LEN_UACARD) + po = po + LEN_UACARD + nbl = 0 + } + } + } + + call sfree (sp) +end + + +# FXF_ACCUM_BUFP -- Accumulate blank keyword cards (No keyword and a / card +# only) and the blank lines in between. + +procedure fxf_accum_bufp (line, tpt, nbkw, nbl) + +char line[LEN_UACARD] #I input card from the pattern buffer +pointer tpt #I pointer to the buffer +int nbkw #U number of blank keyword card +int nbl #U number of blank card before the 1st bkw + +char keyw[SZ_KEYWORD] +bool fxf_is_blank() + +begin + call strcpy (line, keyw, SZ_KEYWORD) + + if (fxf_is_blank (line)) { + # Accumulate blank cards in between bkw cards. + if (nbkw > 0 && nbkw < 100) { + call strcat (line, Memc[tpt], LEN_UACARD_100) + nbkw = nbkw + 1 + } else if (nbkw >= 100) { + nbkw = nbkw - 1 + } else + nbl = nbl + 1 + + } else if (fxf_is_blank (keyw)) { + nbkw = nbkw + 1 + + # We have a blank keyword, but the card is not blank, maybe it is + # a '/ comment' card. Start accumulating upto 100 blank kwy lines. + + if (nbkw < 100) + call strcat (line, Memc[tpt], LEN_UACARD_100) + else + nbkw = nbkw - 1 + } +end + + +# FXF_ACCUM_BUFT -- Accumulate blank keyword keeping track of the blank cards. + +procedure fxf_accum_buft (line, tst, nsb) + +char line[LEN_UACARD] #I input card from the target buffer +pointer tst #I pointer to output buffer +int nsb #U number of consecutives blank cards + +char keyw[SZ_KEYWORD] +bool fxf_is_blank() + +begin + call strcpy (line, keyw, SZ_KEYWORD) + + if (fxf_is_blank (line)) { + if (nsb > 0 && nsb < 5) { + call strcat (line, Memc[tst], LEN_UACARD_5) + nsb = nsb + 1 + } else if (nsb > 4) + nsb = nsb - 1 + } else if (fxf_is_blank (keyw)) { + # We want to pick the last blank kwy only. + call strcpy (line, Memc[tst], LEN_UACARD_5) + nsb = 1 + } +end + + +# FXF_BLANK_LINES -- Write a number of blank lines into output buffer. + +procedure fxf_blank_lines (nbl, po) + +int nbl #U number of blank lines to write +pointer po #I output buffer pointer + +char blk[1] +int i + +begin + blk[1] = ' ' + do i = 1, nbl { + call amovkc (blk[1], Memc[po], LEN_UACARD) + po = po + LEN_UACARD + Memc[po-1] = '\n' + } + nbl = 0 +end + + +# FXF_IS_BLANK -- Determine is the string is blank. + +bool procedure fxf_is_blank (line) + +char line[ARB] #I input string +int i + +begin + for (i=1; IS_WHITE(line[i]); i=i+1) + ; + + if (line[i] == NULL || line[i] == '\n') + return (true) + else + return (false) +end + + +# FXF_FORM_MESSG -- Form string from extname, extver. + +procedure fxf_form_messg (fit, messg) + +pointer fit #I fits descriptor +char messg[ARB] #O string + +begin + if (!IS_INDEFL (FKS_EXTVER(fit))) { + call sprintf (messg, LEN_CARD, "'%s,%d'") + call pargstr (FKS_EXTNAME(fit)) + call pargi (FKS_EXTVER(fit)) + } else { + call sprintf (messg, LEN_CARD, "'%s'") + call pargstr (FKS_EXTNAME(fit)) + } +end diff --git a/sys/imio/iki/fxf/fxfupdhdr.x b/sys/imio/iki/fxf/fxfupdhdr.x new file mode 100644 index 00000000..40a24763 --- /dev/null +++ b/sys/imio/iki/fxf/fxfupdhdr.x @@ -0,0 +1,1478 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imio.h> +include <finfo.h> +include <fio.h> +include <fset.h> +include <mii.h> +include <time.h> +include <mach.h> +include "fxf.h" + +# FXFUPDHDR.X -- Routines to update the header of an image extension on +# disk. + +define SZ_DATESTR 24 + + +# FXF_UPDHDR -- Update the FITS header file. This is done by writing an +# entire new header file and then replacing the old header file with the +# new one. This is necessary since the header file is a text file and text +# files cannot be randomly updated. + +procedure fxf_updhdr (im, status) + +pointer im #I image descriptor +int status #O return status + +pointer sp, fit, mii, poff +pointer outname, fits_file, tmp1, tmp2 +bool adjust_header, overwrite, append +int i, nchars_ua, hdr_fd, group, hdr_off, size +int npad, nlines, pixoff, grp_pix_off, nbks +int acmode, in_fd, diff, hdr_acmode, in_off, nchars, subtype +int read(), fxf_hdr_offset(), access(), strncmp() +int open(), fstatl(), fnldir(), strlen(), stridxs() +bool fnullfile() + +errchk open, read, write, fxf_header_diff, fxf_write_header, fxf_make_adj_copy +errchk fxf_set_cache_time, syserr, syserrs, imerr +errchk fxf_expandh, fxf_not_incache, fxf_ren_tmp, fxf_update_extend +long clktime() + +begin + call smark (sp) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + call salloc (fits_file, SZ_FNAME, TY_CHAR) + call salloc (outname, SZ_PATHNAME, TY_CHAR) + call salloc (tmp1, max(SZ_PATHNAME,SZ_FNAME*2), TY_CHAR) + call salloc (tmp2, max(SZ_PATHNAME,SZ_FNAME*2), TY_CHAR) + + acmode = IM_ACMODE(im) + fit = IM_KDES(im) + status = OK + + # For all intents and purposes the APPEND access mode is the same + # as NEW_IMAGE under the FK. Let's simplify the code as the user + # has requested APPEND. + + if (acmode == APPEND) + acmode = NEW_IMAGE + + if (acmode == READ_ONLY) + call imerr (IM_NAME(im), SYS_IMUPIMHDR) + + if (fnullfile (IM_HDRFILE(im))) { + call sfree (sp) + return + } + + group = FIT_GROUP(fit) + + subtype = 0 + if ((FKS_SUBTYPE(fit) == FK_PLIO || + (strncmp("PLIO_1", FIT_EXTSTYPE(fit), 6) == 0)) && + (IM_PL(im) != NULL)) + subtype = FK_PLIO + + if (FIT_EXTTYPE(fit) != EOS && group != -1) { + if (strncmp (FIT_EXTTYPE(fit), "IMAGE", 5) != 0 && + strncmp (FIT_EXTTYPE(fit), "SIMPLE", 6) != 0 && + subtype == 0) { + call syserr (SYS_FXFUPHBEXTN) + } + } + + if (FKS_OVERWRITE(fit) == YES) { + if (group == 0) { + # We are overwriting the main unit. + FIT_NEWIMAGE(fit) = YES + } + + group = -1 + acmode = NEW_IMAGE + + if (IM_PFD(im) == NULL) + call fxf_overwrite_unit (fit, im) + + call strcpy (IM_PIXFILE(im), Memc[fits_file], SZ_FNAME) + + } else + call strcpy (IM_HDRFILE(im), Memc[fits_file], SZ_FNAME) + + # Calculate the header offset corresponding to group number 'group'. + FIT_IM(fit) = im + hdr_off = fxf_hdr_offset (group, fit, IM_PFD(im), acmode) + + # If the pixfile has not been created, open new one. This could + # happen if the don't write any pixels to the data portion of the file. + + if (IM_PFD(im) == NULL && (acmode == NEW_COPY || acmode == NEW_IMAGE)) { + FIT_NAXIS(fit) = 0 + if (FIT_NEWIMAGE(fit) == YES) + hdr_acmode = NEW_FILE + else { + # We want to append a new extension with no data. + hdr_acmode = READ_WRITE + } + } else { + call close(IM_PFD(im)) + hdr_acmode = READ_WRITE + } + + append = (acmode == NEW_IMAGE || acmode == NEW_COPY) + + # Calculate header difference. The difference between the original + # header length at open time and now. The user could have added or + # deleted header keywords. + + call fxf_header_diff (im, group, acmode, hdr_off, diff, nchars_ua) + + # PLIO + if (subtype == FK_PLIO && append) + diff = 0 + + # Adjust header only when we need to expand. We fill with trailing + # blanks in case diff .gt. 0. (Reduce header size). + + adjust_header = (diff < 0) + if (adjust_header && FIT_EXPAND(fit) == NO) { + call syserr (SYS_FXFUPHEXP) + adjust_header = false + } + + overwrite = (FKS_OVERWRITE(fit) == YES) + if (adjust_header || overwrite) { + # We need to change the size of header portion in the middle of + # the file. The best thing to do is to make a copy in the output + # filename directory. + + i = strlen (IM_PIXFILE(im)) + nchars = fnldir (IM_PIXFILE(im), Memc[outname], SZ_PATHNAME) + if (nchars > 80 && i > 100) { + i = stridxs ("!", Memc[outname]) + call strcpy ("tmp$", Memc[outname+i], SZ_PATHNAME-i) + } + call strcpy (Memc[outname], Memc[tmp2], SZ_FNAME) + call mktemp ("fx", Memc[tmp1], SZ_PATHNAME) + call strcat (".fits", Memc[tmp1], SZ_PATHNAME) + call strcat ("A", Memc[outname], SZ_PATHNAME) + call strcat (Memc[tmp1], Memc[outname], SZ_PATHNAME) + call strcat ("B", Memc[tmp2], SZ_PATHNAME) + call strcat (Memc[tmp1], Memc[tmp2], SZ_PATHNAME) + in_fd = open (Memc[fits_file], READ_ONLY, BINARY_FILE) + if (access (Memc[outname], 0, 0) == YES) + call delete (Memc[outname]) + hdr_fd = open (Memc[outname], NEW_FILE, BINARY_FILE) + + # Now expand the current group at least one block of 36 cards + # and guarantee that the other groups in the file will have at + # least 'nlines' of blank cards at the end of the header unit. + + nlines= FKS_PADLINES(fit) + IM_HFD(im) = in_fd + + if (adjust_header && acmode != NEW_COPY && + FIT_XTENSION(fit) == YES) { + nbks = -diff/1440 # number of blocks to expand + call fxf_expandh (in_fd, hdr_fd, nlines, group, nbks, + hdr_off, pixoff) + nchars_ua = pixoff - hdr_off + # Reload PHU from file if necessary + call fxf_not_incache(im) + poff = FIT_PIXPTR(fit) + Memi[poff+group] = pixoff + } else { + if (append) + grp_pix_off = FIT_PIXOFF(fit) + else { + # Reload PHU from file if necessary + call fxf_not_incache(im) + grp_pix_off = Memi[FIT_PIXPTR(fit)+group] + } + call fxf_make_adj_copy (in_fd, hdr_fd, + hdr_off, grp_pix_off, nchars_ua) + } + diff = 0 + group = -1 + + # Reset the time so we can read a fresh header next time. + call fxf_set_cache_time (im, overwrite) + } else { + hdr_fd = open (Memc[fits_file], hdr_acmode, BINARY_FILE) + # Do not clear if we are creating a Bintable with type PLIO_1. + if (subtype != FK_PLIO) + IM_PFD(im) = NULL + IM_HFD(im) = NULL + } + + if (FIT_NEWIMAGE(fit) == YES) + call seek (hdr_fd, BOF) + else if (hdr_off != 0) + call seek (hdr_fd, hdr_off) + + if (acmode == NEW_COPY) + call fxf_setbitpix (im, fit) + + # Lets changed the value of FIT_MTIME that will be used as the mtime for + # this updated file. This time them will be different in other + # executable's FITS cache, hence rereading the PHU. + # We need to use FIT_MTIME since it reflec the value of keyword + # IRAF_TLM which could have just recently been modified, hence adding + # the 4 seconds. + + if (abs(FIT_MTIME(fit) - clktime(long(0))) > 60) + FIT_MTIME(fit) = clktime(long(0)) + + # We cannot use clktime() directly since the previuos value + # of FIT_MTIME might already have a 4 secs increment. + + FIT_MTIME(fit) = FIT_MTIME(fit) + 4 + + # Now write default cards and im_userarea to disk. + nchars_ua = nchars_ua + diff + call fxf_write_header (im, fit, hdr_fd, nchars_ua, group) + + size = fstatl (hdr_fd, F_FILESIZE) + npad = FITS_BLOCK_CHARS - mod(size,FITS_BLOCK_CHARS) + + # If we are appending a new extension, we need to write padding to + # 2880 bytes blocks at the end of the file. + + if (mod(npad,FITS_BLOCK_CHARS) > 0 && + (FIT_NEWIMAGE(fit) == YES || append)) { + call amovki (0, Memi[mii], npad) + call flush (hdr_fd) + call seek (hdr_fd, EOF) + call write (hdr_fd, Memi[mii], npad) + } + call flush (hdr_fd) + + # Now open the original file and skip to the beginning of (group+1) + # to begin copying into hdr_fd. (end of temporary file in tmp$). + + if (FKS_OVERWRITE(fit) == YES) { + if (overwrite) { + call close (in_fd) + if (access (IM_PIXFILE(im), 0, 0) == YES) + call delete (IM_PIXFILE(im)) + call strcpy (Memc[outname], IM_PIXFILE(im), SZ_FNAME) + } + + in_fd = open (IM_HDRFILE(im), READ_ONLY, BINARY_FILE) + group = FIT_GROUP(fit) + call fxf_not_incache (im) + in_off = Memi[FIT_HDRPTR(fit)+group+1] + call seek (hdr_fd, EOF) + call seek (in_fd, in_off) + size = FITS_BLOCK_CHARS + + while (read (in_fd, Memi[mii], size) != EOF) + call write (hdr_fd, Memi[mii], size) + + call close (hdr_fd) + call close (in_fd) + + call fxf_ren_tmp (IM_PIXFILE(im), IM_HDRFILE(im), Memc[tmp2], 1, 1) + + # Change the acmode so we can change the modification and + # this way reset the cache for this file. + + IM_ACMODE(im) = READ_WRITE + call fxf_over_delete(im) + + } else { + if (adjust_header || overwrite) + call close (in_fd) + call close (hdr_fd) + + # If the header has been expanded then rename the temp file + # to the original name. + if (adjust_header) + call fxf_ren_tmp (Memc[outname], IM_PIXFILE(im), + Memc[tmp2], 1, 1) + } + + # Make sure we reset the modification time for the cached header + # since we have written a new version. This way the header will + # be read from disk next time the file is accessed. + + if (IM_ACMODE(im) == READ_WRITE || overwrite) { + # The modification time of a file in the cache can be different + # from another mod entry in another executable. We need to make + # sure that the mod time has changed in more than a second so that + # the other executable can read the header from disk and not + # from the cache entry. The FIT_MTIME value has already been + # changed by adding 4 seconds. (See above). + + call futime (IM_HDRFILE(im), NULL, FIT_MTIME(fit)) +# call futime (IM_HDRFILE(im), NULL, clktime(long(0))+4) + } + + if (FIT_GROUP(fit) == 0 || FIT_GROUP(fit) == -1) + call fxf_set_cache_time (im, false) + + # See if we need to add or change the value of EXTEND in the PHU. + if (FIT_XTENSION(fit) == YES && + (FIT_EXTEND(fit) == NO_KEYW || FIT_EXTEND(fit) == NO)) { + call fxf_update_extend (im) + } + + call sfree (sp) +end + + +# FXF_HDR_OFFSET -- Function to calculate the header offset for group number +# 'group'. + +int procedure fxf_hdr_offset (group, fit, pfd, acmode) + +int group #I extension number +pointer fit #I fits descriptor +pointer pfd #I pixel file descriptor +int acmode #I image acmode + +int hdr_off + +begin + if (FIT_NEWIMAGE(fit) == YES) + return (0) + + # Look for the beginning of the current group. + if (group == -1) { + # We are appending or creating a new FITS IMAGE. + hdr_off = FIT_EOFSIZE(fit) + } else { + call fxf_not_incache (FIT_IM(fit)) + hdr_off = Memi[FIT_HDRPTR(fit)+group] + } + + # If pixel file descriptor is empty for a newcopy or newimage + # in an existent image then the header offset is EOF. + + if (pfd == NULL && (acmode == NEW_COPY || acmode == NEW_IMAGE)) + hdr_off = EOF + + return (hdr_off) +end + + +# FXF_HEADER_DIFF -- Get the difference between the original header at open +# time and the one at closing time. + +procedure fxf_header_diff (im, group, acmode, hdr_off, diff, ualen) + +pointer im #I image descriptor +int group #I extension number +int acmode #I emage acmode +int hdr_off #I header offset for group +int diff #O difference +int ualen #O new header length + +char temp[LEN_CARD] +pointer hoff, poff, sp, pb, tb +int ua, fit, hdr_size, pixoff, clines, ulines, len, padlines +int merge, usize, excess, nheader_cards, rp, inherit, kmax, kmin +int strlen(), imaccf(), imgeti(), strcmp(), idb_findrecord() +int btoi(), strncmp() +bool imgetb() + +errchk open, fcopyo + +begin + fit = IM_KDES(im) + inherit = NO + + FIT_INHERIT(fit) = FKS_INHERIT(fit) + + # In READ_WRITE mode get the UA value of INHERIT only if it has + # change after _open(). + + if (acmode == READ_WRITE) { + if (imaccf (im, "INHERIT") == YES) { + inherit = btoi (imgetb (im, "INHERIT")) + if (inherit != FKS_INHERIT(fit)) + FIT_INHERIT(fit) = inherit + } + } + + # Allow inheritance only for extensions. + inherit = FIT_INHERIT(fit) + if (FIT_GROUP(fit) == 0) { + inherit = NO + FIT_INHERIT(fit) = inherit + } + # Scale the pixel offset to be zero base rather than the EOF base. + if (FIT_NEWIMAGE(fit) == NO) { + pixoff = FIT_PIXOFF(fit) - FIT_EOFSIZE(fit) + } else { + if ((hdr_off == EOF || hdr_off == 0)&& + (IM_NDIM(im) == 0 || FIT_NAXIS(fit) == 0)) { + diff = 0 + return + } + pixoff = FIT_PIXOFF(fit) - 1 + } + + ua = IM_USERAREA(im) + + if (FIT_NEWIMAGE(fit) == NO && inherit == YES) { + # Form an extension header by copying cards in the UA that + # do not belong in the global header nor in the old + # extension header if the image is open READ_WRITE. + + # Check if the file is still in cache. We need CACHELEN and + # CACHEHDR. + + call fxf_not_incache (im) + + len = strlen (Memc[ua]) + ulines = len / LEN_UACARD + clines = FIT_CACHEHLEN(fit) / LEN_UACARD + + call smark (sp) + call salloc (tb, len+1, TY_CHAR) + + # Now select those lines in UA that are not in fit_cache and + # put them in 'pb'. + + pb = tb + merge = NO + call fxf_match_str (ua, ulines, + FIT_CACHEHDR(fit), clines, merge, pb) + Memc[pb] = EOS + ualen = strlen (Memc[tb]) + + # Now copy the buffer pointed by 'pb' to UA. + call strcpy (Memc[tb], Memc[ua], ualen) + + call sfree (sp) + } + + # See also fitopix.x for an explanation of this call. + call fxf_mandatory_cards (im, nheader_cards) + + kmax = idb_findrecord (im, "DATAMAX", rp) + kmin = idb_findrecord (im, "DATAMIN", rp) + + if (IM_LIMTIME(im) < IM_MTIME(im)) { + # Keywords should not be in the UA. + if (kmax > 0) + call imdelf (im, "DATAMAX") + if (kmin > 0) + call imdelf (im, "DATAMIN") + + } else { + # Now update the keywords. If they are not in the UA we need + # to increase the number of mandatory cards. + + if (kmax == 0) + nheader_cards = nheader_cards + 1 + if (kmin == 0) + nheader_cards = nheader_cards + 1 + } + + # Determine if OBJECT or IM_TITLE have changed. IM_TITLE has + # priority. + + # If FIT_OBJECT is empty, then there was no OBJECT card at read + # time. If OBJECT is present now, then it was added now. If OBJECT + # was present but not now, the keyword was deleted. + + temp[1] = EOS + if (imaccf (im, "OBJECT") == YES) { + call imgstr (im, "OBJECT", temp, LEN_CARD) + # If its value is blank, then temp will be NULL + if (temp[1] == EOS) + call strcpy (" ", temp, LEN_CARD) + } + + if (temp[1] != EOS) + call strcpy (temp, FIT_OBJECT(fit), LEN_CARD) + else + nheader_cards = nheader_cards - 1 + + if (FIT_OBJECT(fit) == EOS) { + if (strcmp (IM_TITLE(im), FIT_TITLE(fit)) != 0) { + call strcpy (IM_TITLE(im), FIT_OBJECT(fit), LEN_CARD) + # The OBJECT keyword will be added. + nheader_cards = nheader_cards + 1 + } + } else { + # See if OBJECT has been deleted from UA. + if (temp[1] == EOS) + FIT_OBJECT(fit) = EOS + if (strcmp (IM_TITLE(im), FIT_TITLE(fit)) != 0) + call strcpy (IM_TITLE(im), FIT_OBJECT(fit), LEN_CARD) + } + + + # Too many mandatory cards if we are using the PHU in READ_WRITE mode. + # Because fxf_mandatory_cards gets call with FIT_NEWIMAGE set to NO, + # i.e. an extension. (12-9=3) + + if (FIT_XTENSION(fit) == NO && FIT_NEWIMAGE(fit) == NO) + nheader_cards = nheader_cards - 3 + + if (FIT_NEWIMAGE(fit) == NO && FIT_XTENSION(fit) == YES) { + + # Now take EXTNAME and EXTVER keywords off the UA if they are in + # there. The reason being they can be out of order. + + iferr (call imgstr (im, "EXTNAME", FIT_EXTNAME(fit), LEN_CARD)) { + FIT_EXTNAME(fit) = EOS + if (FKS_EXTNAME(fit) != EOS) { + call strcpy (FKS_EXTNAME(fit), FIT_EXTNAME(fit), LEN_CARD) + } else { + # We will not create EXTNAME keyword in the output header + nheader_cards = nheader_cards - 1 + } + } else { + call imdelf (im, "EXTNAME") + nheader_cards = nheader_cards + 1 + } + + if (imaccf (im, "EXTVER") == YES) { + FIT_EXTVER(fit) = imgeti (im, "EXTVER") + call imdelf (im, "EXTVER") + nheader_cards = nheader_cards + 1 + } + if (imaccf (im, "PCOUNT") == YES) { + call imdelf (im, "PCOUNT") + nheader_cards = nheader_cards + 1 + } + if (imaccf (im, "GCOUNT") == YES) { + call imdelf (im, "GCOUNT") + nheader_cards = nheader_cards + 1 + } + + if (IS_INDEFL(FIT_EXTVER(fit)) && !IS_INDEFL(FKS_EXTVER(fit))) + FIT_EXTVER(fit) = FKS_EXTVER(fit) + } + + # Finally if we are updating a BINTABLE with a PLIO_1 mask we need + # to add 3 to the mandatory cards since TFIELDS, TTYPE1, nor + # TFORM1 are included. ### Ugh!! + # Also add the Z cards. + + if (strncmp ("PLIO_1", FIT_EXTSTYPE(fit), 6) == 0) + nheader_cards = nheader_cards + 3 + 6 + IM_NDIM(im)*2 + + # Compute current header size rounded to a header block. + usize = strlen (Memc[ua]) + len = (usize / LEN_UACARD + nheader_cards) * LEN_CARD + len = FITS_LEN_CHAR(len / 2) + + # Ask for more lines if the header can or needs to be expanded. + padlines = FKS_PADLINES(fit) + + # Here we go over the FITS header area already allocated? + if (acmode == READ_WRITE || acmode == WRITE_ONLY) { + call fxf_not_incache(im) + hoff = FIT_HDRPTR(fit) + poff = FIT_PIXPTR(fit) + hdr_size = Memi[poff+group] - Memi[hoff+group] + ualen = len + diff = hdr_size - ualen + # If the header needs to be expanded add on the pad lines. + if (diff < 0) { + ualen = (usize/LEN_UACARD + nheader_cards + padlines) * LEN_CARD + ualen = FITS_LEN_CHAR(ualen / 2) + } + diff = hdr_size - ualen + } else if ((hdr_off == EOF || hdr_off == 0) && + (IM_NDIM(im) == 0 || FIT_NAXIS(fit) == 0)) { + hdr_size = len + ualen = len + } else { + hdr_size = pixoff + # The header can expand so add on the pad lines. + ualen = (usize / LEN_UACARD + nheader_cards + padlines) * LEN_CARD + ualen = FITS_LEN_CHAR(ualen / 2) + diff = hdr_size - ualen + } + + if (diff < 0 && FIT_EXPAND(fit) == NO) { + # We need to reduce the size of the UA becuase we are not + # going to expand the header. + excess = mod (nheader_cards * 81 + usize, 1458) + excess = excess + (((-diff-1400)/1440)*1458) + Memc[ua+usize-excess] = EOS + usize = strlen (Memc[ua]) + ualen = (usize / LEN_UACARD + nheader_cards) * LEN_CARD + ualen = FITS_LEN_CHAR(ualen / 2) + } +end + + +# FXF_WRITE_HDR -- Procedure to write header unit onto the PHU or EHU. + +procedure fxf_write_header (im, fit, hdr_fd, nchars_ua, group) + +pointer im #I image structure +pointer fit #I fits structure +int hdr_fd #I FITS header file descriptor +int nchars_ua #I header size +int group #I group number + +char temp[SZ_FNAME] +bool xtension, ext_append +pointer sp, spp, mii, rp, uap +char card[LEN_CARD], blank, keyword[SZ_KEYWORD], datestr[SZ_DATESTR] +int iso_cutover, n, i, sz_rec, up, nblanks, acmode, nbk, len, poff, diff +int pos, pcount, depth, subtype, maxlen, ndim + +long clktime() +int imaccf(), strlen(), fxf_ua_card(), envgeti() +int idb_findrecord(), strncmp(), btoi() +bool fxf_fpl_equald(), imgetb(), itob() +long note() +errchk write + +begin + call smark (sp) + call salloc (spp, FITS_BLOCK_CHARS*5, TY_CHAR) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + + # Write out the standard, reserved header parameters. + n = spp + blank = ' ' + acmode = FIT_ACMODE(fit) + ext_append = ((acmode == NEW_IMAGE || acmode == NEW_COPY) && + (FKS_EXTNAME(fit) != EOS || !IS_INDEFL (FKS_EXTVER(fit)))) + + xtension = (FIT_XTENSION(fit) == YES) + if (FIT_NEWIMAGE(fit) == YES) + xtension = false + + subtype =0 + if ((FKS_SUBTYPE(fit) == FK_PLIO || + (strncmp("PLIO_1", FIT_EXTSTYPE(fit), 6) == 0)) && + IM_PL(im) != NULL) { + + subtype = FK_PLIO + ext_append = true + } + + # PLIO. Write BINTABLE header for a PLIO mask. + if (subtype == FK_PLIO) { + + if (IM_PFD(im) != NULL) { + call fxf_plinfo (im, maxlen, pcount, depth) + + # If we old heap has change in size, we need to + # resize it. + + if (acmode == READ_WRITE && pcount != FIT_PCOUNT(fit)) + call fxf_pl_adj_heap (im, hdr_fd, pcount) + } else { + pcount = FIT_PCOUNT(fit) + depth = DEF_PLDEPTH + } + + ndim = IM_NDIM(im) + call fxf_akwc ("XTENSION", "BINTABLE", 8, "Mask extension", n) + call fxf_akwi ("BITPIX", 8, "Bits per pixel", n) + call fxf_akwi ("NAXIS", ndim, "Number of axes", n) + call fxf_akwi ("NAXIS1", 8, "Number of bytes per line", n) + do i = 2, ndim { + call fxf_encode_axis ("NAXIS", keyword, i) + call fxf_akwi (keyword, IM_LEN(im,i), "axis length", n) + } + call fxf_akwi ("PCOUNT", pcount, "Heap size in bytes", n) + call fxf_akwi ("GCOUNT", 1, "Only one group", n) + + if (imaccf (im, "TFIELDS") == NO) + call fxf_akwi ("TFIELDS", 1, "1 Column field", n) + if (imaccf (im, "TTYPE1") == NO) { + call fxf_akwc ("TTYPE1", "COMPRESSED_DATA", 16, + "Type of PLIO_1 data", n) + } + call sprintf (card, LEN_CARD, "PI(%d)") + call pargi(maxlen) + call fxf_filter_keyw (im, "TFORM1") + len = strlen (card) + call fxf_akwc ("TFORM1", card, len, "Variable word array", n) + + } else { + if (xtension) + call fxf_akwc ("XTENSION", "IMAGE", 5, "Image extension", n) + else + call fxf_akwb ("SIMPLE", YES, "Fits standard", n) + + if (FIT_NAXIS(fit) == 0 || FIT_BITPIX(fit) == 0) + call fxf_setbitpix (im, fit) + + call fxf_akwi ("BITPIX", FIT_BITPIX(fit), "Bits per pixel", n) + call fxf_akwi ("NAXIS", FIT_NAXIS(fit), "Number of axes", n) + + do i = 1, FIT_NAXIS(fit) { + call fxf_encode_axis ("NAXIS", keyword, i) + call fxf_akwi (keyword, FIT_LENAXIS(fit,i), "Axis length", n) + } + + if (xtension) { + call fxf_akwi ("PCOUNT", 0, "No 'random' parameters", n) + call fxf_akwi ("GCOUNT", 1, "Only one group", n) + } else { + if (imaccf (im, "EXTEND") == NO) + i = NO + else { + # Keyword exists but it may be in the wrong position. + # Remove it and write it now. + + i = btoi (imgetb (im, "EXTEND")) + call fxf_filter_keyw (im, "EXTEND") + } + if (FIT_EXTEND(fit) == YES) + i = YES + call fxf_akwb ("EXTEND", i, "File may contain extensions", n) + FIT_EXTEND(fit) = YES + } + } + + # Delete BSCALE and BZERO just in case the application puts them + # in the UA after the pixels have been written. The keywords + # should not be there since the FK does not allow reading pixels + # with BITPIX -32 and BSCALE and BZERO. If the application + # really wants to circumvent this restriction the code below + # will defeat that. The implications are left to the application. + # This fix is put in here to save the ST Hstio interface to be + # a victim of the fact that in v2.12 the BSCALE and BZERO keywords + # are left in the header for the user to see or change. Previous + # FK versions, the keywords were deleted from the UA. + + if ((IM_PIXTYPE(im) == TY_REAL || IM_PIXTYPE(im) == TY_DOUBLE) + && (FIT_TOTPIX(fit) > 0 && FIT_BITPIX(fit) <= 0)) { + + call fxf_filter_keyw (im, "BSCALE") + call fxf_filter_keyw (im, "BZERO") + } + + # Do not write BSCALE and BZERO if they have the default + # values (1.0, 0.0). + + if (IM_PIXTYPE(im) == TY_USHORT) { + call fxf_filter_keyw (im, "BSCALE") + call fxf_akwd ("BSCALE", 1.0d0, + "REAL = TAPE*BSCALE + BZERO", NDEC_REAL, n) + call fxf_filter_keyw (im, "BZERO") + call fxf_akwd ("BZERO", 32768.0d0, "", NDEC_REAL, n) + } else if (FIT_PIXTYPE(fit) != TY_REAL && + FIT_PIXTYPE(fit) != TY_DOUBLE && IM_ACMODE(im) != NEW_COPY) { + # Now we have TY_SHORT or TY_(INT,LONG). + # Check the keywords only if they have non_default values. + + # Do not add the keywords if they have been deleted. + if (!fxf_fpl_equald(1.0d0, FIT_BSCALE(fit), 4)) { + if ((imaccf (im, "BSCALE") == NO) && + fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 4)) { + call fxf_akwd ("BSCALE", FIT_BSCALE(fit), + "REAL = TAPE*BSCALE + BZERO", NDEC_REAL, n) + } + } + if (!fxf_fpl_equald(0.0d0, FIT_BZERO(fit), 4) ) { + if (imaccf (im, "BZERO") == NO && + fxf_fpl_equald (1.0d0, FIT_BZERO(fit), 4)) + call fxf_akwd ("BZERO", FIT_BZERO(fit), "", NDEC_REAL, n) + } + } + + uap = IM_USERAREA(im) + + if (idb_findrecord (im, "ORIGIN", rp) == 0) { + call strcpy (FITS_ORIGIN, temp, LEN_CARD) + call fxf_akwc ("ORIGIN", + temp, strlen(temp), "FITS file originator", n) + } else if (rp - uap > 10*81) { + # Out of place; do not change the value. + call imgstr (im, "ORIGIN", temp, LEN_CARD) + call fxf_filter_keyw (im, "ORIGIN") + call fxf_akwc ("ORIGIN", + temp, strlen(temp), "FITS file originator", n) + } + + if (xtension) { + # Update the cache in case these values have changed + # in the UA. + call fxf_set_extnv (im) + + if (FIT_EXTNAME(fit) != EOS) { + call strcpy (FIT_EXTNAME(fit), temp, LEN_CARD) + call fxf_akwc ("EXTNAME", + temp, strlen(temp), "Extension name", n) + } + if (!IS_INDEFL (FIT_EXTVER(fit))) { + call fxf_akwi ("EXTVER", + FIT_EXTVER(fit), "Extension version", n) + } + if (idb_findrecord (im, "INHERIT", rp) > 0) { + # See if keyword is at the begining of the UA + if (rp - uap > 11*81) { + call fxf_filter_keyw (im, "INHERIT") + call fxf_akwb ("INHERIT", + FIT_INHERIT(fit), "Inherits global header", n) + } else if (acmode != READ_WRITE) + call imputb (im, "INHERIT", itob(FIT_INHERIT(fit))) + } else { + call fxf_akwb ("INHERIT", + FIT_INHERIT(fit), "Inherits global header", n) + } + } + + # Dates after iso_cutover use ISO format dates. + iferr (iso_cutover = envgeti (ENV_ISOCUTOVER)) + iso_cutover = DEF_ISOCUTOVER + + # Encode the "DATE" keyword (records create time of imagefile). + call fxf_encode_date (clktime(long(0)), datestr, SZ_DATESTR, + "ISO", iso_cutover) + len = strlen (datestr) + + if (idb_findrecord (im, "DATE", rp) == 0) { + # Keyword is not in the UA, created with current time + call fxf_akwc ("DATE", + datestr, len, "Date FITS file was generated", n) + } else { + if (acmode == READ_WRITE) { + # Keep the old DATE, change only the IRAF-TLM keyword value + call imgstr (im, "DATE", datestr, SZ_DATESTR) + } + # See if the keyword is out of order. + if (rp - uap > 12*81) { + call fxf_filter_keyw (im, "DATE") + + call fxf_akwc ("DATE", + datestr, len, "Date FITS file was generated", n) + } else + call impstr (im, "DATE", datestr) + } + + # Encode the "IRAF_TLM" keyword (records time of last modification). + if (acmode == NEW_IMAGE || acmode == NEW_COPY) { + FIT_MTIME(fit) = IM_MTIME(im) + } + + call fxf_encode_date (FIT_MTIME(fit), datestr, SZ_DATESTR, "TLM", 2010) +# call fxf_encode_date (clktime(long(0))+4, datestr, SZ_DATESTR, "TLM", 2010) + len = strlen (datestr) + + if (idb_findrecord (im, "IRAF-TLM", rp) == 0) { + call fxf_akwc ("IRAF-TLM", + datestr, len, "Time of last modification", n) + } else if (rp - uap > 13*81) { + call fxf_filter_keyw (im, "IRAF-TLM") + call fxf_akwc ("IRAF-TLM", + datestr, len, "Time of last modification", n) + } else + call impstr (im, "IRAF-TLM", datestr) + + # Create DATA(MIN,MAX) keywords only if they have the real + # min and max of the data. + + if (IM_LIMTIME(im) >= IM_MTIME(im)) { + if (idb_findrecord (im, "DATAMIN", rp) == 0) { + call fxf_akwr ("DATAMIN", + IM_MIN(im), "Minimum data value", NDEC_REAL, n) + } else + call imputr (im, "DATAMIN", IM_MIN(im)) + + if (idb_findrecord (im, "DATAMAX", rp) == 0) { + call fxf_akwr ("DATAMAX", + IM_MAX(im), "Maximum data value",NDEC_REAL, n) + } else + call imputr (im, "DATAMAX", IM_MAX(im)) + } + + if (FIT_OBJECT(fit) != EOS) { + if (idb_findrecord (im, "OBJECT", rp) == 0) { + call fxf_akwc ("OBJECT", FIT_OBJECT(fit), + strlen (FIT_OBJECT(fit)), "Name of the object observed", n) + } else if (rp - uap > 14*81) { + call fxf_filter_keyw (im, "OBJECT") + call fxf_akwc ("OBJECT", FIT_OBJECT(fit), + strlen (FIT_OBJECT(fit)), "Name of the object observed", n) + } else + call impstr (im, "OBJECT", FIT_OBJECT(fit)) + } + + # Write Compression keywords for PLIO BINTABLE. +# if (subtype == FK_PLIO && IM_PFD(im) != NULL && ext_append) { + if (subtype == FK_PLIO) { + call fxf_akwb ("ZIMAGE", YES, "Is a compressed image", n) + call fxf_akwc ("ZCMPTYPE", "PLIO_1", 6, "IRAF image masks", n) + call fxf_akwi ("ZBITPIX", 32, "BITPIX for uncompressed image",n) + + # We use IM_NDIM and IM_LEN here because FIT_NAXIS and _LENAXIS + # are not available for NEW_IMAGE mode. + + ndim = IM_NDIM(im) + call fxf_akwi ("ZNAXIS", ndim, "NAXIS for uncompressed image",n) + do i = 1, ndim { + call fxf_encode_axis ("ZNAXIS", keyword, i) + call fxf_akwi (keyword, IM_LEN(im,i), "Axis length", n) + } + call fxf_encode_axis ("ZTILE", keyword, 1) + call fxf_akwi (keyword, IM_LEN(im,1), "Axis length", n) + do i = 2, ndim { + call fxf_encode_axis ("ZTILE", keyword, i) + call fxf_akwi (keyword, 1, "Axis length", n) + } + call fxf_encode_axis ("ZNAME", keyword, 1) + call fxf_akwc (keyword, "depth", 5, "PLIO mask depth", n) + call fxf_encode_axis ("ZVAL", keyword, 1) + call fxf_akwi (keyword, depth, "Parameter value", n) + } + + # Write the UA now. + up = 1 + nbk = 0 + n = n - spp + sz_rec = 1440 + while (fxf_ua_card (fit, im, up, card) == YES) { + call amovc (card, Memc[spp+n], LEN_CARD) + n = n + LEN_CARD + + if (n == 2880) { + nbk = nbk + 1 + call miipak (Memc[spp], Memi[mii], sz_rec*2, TY_CHAR, MII_BYTE) + call write (hdr_fd, Memi[mii], sz_rec) + n = 0 + } + } + + # Write the last record. + nblanks = 2880 - n + call amovkc (blank, Memc[spp+n], nblanks) + rp = spp+n+nblanks-LEN_CARD + + # If there are blocks of trailing blanks, write them now. + if (n > 0) + nbk = nbk + 1 + diff = nchars_ua - nbk * 1440 + if (diff > 0) { + if (n > 0) { + call miipak (Memc[spp], Memi[mii], sz_rec*2, TY_CHAR, MII_BYTE) + call write (hdr_fd, Memi[mii], sz_rec) + } + + if (group < 0) { + # We are writing blocks of blanks on a new_copy + # image which has group=-1 here. Use diff. + + nbk = diff / 1440 + } else { + pos = note (hdr_fd) + call fxf_not_incache(im) + poff = FIT_PIXPTR(fit) + nbk = (Memi[poff+group] - pos) + nbk = nbk / 1440 + } + call amovkc (blank, Memc[spp], 2880) + call miipak (Memc[spp], Memi[mii], sz_rec*2, TY_CHAR, MII_BYTE) + do i = 1, nbk-1 + call write (hdr_fd, Memi[mii], sz_rec) + + call amovkc (blank, Memc[spp], 2880) + rp = spp+2880-LEN_CARD + } + + call amovc ("END", Memc[rp], 3) + call miipak (Memc[spp], Memi[mii], sz_rec*2, TY_CHAR, MII_BYTE) + call write (hdr_fd, Memi[mii], sz_rec) + # PLIO: write the mask data to the new extension. + if (subtype == FK_PLIO && IM_PFD(im) != NULL) { + call fxf_plwrite (im, hdr_fd) + IM_PFD(im) = NULL + } + + call flush (hdr_fd) + call sfree (sp) +end + + +# FXF_UA_CARD -- Fetch a single line from the user area, trim newlines and +# pad with blanks to size LEN_CARD in order to create an unknown keyword card. +# At present user area information is assumed to be in the form of FITS card +# images, less then or equal to 80 characters and delimited by a newline. + +int procedure fxf_ua_card (fit, im, up, card) + +pointer fit #I points to the fits descriptor +pointer im #I pointer to the IRAF image +int up #I next character in the unknown string +char card[ARB] #O FITS card image + +char cval +int stat, diff +char chfetch() +int strmatch() + +begin + if (chfetch (UNKNOWN(im), up, cval) == EOS) + return (NO) + else { + up = up - 1 + stat = NO + + while (stat == NO) { + diff = up + call fxf_make_card (UNKNOWN(im), up, card, 1, LEN_CARD, '\n') + diff = up - diff + if (card[1] == EOS) + break + + if (strmatch ( card, "^GROUPS ") != 0) + stat = NO + else if (strmatch (card, "^GCOUNT ") != 0) + stat = NO + else if (strmatch (card, "^PCOUNT ") != 0) + stat = NO + else if (strmatch (card, "^BLOCKED ") != 0) + stat = NO + else if (strmatch (card, "^PSIZE ") != 0) + stat = NO + else + stat = YES + } + + return (stat) + } +end + + +# FXF_SETBITPIX -- Set the FIT_BITPIX to the pixel datatype value. + +procedure fxf_setbitpix (im, fit) + +pointer im #I image descriptor +pointer fit #I fit descriptor + +int datatype +errchk syserr, syserrs + +begin + datatype = IM_PIXTYPE(im) + + switch (datatype) { + case TY_SHORT, TY_USHORT: + FIT_BITPIX(fit) = FITS_SHORT + case TY_INT, TY_LONG: + FIT_BITPIX(fit) = FITS_LONG + case TY_REAL: + FIT_BITPIX(fit) = FITS_REAL + case TY_DOUBLE: + FIT_BITPIX(fit) = FITS_DOUBLE + default: + call flush (STDOUT) + call syserr (SYS_FXFUPHBTYP) + } +end + + +# FXF_MAKE_ADJ_COPY -- Copy a FITS file into a new one, changing the size +# of a fits header. + +procedure fxf_make_adj_copy (in_fd, out_fd, hdr_off, pixoff, chars_ua) + +int in_fd #I input FITS descriptor +int out_fd #I output FITS descriptor +int hdr_off #I offset to be beginning of the ua to be resized +int pixoff #I offset to be pixel area following hdroff +int chars_ua #I size of the new UA (user area) in units of chars + +pointer mii, sp +int nk, nblocks, junk, size_ua +errchk read, write +int read() + +begin + call smark (sp) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + + # Number of 1440 chars block up to the beginning of the UA to change. + nblocks = hdr_off / FITS_BLOCK_CHARS + + # Copy everything up to hdroff. + call seek (in_fd, BOF) + do nk = 1, nblocks { + junk = read (in_fd, Memi[mii], FITS_BLOCK_CHARS) + call write (out_fd, Memi[mii], FITS_BLOCK_CHARS) + } + + # Size of the new UA. + size_ua = FITS_LEN_CHAR(chars_ua) + nblocks = size_ua / FITS_BLOCK_CHARS + + # Put a blank new header in the meantime. + call amovki( 0, Memi[mii], FITS_BLOCK_CHARS) + do nk = 1, nblocks + call write (out_fd, Memi[mii], FITS_BLOCK_CHARS) + + # Position after the current input header to continue + # copying. + + call flush (out_fd) + call seek (in_fd, pixoff) + call fcopyo (in_fd, out_fd) + call flush (out_fd) + call sfree (sp) +end + + +# FXF_SET_CACHE_MTIME -- Procedure to reset the modification time on the +# cached entry for the file pointed by 'im'. + +procedure fxf_set_cache_time (im, overwrite) + +pointer im #I image descriptor +bool overwrite #I invalidate entry if true + +pointer sp, hdrfile, fit +long fi[LEN_FINFO] +int finfo(), cindx +errchk syserr, syserrs +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + fit = IM_KDES(im) + + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + if (finfo (Memc[hdrfile], fi) == ERR) + call syserrs (SYS_FOPEN, IM_HDRFILE(im)) + + # Search the header file cache for the named image. + do cindx = 1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + # Reset cache + if (IM_ACMODE(im) == READ_WRITE || overwrite) { + # Invalidate entry. + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fname[1,cindx] = EOS + rf_mtime[cindx] = 0 + rf_fit[cindx] = NULL + + } else { + # While we are appending we want to keep the cache entry + # in the slot. + rf_mtime[cindx] = FI_MTIME(fi) + } + break + } + } + + call sfree (sp) +end + + +# FXF_SET_EXTNV -- Procedure to write UA value of EXTNAME and EXTVER +# into the cache slot. + +procedure fxf_set_extnv (im) + +pointer im #I image descriptor + +pointer fit, sp, hdrfile +int cindx, ig, extn, extv +errchk syserr, syserrs +bool bxtn, bxtv +bool streq() + +include "fxfcache.com" + +begin + fit = IM_KDES(im) + ig = FIT_GROUP(fit) + + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + # Search the header file cache for the named image. + do cindx = 1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + bxtn = (FIT_EXTNAME(fit) != EOS) + bxtv = (!IS_INDEFL (FIT_EXTVER(fit))) + # Reset cache + if (IM_ACMODE(im) == READ_WRITE) { + if (bxtn) { + extn = rf_pextn[cindx] + # Just replace the value + call strcpy (FIT_EXTNAME(fit), Memc[extn+LEN_CARD*ig], + LEN_CARD) + } + if (bxtv) { + extv = rf_pextv[cindx] + # Just replace the value + Memi[extv+ig] = FIT_EXTVER(fit) + } + } + break + } + } + + call sfree (sp) +end + + +# FXF_REN_TMP -- Rename input file to output file. +# +# The output file may already exists in which case it is replaced. +# Because this operation is critical it is heavily error checked and +# has retries to deal with networking cases. + +procedure fxf_ren_tmp (in, out, tmp, ntry, nsleep) + +char in[ARB] #I file to replace output +char out[ARB] #O output file (replaced if it exists) +char tmp[ARB] #I temporary name for in until rename succeeds +int ntry #I number of retries for rename +int nsleep #I Number of seconds to sleep before retry + +int i, stat, err, access(), protect(), errget() +bool replace, prot +pointer errstr + +errchk access, protect, rename, delete, salloc + +begin +#call eprintf ("fxf_ren_tmp (%s, %s, %s, %d %d)\n") +#call pargstr (in) +#call pargstr (out) +#call pargstr (tmp) +#call pargi (ntry) +#call pargi (nsleep) + err = 0; errstr = NULL + + iferr { + # Move original output out of the way. + # Don't delete it in case of an error. + replace = (access (out, 0, 0) == YES) + prot = false + if (replace) { + prot = (protect (out, QUERY_PROTECTION) == YES) + if (prot) + stat = protect (out, REMOVE_PROTECTION) + do i = 0, max(0,ntry) { +#call eprintf ("1 rename (%s, %s)\n") +#call pargstr (out) +#call pargstr (tmp) + ifnoerr (call rename (out, tmp)) { + err = 0 + break + } + if (errstr == NULL) + call salloc (errstr, SZ_LINE, TY_CHAR) + err = errget (Memc[errstr], SZ_LINE) + if (err == 0) + err = SYS_FMKCOPY + call tsleep (nsleep) + } + if (err > 0) + call error (err, Memc[errstr]) + } + + # Now rename the input to the output. + do i = 0, max(0,ntry) { +#call eprintf ("2 rename (%s, %s)\n") +#call pargstr (in) +#call pargstr (out) + ifnoerr (call rename (in, out)) { + err = 0 + break + } + if (errstr == NULL) + call salloc (errstr, SZ_LINE, TY_CHAR) + err = errget (Memc[errstr], SZ_LINE) + if (err == 0) + err = SYS_FMKCOPY + call tsleep (nsleep) + } + if (err > 0) + call error (err, Memc[errstr]) + if (prot) + stat = protect (out, SET_PROTECTION) + + # If the rename has succeeded delete the original data. + if (replace) { +#call eprintf ("delete (%s)\n") +#call pargstr (tmp) + call delete (tmp) + } + } then + call erract (EA_ERROR) +end + + +# FXF_OVER_TMP -- Rename an entry from the cache. + +procedure fxf_over_delete (im) + +pointer im #I image descriptor + +pointer fname, sp +bool streq() +int cindx +include "fxfcache.com" + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call fpathname (IM_HDRFILE(im), Memc[fname], SZ_PATHNAME) + + # Remove the image from the FITS cache if found. + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + if (streq (Memc[fname], rf_fname[1,cindx])) { + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fit[cindx] = NULL + } + } + + call sfree (sp) +end + + +# FXF_UPDATE_EXTEND -- Add or change the value of the EXTEND keyword in PHU. +# Sometimes the input PHU has not been created by the FK and the EXTEND keyw +# might not be there as the standard tells when an extension is appended +# to a file. + +procedure fxf_update_extend (im) + +pointer im #I image descriptor + +pointer sp, hdrfile, tmp1, tmp2 +int fd, fdout, i, nch, nc, cfit +char line[LEN_CARD], blank, cindx +bool streq() +int open(), naxis, read(), strncmp(), fnroot() +long note() +errchk open, fxf_ren_tmp + +include "fxfcache.com" +define cfit_ 91 + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + fd = open (IM_HDRFILE(im), READ_WRITE, BINARY_FILE) + + # Look for EXTEND keyword and change its value in place. + nc = 0 + while (read (fd, line, 40) != EOF) { + nc = nc + 1 + call achtbc (line, line, LEN_CARD) + if (strncmp ("EXTEND ", line, 8) == 0) { + line[30] = 'T' + call seek (fd, note(fd)-40) + call achtcb (line, line, LEN_CARD) + call write (fd, line, 40) + call close (fd) + goto cfit_ + } else if (strncmp ("END ", line, 8) == 0) + break + } + + # The EXTEND card is not in the header. Insert it after the + # last NAXISi in a temporary file, rename after this. + + call salloc (tmp1, SZ_FNAME, TY_CHAR) + i = fnroot (IM_HDRFILE(im), Memc[tmp1], SZ_FNAME) + call mktemp (Memc[tmp1], Memc[tmp1], SZ_FNAME) + + fdout = open (Memc[tmp1], NEW_FILE, BINARY_FILE) + + call seek (fd, BOF) + do i = 0, nc-2 { + nch = read (fd, line, 40) + call write (fdout, line, 40) + call achtbc(line, line, LEN_CARD) + if (strncmp ("NAXIS ", line, 8) == 0) + call fxf_geti (line, naxis) + else if (strncmp ("NAXIS", line, 5) == 0){ + if ((line[6] - '0') == naxis) { + # Now create the EXTEND card in the output file. + call fxf_encodeb ("EXTEND", YES, line, + "File may contain extensions") + call achtcb (line, line , LEN_CARD) + call write (fdout, line, 40) + } + } + } + + if (mod (nc, 36) == 0) { + # We have to write one END card and 35 blank card. + blank = ' ' + call amovkc (blank, line, 80) + call amovc ("END", line, 3) + call achtcb (line, line , LEN_CARD) + call write (fdout, line, 40) + call amovkc (blank, line, 80) + call achtcb (line, line , LEN_CARD) + for (i=1; i < 36; i=i+1) + call write (fdout, line, 40) + } else { + nch = read (fd, line, 40) + call write (fdout, line, 40) + } + + # Read one more line to synchronize. + nch = read (fd, line, 40) + + # Copy the rest of the file. + call fcopyo (fd, fdout) + + call close (fd) + call close (fdout) + + call salloc (tmp2, SZ_FNAME, TY_CHAR) + call strcpy (Memc[tmp1], Memc[tmp2], SZ_FNAME) + call strcat ("A", Memc[tmp2], SZ_FNAME) + call fxf_ren_tmp (Memc[tmp1], IM_HDRFILE(im), Memc[tmp2], 1, 1) + +cfit_ + # Now reset the value in the cache + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + + # Search the header file cache for the named image. + do cindx = 1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + # Reset cache + cfit = rf_fit[cindx] + FIT_EXTEND(cfit) = YES + break + } + } + + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfupk.x b/sys/imio/iki/fxf/fxfupk.x new file mode 100644 index 00000000..b6b158ae --- /dev/null +++ b/sys/imio/iki/fxf/fxfupk.x @@ -0,0 +1,155 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <mach.h> +include "fxf.h" + +# FXFUPK.X -- Routines to upack an IEEE vector into native format. +# +# fxf_unpack_data (cbuf, npix, pixtype, bscale, bzero) +# fxf_altmr (a, b, npix, bscale, bzero) +# fxf_altmd (a, b, npix, bscale, bzero) +# fxf_altmu (a, b, npix) +# fxf_astmr (a, b, npix, bscale, bzero) + +define NBITS_DOU (SZB_CHAR * SZ_DOUBLE) +define IOFF 1 + + +# FITUPK -- Unpack cbuf in place from FITS binary format to local machine type. + +procedure fxf_unpack_data (cbuf, npix, pixtype, bscale, bzero) + +char cbuf[ARB] #U buffer with input,output data +int npix #I number of pixels in buffer +int pixtype #I input pixtype +double bscale #I scale factor to applied to input data +double bzero #I offset to applied to input data + +int nchars, nbytes +bool fp_equald() +errchk syserr + +include <szpixtype.inc> + +begin + nchars = npix * pix_size[pixtype] + nbytes = nchars * SZB_CHAR + + switch (pixtype) { + case TY_SHORT, TY_USHORT: + if (BYTE_SWAP2 == YES) + call bswap2 (cbuf, 1, cbuf, 1, nbytes) + if (pixtype == TY_USHORT) + call fxf_altmu (cbuf, cbuf, npix) + + case TY_INT, TY_LONG: + if (BYTE_SWAP4 == YES) + call bswap4 (cbuf, 1, cbuf, 1, nbytes) + + case TY_REAL: + ### Rather than perform this test redundantly a flag should be + ### passed in from the high level code telling the routine whether + ### or not it should apply the scaling. Testing for floating + ### point equality (e.g. bscale != 1.0) is not portable. + + if (!fp_equald(bscale,1.0d0) || !fp_equald(bzero,0.0d0)) { + if (BYTE_SWAP4 == YES) + call bswap4 (cbuf, 1, cbuf, 1, nbytes) + call iscl32 (cbuf, cbuf, npix, bscale, bzero) + } else + call ieevupkr (cbuf, cbuf, npix) + + case TY_DOUBLE: + ### Same as above. + if (!fp_equald(bscale,1.0d0) || !fp_equald(bzero,0.0d0)) { + if (BYTE_SWAP4 == YES) + call bswap4 (cbuf, 1, cbuf, 1, nbytes) + call iscl64 (cbuf, cbuf, npix, bscale, bzero) + } else + call ieevupkd (cbuf, cbuf, npix) + + default: + call syserr (SYS_FXFUPKDTY) + } +end + + +# FXF_ALTMR -- Scale a real array. + +procedure fxf_altmr (a, b, npix, bscale, bzero) + +int a[ARB] #I input array +real b[ARB] #O output array +int npix #I number of pixels +double bscale, bzero #I scaling parameters + +int i + +begin + do i = 1, npix + b[i] = a[i] * bscale + bzero +end + + +# FXF_ALTMD -- Scale a double array. + +procedure fxf_altmd (a, b, npix, bscale, bzero) + +int a[ARB] #I input array +double b[ARB] #O output array +int npix #I number of pixels +double bscale, bzero #I scaling parameters + +int i + +begin + ### int and double are not the same size so if this operation is + ### to allow an in-place conversion it must go right to left instead + ### of left to right. + + do i = npix, 1, -1 + b[i] = a[i] * bscale + bzero +end + + +# FXF_ALTMU -- Scale an array to unsigned short. + +procedure fxf_altmu (a, b, npix) + +short a[ARB] #I input array +char b[ARB] #O output array +int npix #I number of pixels + +int i +pointer sp, ip + +begin + call smark (sp) + call salloc (ip, npix+1, TY_INT) + + do i = 1, npix + Memi[ip+i] = a[i] + 32768 + + call achtlu (Memi[ip+1], b, npix) + call sfree (sp) +end + + +# FXF_ASTMR -- Scale an input short array into a real. + +procedure fxf_astmr (a, b, npix, bscale, bzero) + +short a[ARB] #I input array +real b[ARB] #O output array +int npix #I number of pixels +double bscale, bzero #I scaling parameters + +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] * bscale + bzero +end + + diff --git a/sys/imio/iki/fxf/mkpkg b/sys/imio/iki/fxf/mkpkg new file mode 100644 index 00000000..859d6f47 --- /dev/null +++ b/sys/imio/iki/fxf/mkpkg @@ -0,0 +1,42 @@ +# Build or update the FITS kernel. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + fxfaccess.x fxf.h + fxfaddpar.x <imhdr.h> <imio.h> <mach.h> fxf.h + fxfclose.x fxf.h <imhdr.h> <imio.h> + fxfcopy.x <error.h> + fxfctype.x fxf.h <ctype.h> + fxfdelete.x <error.h> <imhdr.h> fxf.h fxfcache.com + fxfencode.x fxf.h <time.h> + fxfexpandh.x fxf.h fxfcache.com <fset.h> <imhdr.h> <imio.h>\ + <mach.h> <mii.h> + fxfget.x fxf.h <ctype.h> + fxfhextn.x fxf.h <imhdr.h> <imio.h> + fxfksection.x <error.h> fxf.h <ctotok.h> <imhdr.h> <lexnum.h> + fxfmkcard.x + fxfnull.x fxf.h + fxfopen.x fxf.h fxfcache.com <error.h> <imhdr.h> <imio.h>\ + fxfcache.com <finfo.h> <fset.h> <mach.h> <mii.h>\ + <pmset.h> + fxfopix.x fxf.h <fset.h> <imhdr.h> <imio.h> <error.h> <mach.h> + fxfpak.x fxf.h <mach.h> + fxfplread.x fxf.h <imhdr.h> <imio.h> <mach.h> <plset.h> + fxfplwrite.x fxf.h <imio.h> <mach.h> <mii.h> <plset.h> <pmset.h>\ + <imhdr.h> + fxfrcard.x fxf.h <mii.h> + fxfrdhdr.x fxf.h <imhdr.h> <imio.h> <mach.h> + fxfrename.x <error.h> fxf.h fxfcache.com + fxfrfits.x fxf.h fxfcache.com <ctype.h> <finfo.h> <fset.h>\ + <imhdr.h> <imio.h> <imset.h> <mach.h> <time.h> + fxfupdhdr.x fxf.h <fio.h> <fset.h> <imhdr.h> <imio.h>\ + fxfcache.com <error.h> <finfo.h> <mach.h> <mii.h>\ + <time.h> + fxfupk.x fxf.h <mach.h> + zfiofxf.x fxf.h <fio.h> <fset.h> <imhdr.h> <imio.h> <knet.h>\ + <mach.h> + ; diff --git a/sys/imio/iki/fxf/zfiofxf.x b/sys/imio/iki/fxf/zfiofxf.x new file mode 100644 index 00000000..97b36264 --- /dev/null +++ b/sys/imio/iki/fxf/zfiofxf.x @@ -0,0 +1,546 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <knet.h> +include <fio.h> +include <fset.h> +include <imio.h> +include <imhdr.h> +include "fxf.h" + +# ZFIOFXF -- FITS kernel virtual file driver. This maps the actual +# FITS file into the virtual pixel file expected by IMIO. + + +# FXFZOP -- Open the file driver for i/o. The filename has appended the +# string "_nnnnn", where 'nnnnn' is the FIT descriptor to the structure +# defined in "fit.h". + +procedure fxfzop (pkfn, mode, status) + +char pkfn[ARB] #I packed virtual filename from FIO +int mode #I file access mode (ignored) +int status #O output status - i/o channel if successful + +pointer im, fit +int ip, indx, channel, strldx(), ctoi() +bool lscale, lzero, bfloat, fxf_fpl_equald() +char fname[SZ_PATHNAME] + +begin + # Separate the FIT descriptor from the file name. + call strupk (pkfn, fname, SZ_PATHNAME) + + ip = strldx ("_", fname) + indx = ip + 1 + if (ctoi (fname, indx, fit) <= 0) { + status = ERR + return + } + + # Determine if we have a Fits Kernel non supported + # data format; i.e. Bitpix -32 or -64 and BSCALE and/or + # BZERO with non default values. + + ### Only "low level" routines can be falled from a file driver: + ### high level routines like syserr cannot be used due to + ### recursion/reentrancy problems. + # We are calling syserrs at this level because we want to + # give the application the freedom to manipulate the FITS header + # at will and not imposing restriction at that level. + + im = FIT_IM(fit) + lscale = fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 1) + lzero = fxf_fpl_equald (0.0d0, FIT_BZERO(fit), 1) + + # Determine if scaling is necessary. + #bfloat = (!lscale || !lzero) + #if (bfloat && (FIT_BITPIX(fit) == -32 || FIT_BITPIX(fit) == -64)) { + # FIT_IOSTAT(fit) = ERR + # #call syserrs (SYS_FXFRDHSC,IM_HDRFILE(im)) + # status = ERR + # return + #} + + fname[ip] = EOS + call strpak (fname, fname, SZ_PATHNAME) + + # Open the file. + call zopnbf (fname, mode, channel) + if (channel == ERR) { + status = ERR + return + } + + status = fit + FIT_IO(fit) = channel +end + + +# FITZCL -- Close the FIT binary file driver. + +procedure fxfzcl (chan, status) + +int chan #I FIT i/o channel +int status #O output status + +pointer fit + +begin + fit = chan + call zclsbf (FIT_IO(fit), status) +end + + +# FXFZRD -- Read the FIT file (header and pixel data). An offset pointer +# needs to be set to point to the data portion of the file. If we are reading +# pixel data, the scale routine fxf_unpack_data is called. We need to keep +# a counter (npix_read) with the current number of pixels unpacked since we +# don't want to convert beyond the total number of pixels; where the last +# block of data read can contain zeros or garbage up to a count of 2880 bytes. + +procedure fxfzrd (chan, obuf, nbytes, boffset) + +int chan #I FIT i/o channel +char obuf[ARB] #O output buffer +int nbytes #I nbytes to be read +int boffset #I file offset at which read commences + +pointer fit, im +int ip, pixtype, nb +int status, totpix, npix +int datasizeb, pixoffb, nb_skipped, i +double dtemp +real rtemp, rscale, roffset + +include <szpixtype.inc> + +begin + fit = chan + im = FIT_IM(fit) + FIT_IOSTAT(fit) = OK + + totpix = IM_PHYSLEN(im,1) + do i = 2, IM_NPHYSDIM(im) + totpix = totpix * IM_PHYSLEN(im,i) + + if (FIT_ZCNV(fit) == YES) { + if (FIT_PIXTYPE(fit) != TY_REAL && FIT_PIXTYPE(fit) != TY_DOUBLE) { + call fxf_cnvpx (im, totpix, obuf, nbytes, boffset) + return + } + } + + pixtype = IM_PIXTYPE(im) + datasizeb = totpix * (pix_size[pixtype] * SZB_CHAR) + pixoffb = (FIT_PIXOFF(fit) - 1) * SZB_CHAR + 1 + + # We can read the data directly into the caller's output buffer as + # any FITS kernel input conversions are guaranteed to not make the + # data smaller. + + call zardbf (FIT_IO(fit), obuf, nbytes, boffset) + call zawtbf (FIT_IO(fit), status) + if (status == ERR) { + FIT_IOSTAT(fit) = ERR + return + } + + ### boffset is 1-indexed, so one would expect (boffset/SZB_CHAR) to + ### be ((boffset - 1) * SZB_CHAR + 1). This is off by one from what + ### is being calculated, so if PIXOFF and boffset point to the same + ### place IP will be one, which happens to be the correct array index. + ### Nonehtless expressions like this should be written out so that + ### they can be verified easily by reading them. Any modern compiler + ### will optimize the expression, we don't have to do this in the + ### source code. + + ip = FIT_PIXOFF(fit) - boffset/SZB_CHAR + if (ip <= 0) + ip = 1 + + nb_skipped = boffset - pixoffb + if (nb_skipped <= 0) + nb = min (status + nb_skipped, datasizeb) + else + nb = min (status, datasizeb - nb_skipped) + npix = max (0, nb / (pix_size[pixtype] * SZB_CHAR)) + + if (FIT_ZCNV(fit) == YES) { + if (FIT_PIXTYPE(fit) == TY_REAL) { + # This is for scaling -32 (should not be allowed) + call fxf_zaltrr(obuf[ip], npix, FIT_BSCALE(fit), FIT_BZERO(fit)) + } else if (FIT_PIXTYPE(fit) == TY_DOUBLE) { + # This is for scaling -64 data (should not be allowed) + call fxf_zaltrd(obuf[ip], npix, FIT_BSCALE(fit), FIT_BZERO(fit)) + } + } else { + call fxf_unpack_data (obuf[ip], + npix, pixtype, FIT_BSCALE(fit), FIT_BZERO(fit)) + } +end + +procedure fxf_zaltrr (data, npix, bscale, bzero) + +real data[ARB], rt +int npix +double bscale, bzero + +int i + +begin + call ieevupkr (data, data, npix) + do i = 1, npix { + data[i] = data[i] * bscale + bzero + } +end + + +procedure fxf_zaltrd (data, npix, bscale, bzero) + +double data[ARB] +int npix +double bscale, bzero + +int i + +begin + call ieevupkd (data, data, npix) + do i = 1, npix + data[i] = data[i] * bscale + bzero +end + + + +# FXFZWR -- Write to the output file. + +procedure fxfzwr (chan, ibuf, nbytes, boffset) + +int chan #I QPF i/o channel +char ibuf[ARB] #O data buffer +int nbytes #I nbytes to be written +int boffset #I file offset + +pointer fit, im, sp, obuf +bool noconvert, lscale, lzero, bfloat +int ip, op, pixtype, npix, totpix, nb, nchars, i +int datasizeb, pixoffb, nb_skipped, obufsize + +bool fxf_fpl_equald() + +include <szpixtype.inc> + +begin + fit = chan + im = FIT_IM(fit) + FIT_IOSTAT(fit) = OK + + # We don't have to pack the data if it is integer and we don't need + # to byte swap; the data buffer can be written directly out. + + + # Determine if we are writing into an scaled floating point data + # unit; i.e. bitpix > 0 and BSCALE or/and BZERO with non default + # values. This is an error since we are not supporting this + # combination for writing at this time. + + lscale = fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 1) + lzero = fxf_fpl_equald (0.0d0, FIT_BZERO(fit), 1) + + # Determine if scaling is necessary. + bfloat = (!lscale || !lzero) + if (bfloat && + (IM_PIXTYPE(im) == TY_REAL || IM_PIXTYPE(im) == TY_DOUBLE)) { + FIT_IOSTAT(fit) = ERR + return + } + + pixtype = IM_PIXTYPE(im) + noconvert = ((pixtype == TY_SHORT && BYTE_SWAP2 == NO) || + ((pixtype == TY_INT || pixtype == TY_LONG) && BYTE_SWAP4 == NO)) + + if (noconvert) { + call zawrbf (FIT_IO(fit), ibuf, nbytes, boffset) + return + } + + # Writing pixel data to an image is currently illegal if on-the-fly + # conversion is in effect, as on-the-fly conversion is currently only + # available for reading. + + if (FIT_ZCNV(fit) == YES) { + FIT_IOSTAT(fit) = ERR + return + } + + totpix = IM_PHYSLEN(im,1) + do i = 2, IM_NPHYSDIM(im) + totpix = totpix * IM_PHYSLEN(im,i) + + datasizeb = totpix * (pix_size[pixtype] * SZB_CHAR) + pixoffb = (FIT_PIXOFF(fit) - 1) * SZB_CHAR + 1 + + ### Same comments as for fxfzrd apply here. + ### There doesn't appear to be any support here for byte data like + ### in fxfzwr. This must mean that byte images are read-only. + ### This shouldn't be necessary, but we shouldn't try to do anything + ### about it until the fxf_byte_short issue is addressed. + + ip = FIT_PIXOFF(fit) - boffset / SZB_CHAR + if (ip <= 0) + ip = 1 + + nb_skipped = boffset - pixoffb + if (nb_skipped <= 0) + nb = min (nbytes + nb_skipped, datasizeb) + else + nb = min (nbytes, datasizeb - nb_skipped) + npix = max (0, nb / (pix_size[pixtype] * SZB_CHAR)) + + if (npix == 0) + return + + # We don't do scaling (e.g. BSCALE/BZERO) when writing. All the + # generated FITS files in this interface are ieee fits standard. + ### I didn't look into it but I don't understand this; when accessing + ### a BSCALE image read-write, it should be necessary to scale both + ### when reading and writing if the application sees TY_REAL pixels. + ### When writing a new image I suppose the application would take + ### care of any scaling. + + # Convert any pixel data in the input buffer to the binary format + # required for FITS and write it out. Any non-pixel data in the + # buffer should be left as-is. + + obufsize = (nbytes + SZB_CHAR-1) / SZB_CHAR + + call smark (sp) + call salloc (obuf, obufsize, TY_CHAR) + + # Preserve any leading non-pixel data. + op = 1 + if (ip > 1) { + nchars = min (obufsize, ip - 1) + call amovc (ibuf[1], Memc[obuf], nchars) + op = op + nchars + } + + # Convert and output the pixels. + call fxf_pak_data (ibuf[ip], Memc[obuf+op-1], npix, pixtype) + op = op + npix * pix_size[pixtype] + + # Preserve any remaining non-pixel data. + nchars = obufsize - op + 1 + if (nchars > 0) + call amovc (ibuf[op], Memc[obuf+op-1], nchars) + + # Write out the data. + call zawrbf (FIT_IO(fit), Memc[obuf], nbytes, boffset) + + call sfree (sp) +end + + +# FXFZWT -- Return the number of bytes transferred in the last i/o request. + +procedure fxfzwt (chan, status) + +int chan #I QPF i/o channel +int status #O i/o channel status + +pointer fit, im + +begin + fit = chan + im = FIT_IM(fit) + + # A file driver returns status for i/o only in the AWAIT routine; + # hence any i/o errors occurring in the FK itself are indicated by + # setting FIT_IOSTAT. Otherwise the actual i/o operation must have + # been submitted, and we call zawtbf to wait for i/o, and get status. + + if (FIT_IOSTAT(fit) != OK) + status = FIT_IOSTAT(fit) + else + call zawtbf (FIT_IO(fit), status) + + # FIT_ZBYTES has the correct number of logical bytes that need + # to be passed to fio since we are expanding the buffer size + # from byte to short or real and short to real. + + if (status > 0) { + if (FIT_PIXTYPE(fit) == TY_UBYTE) + status = FIT_ZBYTES(fit) + else if (FIT_PIXTYPE(fit) == TY_SHORT && IM_PIXTYPE(im) == TY_REAL) + status = FIT_ZBYTES(fit) + } +end + + +# FXFZST -- Query device/file parameters. + +procedure fxfzst (chan, param, value) + +int chan #I FIT i/o channel +int param #I parameter to be returned +int value #O parameter value + +pointer fit, im +int i, totpix, szb_pixel, szb_real + +include <szpixtype.inc> + +begin + fit = chan + im = FIT_IM(fit) + + totpix = IM_PHYSLEN(im,1) + do i = 2, IM_NPHYSDIM(im) + totpix = totpix * IM_PHYSLEN(im,i) + + szb_pixel = pix_size[IM_PIXTYPE(im)] * SZB_CHAR + szb_real = SZ_REAL * SZB_CHAR + + call zsttbf (FIT_IO(fit), param, value) + + if (param == FSTT_FILSIZE) { + switch (FIT_PIXTYPE(fit)) { + case TY_SHORT: + if (IM_PIXTYPE(im) == TY_REAL) { + value = value + int ((totpix * SZ_SHORT * SZB_CHAR) / + 2880. + .5) * 2880 + } + case TY_UBYTE: + if (IM_PIXTYPE(im) == TY_SHORT) + value = value + int (totpix/2880. + 0.5)*2880 + else if (IM_PIXTYPE(im) == TY_REAL) + value = value + int(totpix*(szb_real-1)/2880. + 0.5) * 2880 + } + } +end + + +# FXF_CNVPX -- Convert FITS type BITPIX = 8 to SHORT or REAL depending +# on the value of BSCALE, BZERO (1, 32768 is already iraf supported as ushort +# and is not treated in here). If BITPIX=16 and BSCALE and BZERO are +# non-default then the pixels are converted to REAL. + +procedure fxf_cnvpx (im, totpix, obuf, nbytes, boffset) + +pointer im #I Image descriptor +int totpix #I Total number of pixels +char obuf[ARB] #O Output data buffer +int nbytes #I Size in bytes of the output buffer +int boffset #I Byte offset into the virtual image + +pointer sp, buf, fit, op +double bscale, bzero +int ip, nelem, pfactor +int pixtype, nb, buf_size, bzoff, nboff +int status, offset, npix +int datasizeb, pixoffb, nb_skipped + +include <szpixtype.inc> + +begin + fit = IM_KDES(im) + bscale = FIT_BSCALE(fit) + bzero = FIT_BZERO(fit) + + ip = FIT_PIXOFF(fit) - boffset/SZB_CHAR + if (ip <= 0) + ip = 1 + + # The beginning of the data portion in bytes. + pixoffb = (FIT_PIXOFF(fit)-1) * SZB_CHAR + 1 + + # Determine the factor to applied: size(im_pixtype)/size(fit_pixtype) + if (FIT_PIXTYPE(fit) == TY_UBYTE) { + if (IM_PIXTYPE(im) == TY_REAL) + pfactor = SZ_REAL * SZB_CHAR + else # TY_SHORT + pfactor = SZB_CHAR + datasizeb = totpix + } else if (FIT_PIXTYPE(fit) == TY_SHORT) { + pfactor = SZ_REAL / SZ_SHORT + pixtype = TY_SHORT + datasizeb = totpix * (pix_size[pixtype] * SZB_CHAR) + } else { + FIT_IOSTAT(fit) = ERR + return + } + + # We need to map the virtual image of type im_pixtype to the actual + # file of type fit_pixtype. 'nbytes' is the number of bytes to read + # from the virtual image. To find out how many fit_pixtype bytes + # we need to read from disk we need to subtract the FITS + # header size (if boffset is 1) from nbytes and then divide + # the resultant value by the convertion factor. + # We then add the size of the header if necessary. + + # Determine the offset into the pixel area. + nboff = boffset - pixoffb + if (nboff > 0) { + nelem = nboff / pfactor + offset = nelem + pixoffb + } else { + # Keep the 1st boffset. + bzoff = boffset + offset = boffset + } + + # Calculates the number of elements to convert. We keep the offset from + # the beginning of the unit (bzoff) and not from file's 1st byte. + + nelem = nbytes - (pixoffb - bzoff + 1) + nelem = nelem / pfactor + buf_size = nelem + (pixoffb - bzoff + 1) + if (buf_size*pfactor > nbytes && ip == 1) + buf_size = (nbytes - 1) / pfactor + 1 + + # Allocate space for TY_SHORT + call smark(sp) + call salloc (buf, buf_size/SZB_CHAR, TY_SHORT) + + call zardbf (FIT_IO(fit), Mems[buf], buf_size, offset) + call zawtbf (FIT_IO(fit), status) + if (status == ERR) { + FIT_IOSTAT(fit) = ERR + call sfree (sp) + return + } + + # Map the number of bytes of datatype FIT_PIXTYPE to + # IM_PIXTYPE for use in zfxfwt(). + + if (status*pfactor >= nbytes) + FIT_ZBYTES(fit) = nbytes + else + FIT_ZBYTES(fit) = status * pfactor + + nb_skipped = offset - pixoffb + if (nb_skipped <= 0) + nb = min (status + nb_skipped, datasizeb) + else + nb = min (status, datasizeb - nb_skipped) + + switch (FIT_PIXTYPE(fit)) { + case TY_UBYTE: + npix = max (0, nb) + if (IM_PIXTYPE(im) == TY_SHORT) + call achtbs (Mems[buf+ip-1], obuf[ip], npix) + else { + # Scaled from byte to REAL. + call achtbl (Mems[buf+ip-1], obuf[ip], npix) + call fxf_altmr (obuf[ip], obuf[ip], npix, bscale, bzero) + } + case TY_SHORT: + op = buf + ip - 1 + npix = max (0, nb / (pix_size[pixtype] * SZB_CHAR)) + if (BYTE_SWAP2 == YES) + call bswap2 (Mems[op], 1, Mems[op], 1, npix*SZB_CHAR) + call fxf_astmr (Mems[op], obuf[ip], npix, bscale, bzero) + } + + call sfree (sp) +end diff --git a/sys/imio/iki/iki.com b/sys/imio/iki/iki.com new file mode 100644 index 00000000..1c8ef719 --- /dev/null +++ b/sys/imio/iki/iki.com @@ -0,0 +1,10 @@ +# IKI.COM -- Image Kernel Interface global common. + +int k_nkernels, k_nextn, k_sbufused, k_defimtype, k_inherit +int k_kernel[MAX_IMEXTN], k_extn[MAX_IMEXTN], k_pattern[MAX_IMEXTN] +int k_table[LEN_KERNEL,MAX_KERNELS] +char k_kname[SZ_KNAME,MAX_KERNELS] +char k_sbuf[SZ_IKISBUF] + +common /ikicom/ k_nkernels, k_nextn, k_sbufused, k_defimtype, k_inherit, + k_kernel, k_extn, k_pattern, k_table, k_kname, k_sbuf diff --git a/sys/imio/iki/iki.h b/sys/imio/iki/iki.h new file mode 100644 index 00000000..be7a6bc0 --- /dev/null +++ b/sys/imio/iki/iki.h @@ -0,0 +1,35 @@ +# IKI.H -- Image Kernel Interface global definitions. + +define MAX_KERNELS 10 # max loaded IKI kernels +define MAX_LENEXTN 4 # max length header filename extension +define MIN_LENEXTN 2 # min length header filename extension +define MAX_IMEXTN 64 # max image extension patterns +define SZ_IKISBUF 512 # string buffer for IKI common +define SZ_KNAME 4 # internal kernel name "oif,fxf,.." + +# IMTYPE specifies the default type for new images. +define ENV_IMTYPE "imtype" +define DEF_IMTYPE "oif,noinherit" + +# IMEXTN specifies the mapping between image types and file extensions. +define ENV_IMEXTN "imextn" +define DEF_IMEXTN "oif:imh fxf:fits,fit plf:pl qpf:qp stf:hhh,??h" + +# The standard test image. +define STD_TESTIMAGE "dev$pix" +define DEF_TESTIMAGE "dev$pix.imh" + +define LEN_KERNEL 9 # length of a kernel entry in k_table +define IKI_KNAME k_kname[1,$1] # image kernel name +define IKI_OPEN k_table[1,$1] # open/create image +define IKI_CLOSE k_table[2,$1] # close image +define IKI_OPIX k_table[3,$1] # open/create pixel file +define IKI_UPDHDR k_table[4,$1] # update image header +define IKI_ACCESS k_table[5,$1] # test existence or legal type +define IKI_COPY k_table[6,$1] # fast copy of entire image +define IKI_DELETE k_table[7,$1] # delete image +define IKI_RENAME k_table[8,$1] # rename image +define IKI_FLAGS k_table[9,$1] # driver flags + +# IKI driver flags. +define IKF_NOCREATE 1 # kernel cannot create new images diff --git a/sys/imio/iki/ikiaccess.x b/sys/imio/iki/ikiaccess.x new file mode 100644 index 00000000..83736b4f --- /dev/null +++ b/sys/imio/iki/ikiaccess.x @@ -0,0 +1,128 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "iki.h" + +# IKI_ACCESS -- Determine if the named image exists, and if so, return the +# the index of the IKI kernel to be used to access the image, else return 0 if +# the named image is not found. If multiple images exist with the same name +# (e.g. but with different image types) then ERR is returned. An NEW_IMAGE +# access mode may be specified to associate an extension with an image kernel +# without testing for the existence of an image. If the input image name did +# not specify an extension or what appeared to be an extension was just a . +# delimited field, we will patch up the ROOT and EXTN strings to the real +# values. + +int procedure iki_access (image, root, extn, acmode) + +char image[ARB] #I image/group name +char root[ARB] #O image/group file name +char extn[ARB] #O image/group file extension +int acmode + +bool first_time +int i, k, status, op +pointer sp, osroot, fname, textn, fextn, ip +data first_time /true/ + +bool fnullfile() +int gstrcpy(), strlen() +errchk fpathname, syserrs +include "iki.com" + +begin + call smark (sp) + call salloc (osroot, SZ_PATHNAME, TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (textn, MAX_LENEXTN, TY_CHAR) + call salloc (fextn, MAX_LENEXTN, TY_CHAR) + + # The first call makes sure the IKI kernels are loaded into the kernel + # table. + + if (first_time) { + call iki_init() + first_time = false + } + + call iki_parse (image, root, extn) + if (fnullfile (root)) { + call sfree (sp) + return (1) + } + + repeat { + # Convert to absolute pathname to render names like file + # and ./file equivalent. Add a dummy file extension first + # to cause escape sequence encoding of any .DDDD etc. files + # which may be part of the root image name. + + op = gstrcpy (root, Memc[fname], SZ_PATHNAME) + call strcpy (".x", Memc[fname+op], SZ_PATHNAME-op+1) + call fpathname (Memc[fname], Memc[osroot], SZ_PATHNAME) + Memc[osroot+strlen(Memc[osroot])-2] = EOS + + # Escape any $ in the pathname since we are still in VOS land. + op = 1 + for (ip=osroot; Memc[ip] != EOS; ip=ip+1) { + if (Memc[ip] == '$' || Memc[ip] == '[') { + root[op] = '\\' + op = op + 1 + } + root[op] = Memc[ip] + op = op + 1 + } + + root[op] = EOS + + # Select an image kernel by calling the access function in each + # loaded kernel until somebody claims the image. If multiple + # kernels claim the image the image specification (name) is + # ambiguous and we don't know which image was intended, an error. + # Note that in the case of a new image, the access function + # tests only the legality of the extn. + + k = 0 + for (i=1; i <= k_nkernels; i=i+1) { + call strcpy (extn, Memc[textn], MAX_LENEXTN) + call zcall5 (IKI_ACCESS(i), i,root,Memc[textn],acmode,status) + + if (status == YES) { + if (k == 0) { + # Stop on the first access if an explicit extension + # was given. + + k = i + call strcpy (Memc[textn], Memc[fextn], MAX_LENEXTN) + if (extn[1] != EOS) + break + + } else { + # The image name is ambiguous. + call sfree (sp) + return (ERR) + } + } + } + + # Valid image using kernel K. + if (k != 0) { + call strcpy (Memc[fextn], extn, MAX_LENEXTN) + call sfree (sp) + return (k) + } + + # If the search failed and an extension was given, maybe what + # we thought was an extension was really just part of the root + # filename. Try again with the extn folded into the root. + + if (status == NO && extn[1] != EOS) { + call strcpy (image, root, SZ_PATHNAME) + extn[1] = EOS + } else + break + } + + call sfree (sp) + return (0) +end diff --git a/sys/imio/iki/ikiclose.x b/sys/imio/iki/ikiclose.x new file mode 100644 index 00000000..e4b2ced9 --- /dev/null +++ b/sys/imio/iki/ikiclose.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include "iki.h" + +# IKI_CLOSE -- Physically close an image opened under the IKI. It is not +# necessary to update the image header or flush any pixel data, as IMIO will +# already have performed those functions. + +procedure iki_close (im) + +pointer im #I image descriptor + +int status +include "iki.com" + +begin + iferr (call zcall2 (IKI_CLOSE(IM_KERNEL(im)), im, status)) + status = ERR + if (status == ERR) + call syserrs (SYS_IKICLOSE, IM_NAME(im)) +end diff --git a/sys/imio/iki/ikicopy.x b/sys/imio/iki/ikicopy.x new file mode 100644 index 00000000..31df1970 --- /dev/null +++ b/sys/imio/iki/ikicopy.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "iki.h" + +# IKI_COPY -- Fast copy of an entire image or group of images. This function +# is provided at the IKI level since the kernel has explicit knowledge of the +# storage format and hence may be able to copy the image by means much simpler +# and faster way than those available to the high level software. + +procedure iki_copy (old, new) + +char old[ARB] #I name of old image +char new[ARB] #I name of new image + +int k, n, status +pointer sp, old_root, old_extn, new_root, new_extn +int iki_access() +bool streq() +errchk syserrs + +include "iki.com" + +begin + call smark (sp) + call salloc (old_root, SZ_PATHNAME, TY_CHAR) + call salloc (old_extn, MAX_LENEXTN, TY_CHAR) + call salloc (new_root, SZ_PATHNAME, TY_CHAR) + call salloc (new_extn, MAX_LENEXTN, TY_CHAR) + + # Verify that the old image exists and determine its type. + k = iki_access (old, Memc[old_root], Memc[old_extn], READ_ONLY) + if (k < 0) + call syserrs (SYS_IKIAMBIG, old) + else if (k == 0) + call syserrs (SYS_IKIIMNF, old) + + # Make sure we will not be clobbering an existing image. Ignore + # attempts to rename an image onto itself. + + n = iki_access (new, Memc[new_root], Memc[new_extn], 0) + if (n > 0) { + if (streq (Memc[old_root], Memc[new_root])) + if (streq (Memc[old_extn], Memc[new_extn])) { + call sfree (sp) + return + } + call syserrs (SYS_IKICLOB, new) + } else { + # New name is new root plus legal extn for old image. + call iki_parse (new, Memc[new_root], Memc[new_extn]) + call strcpy (Memc[old_extn], Memc[new_extn], MAX_LENEXTN) + } + + # Copy the image. + call zcall6 (IKI_COPY(k), k, Memc[old_root], Memc[old_extn], + Memc[new_root], Memc[new_extn], status) + if (status == ERR) + call syserrs (SYS_IKICOPY, old) + + call sfree (sp) +end diff --git a/sys/imio/iki/ikidelete.x b/sys/imio/iki/ikidelete.x new file mode 100644 index 00000000..a172980b --- /dev/null +++ b/sys/imio/iki/ikidelete.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "iki.h" + +# IKI_DELETE -- Delete an image or group of images. + +procedure iki_delete (image) + +char image[ARB] #I name of image + +int k, status +pointer sp, root, extn +int iki_access() +bool fnullfile() + +errchk syserrs +include "iki.com" + +begin + if (fnullfile (image)) + return + + call smark (sp) + call salloc (root, SZ_PATHNAME, TY_CHAR) + call salloc (extn, MAX_LENEXTN, TY_CHAR) + + # Verify that the image exists and determine its type. + k = iki_access (image, Memc[root], Memc[extn], 0) + if (k < 0) + call syserrs (SYS_IKIAMBIG, image) + else if (k == 0) + call syserrs (SYS_IKIIMNF, image) + + # Delete the image. + call zcall4 (IKI_DELETE(k), k, Memc[root], Memc[extn], status) + if (status == ERR) + call syserrs (SYS_IKIDEL, image) + + call sfree (sp) +end diff --git a/sys/imio/iki/ikiextn.x b/sys/imio/iki/ikiextn.x new file mode 100644 index 00000000..a5f2aa12 --- /dev/null +++ b/sys/imio/iki/ikiextn.x @@ -0,0 +1,372 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <imhdr.h> +include "iki.h" + +# IKIEXTN.X -- Image extension handling. This package is used to map image +# file extensions to image types and vice versa. +# +# iki_extninit (imtype, def_imtype, imextn, def_imextn) +# status = iki_validextn (kernel, extn) +# status = iki_getextn (kernel, index, extn, maxch) +# value = iki_getpar (param) +# +# iki_extninit initializes the image extension handling package. This parses +# the lists of extensions and patterns and builds an internal descriptor which +# will be used by the other routines for extension handling. iki_validextn +# tests whether a given extension is valid for a particular image kernel +# (type of image). iki_getextn is used with an index argument to get a list +# of the extensions for a particular image type. iki_getpar queries the value +# of IKI global parameters. + +define SZ_IMTYPE 128 +define SZ_IMEXTN 1024 + + +# IKI_EXTNINIT -- Initialize the image extension handling package. This is +# typically done once when IKI is first initialized. Changes to the image +# typing environment made subsequently have no effect unless the package is +# reinitialized. + +int procedure iki_extninit (env_imtype, def_imtype, env_imextn, def_imextn) + +char env_imtype[ARB] #I imtype environment variable +char def_imtype[ARB] #I default imtype value string +char env_imextn[ARB] #I imextn environment variable +char def_imextn[ARB] #I default imextn value string + +int kset[MAX_KERNELS] +pointer sp, ip, ip_save, imtype, imextn, strval +int op, delim, status, nchars, i, j, kernel +int envfind(), iki_getfield(), gstrcpy(), iki_validextn() +bool streq(), envgetb() + +include "iki.com" + +begin + call smark (sp) + call salloc (imtype, SZ_IMTYPE, TY_CHAR) + call salloc (imextn, SZ_IMEXTN, TY_CHAR) + call salloc (strval, SZ_FNAME, TY_CHAR) + + status = OK + + # Get the imtype string. The value of the env_imtype variable is used + # if the variable is found, otherwise the default is used. + + Memc[imtype] = EOS + if (env_imtype[1] != EOS) + if (envfind (env_imtype, Memc[imtype], SZ_IMTYPE) <= 0) + Memc[imtype] = EOS + if (Memc[imtype] == EOS) + call strcpy (def_imtype, Memc[imtype], SZ_IMTYPE) + + # Get the imextn string. The value of the env_imextn variable is used + # if the variable is found, otherwise the default is used. + + Memc[imextn] = EOS + if (env_imextn[1] != EOS) + if (envfind (env_imextn, Memc[imextn], SZ_IMEXTN) <= 0) + Memc[imextn] = EOS + if (Memc[imextn] == EOS) + call strcpy (def_imextn, Memc[imextn], SZ_IMEXTN) + + # Process imextn. This specifies the set of valid extensions for + # each image type. This must be done before processing imtype below, + # since iki_validextn can be used when processing imtype. The imextn + # string is of the form "<kernel>:<extn>[,<extn>...] ..." where + # <kernel> is the IKI kernel name (k_kname) and <extn> is a regular + # expression to be used to test for a matching file extension. + # For example, imextn = "oif:imh stf:hhh,??h fits:,fits,fit". + + k_nextn = 0 + k_sbufused = 0 + call aclri (kset, MAX_KERNELS) + + # Process the user extension string first followed by the builtin + # defaults. Anything given in the user string takes precedence + # while anything omitted uses the builtin defaults instead (if there + # is no user imextn this processes the default string twice). + + do i = 1, 2 { + if (i > 1) + call strcpy (def_imextn, Memc[imextn], SZ_IMEXTN) + + ip = imextn + while (Memc[ip] != EOS && IS_WHITE(Memc[ip])) + ip = ip + 1 + + repeat { + # Get the kernel name. + if (iki_getfield (ip, Memc[strval], SZ_FNAME, delim) <= 0) + break + call strlwr (Memc[strval]) + if (delim != ':') { + status = ERR + break + } + + # Lookup kernel. + kernel = 0 + do j = 1, k_nkernels { + if (streq (Memc[strval], k_kname[1,j])) { + kernel = j + break + } + } + if (kernel <= 0) { + status = ERR + break + } + + # Process the list of extension patterns. + op = k_sbufused + 1 + ip_save = ip + + while (iki_getfield (ip, Memc[strval], SZ_FNAME, delim) > 0) { + # call strlwr (Memc[strval]) + + # Skip it if we already have something for this kernel. + if (kset[kernel] == 0) { + # Get a new extension descriptor. + if (k_nextn >= MAX_IMEXTN) { + status = ERR + break + } else + k_nextn = k_nextn + 1 + + # Save the kernel index associated with this extension. + k_kernel[k_nextn] = kernel + + # Save the extension string. + k_extn[k_nextn] = op + nchars = gstrcpy(Memc[strval],k_sbuf[op],SZ_IKISBUF-op) + op = op + nchars + 1 + + # Save the strmatch pattern for the extension. + k_pattern[k_nextn] = op + k_sbuf[op] = '^'; op = op + 1 + nchars = gstrcpy(Memc[strval],k_sbuf[op],SZ_IKISBUF-op) + op = op + nchars + 1 + } + + ip_save = ip + if (delim != ',') + break + } + + kset[kernel] = 1 + k_sbufused = op - 1 + + } until (Memc[ip] == EOS) + } + + # Process imtype. This sets the default image type for new images. + # For example, imtype = "oif,inherit" would create OIF (.imh) images + # by default, inheriting the old image type if a newcopy image is + # being written. + + k_defimtype = 1 + k_inherit = NO + ip = imtype + kernel = 0 + + while (iki_getfield (ip, Memc[strval], SZ_FNAME, delim) > 0) { + call strlwr (Memc[strval]) + + # Check for the inherit/noinherit keywords. + if (streq (Memc[strval], "inherit")) { + k_inherit = YES + next + } + if (streq (Memc[strval], "noinherit")) { + k_inherit = NO + next + } + + # Scan the kernels to see if we have a kernel name. + if (kernel <= 0) + do i = 1, k_nkernels + if (streq (Memc[strval], k_kname[1,i])) { + kernel = i + break + } + + # Check for a valid imagefile extension. + if (kernel <= 0) + kernel = iki_validextn (0, Memc[strval]) + } + + if (kernel <= 0) + status = ERR + else + k_defimtype = kernel + + if (envgetb ("ikidebug")) + call iki_debug ("IKI debug:", STDERR, 0) + + call sfree (sp) + return (status) +end + + +# IKI_VALIDEXTN -- Determine if the given imagefile extension is valid for +# the given image kernel (image type). If kernel=0 the extensions for all +# kernels are examined. If a valid match is found the kernel index is +# returned as the function value, otherwise 0 is returned. + +int procedure iki_validextn (kernel, extn) + +int kernel #I kernel index, zero for all kernels +char extn[ARB] #I extension to be tested + +int i, ip +int strmatch() +include "iki.com" + +begin + do i = 1, k_nextn + if (kernel == 0 || k_kernel[i] == kernel) { + ip = strmatch (extn, k_sbuf[k_pattern[i]]) + if (ip > 0 && extn[ip] == EOS) + return (k_kernel[i]) + } + + return (0) +end + + +# IKI_GETEXTN -- Get an entry from the list of valid extensions (actually +# extension patterns) for the given image kernel. If kernel=0 all entries +# are returned. The kernel index for the output extension is returned as +# the function value. ERR is returned if the requested extension does not +# exist. + +int procedure iki_getextn (kernel, index, extn, maxch) + +int kernel #I kernel index, zero for all kernels +int index #I extension number (1 indexed) +char extn[ARB] #O extension +int maxch #I max chars out + +int i, n +include "iki.com" + +begin + n = 0 + do i = 1, k_nextn + if (kernel == 0 || k_kernel[i] == kernel) { + n = n + 1 + if (index == n) { + call strcpy (k_sbuf[k_extn[i]], extn, maxch) + return (k_kernel[i]) + } + } + + return (ERR) +end + + +# IKI_GETPAR -- Return the value of an IKI global parameter (integer valued). + +int procedure iki_getpar (param) + +char param[ARB] #I parameter name + +bool streq() +include "iki.com" + +begin + if (streq (param, "inherit")) + return (k_inherit) + else if (streq (param, "defimtype")) + return (k_defimtype) +end + + +# IKI_GETFIELD -- Get the next field from a punctuation or whitespace +# delimited list. The length of the field is returned as the function value. +# EOF is returned at the end of the list. Zero can be returned if a field +# is zero length, e.g. in "foo,,foo" the second field is zero length. + +int procedure iki_getfield (ip, outstr, maxch, delim) + +pointer ip #U string pointer +char outstr[ARB] #O receives string +int maxch #I max chars out +int delim #O delimiter char + +int op, ch + +begin + # Skip any leading whitespace. + while (Memc[ip] != EOS && IS_WHITE(Memc[ip])) + ip = ip + 1 + + # Check for end of list. + if (Memc[ip] == EOS || Memc[ip] == '\n') + return (EOF) + + op = 1 + for (ch=Memc[ip]; ch != EOS && !IS_WHITE(ch); ch=Memc[ip]) { + if (ch == ',' || ch == ':' || ch == ';') + break + else { + outstr[op] = ch + op = op + 1 + } + ip = ip + 1 + } + + delim = ch + if (delim != EOS) + ip = ip + 1 + + outstr[op] = EOS + return (op - 1) +end + + +# IKI_DEBUG -- Print debug information on the IKI internal data structures. + +procedure iki_debug (str, fd, flags) + +char str[ARB] #I title string +int fd #I output file +int flags #I (not used) + +int i +include "iki.com" + +begin + # Print global variables. + call fprintf (fd, "%s nkernels=%d sbufused=%d deftype=%d ") + call pargstr (str) + call pargi (k_nkernels) + call pargi (k_sbufused) + call pargi (k_defimtype) + call fprintf (fd, "inherit=%d nextn=%d\n") + call pargi (k_inherit) + call pargi (k_nextn) + + # List the installed kernels. + call fprintf (fd, "installed kernels ") + do i = 1, k_nkernels { + call fprintf (fd, "%s=%d ") + call pargstr (k_kname[1,i]) + call pargi (i) + } + call fprintf (fd, "\n") + + # Print the extension table. + do i = 1, k_nextn { + call fprintf (fd, "%6s %d (%s) %s\n") + call pargstr (k_sbuf[k_extn[i]]) + call pargi (k_kernel[i]) + call pargstr (k_kname[1,k_kernel[i]]) + call pargstr (k_sbuf[k_pattern[i]]) + } + + call flush (fd) +end diff --git a/sys/imio/iki/ikiinit.x b/sys/imio/iki/ikiinit.x new file mode 100644 index 00000000..41de76b6 --- /dev/null +++ b/sys/imio/iki/ikiinit.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "iki.h" + +# IKI_INIT -- Initialize the IKI kernel table, i.e., load all the standard +# kernels into the table. Additional kernels may be dynamically added at +# run time for special applications. + +procedure iki_init() + +extern oif_open(), oif_close(), oif_opix(), oif_updhdr(), + oif_access(), oif_copy(), oif_delete(), oif_rename() +extern fxf_open(), fxf_close(), fxf_opix(), fxf_updhdr(), + fxf_access(), fxf_copy(), fxf_delete(), fxf_rename() +extern plf_open(), plf_close(), plf_null(), plf_updhdr(), + plf_access(), plf_copy(), plf_delete(), plf_rename() +extern qpf_open(), qpf_close(), qpf_opix(), qpf_updhdr(), + qpf_access(), qpf_copy(), qpf_delete(), qpf_rename() +extern stf_open(), stf_close(), stf_opix(), stf_updhdr(), + stf_access(), stf_copy(), stf_delete(), stf_rname() + +bool first_time +data first_time /true/ +int iki_extninit() +include "iki.com" + +begin + if (!first_time) + return + + k_nkernels = 0 + + # Load the original IRAF format (OIF) kernel. + call iki_lddriver ("oif", oif_open, oif_close, oif_opix, oif_updhdr, + oif_access, oif_copy, oif_delete, oif_rename, 0) + + # Load the FITS image kernel (FXF). + call iki_lddriver ("fxf", fxf_open, fxf_close, fxf_opix, fxf_updhdr, + fxf_access, fxf_copy, fxf_delete, fxf_rename, 0) + + # Load the PLIO mask image mini-kernel (PLF - not a full kernel). + call iki_lddriver ("plf", plf_open, plf_close, plf_null, plf_updhdr, + plf_access, plf_copy, plf_delete, plf_rename, 0) + + # Load the QPOE photon image kernel (QPF). + call iki_lddriver ("qpf", qpf_open, qpf_close, qpf_opix, qpf_updhdr, + qpf_access, qpf_copy, qpf_delete, qpf_rename, IKF_NOCREATE) + + # Load the SDAS GEIS format (STF) kernel. + call iki_lddriver ("stf", stf_open, stf_close, stf_opix, stf_updhdr, + stf_access, stf_copy, stf_delete, stf_rname, 0) + + # Initialize the extension-based image typing mechanism. + if (iki_extninit (ENV_IMTYPE, DEF_IMTYPE, ENV_IMEXTN, DEF_IMEXTN) < 0) + ; + + first_time = false +end diff --git a/sys/imio/iki/ikildd.x b/sys/imio/iki/ikildd.x new file mode 100644 index 00000000..256e7e70 --- /dev/null +++ b/sys/imio/iki/ikildd.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "iki.h" + +# IKI_LDDRIVER -- Load an IKI kernel into the kernel table, i.e., make a new +# kernel entry in the table containing the entry point address of each of the +# kernel procedures. + +procedure iki_lddriver (kname, ex_open, ex_close, ex_opix, ex_updhdr, + ex_access, ex_copy, ex_delete, ex_rename, flags) + +char kname[ARB] +extern ex_open(), ex_close(), ex_opix(), ex_updhdr() +extern ex_access(), ex_copy(), ex_delete(), ex_rename() +int locpr() +int flags + +include "iki.com" +errchk syserr + +begin + if (k_nkernels + 1 > MAX_KERNELS) + call syserr (SYS_IKIKTBLOVFL) + else + k_nkernels = k_nkernels + 1 + + call strcpy (kname, IKI_KNAME(k_nkernels), SZ_KNAME) + IKI_OPEN(k_nkernels) = locpr (ex_open) + IKI_CLOSE(k_nkernels) = locpr (ex_close) + IKI_OPIX(k_nkernels) = locpr (ex_opix) + IKI_UPDHDR(k_nkernels) = locpr (ex_updhdr) + IKI_ACCESS(k_nkernels) = locpr (ex_access) + IKI_COPY(k_nkernels) = locpr (ex_copy) + IKI_DELETE(k_nkernels) = locpr (ex_delete) + IKI_RENAME(k_nkernels) = locpr (ex_rename) + IKI_FLAGS(k_nkernels) = flags +end diff --git a/sys/imio/iki/ikimkfn.x b/sys/imio/iki/ikimkfn.x new file mode 100644 index 00000000..a224f728 --- /dev/null +++ b/sys/imio/iki/ikimkfn.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "iki.h" + +# IKI_MKFNAME -- Manufacture a filename from the root and extension fields +# given. + +procedure iki_mkfname (root, extn, fname, maxch) + +char root[ARB] #I root filename +char extn[ARB] #I filename extension +char fname[maxch] #O output filename +int maxch #I max chars out + +int op +int gstrcpy() +bool fnullfile() + +begin + op = gstrcpy (root, fname, maxch) + 1 + if (extn[1] != EOS && !fnullfile (root)) { + fname[op] = '.' + op = op + 1 + call strcpy (extn, fname[op], maxch-op+1) + } +end diff --git a/sys/imio/iki/ikiopen.x b/sys/imio/iki/ikiopen.x new file mode 100644 index 00000000..f60a672d --- /dev/null +++ b/sys/imio/iki/ikiopen.x @@ -0,0 +1,153 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include "iki.h" + +# IKI_OPEN -- Open or create an image. If opening an existing image, determine +# the type of image and open it with the corresponding kernel. If creating a +# new image, the value of the environment variable IMTYPE determines the type +# of image to be created, i.e., the kernel to be used to open the image. If +# opening a new copy image, create an image of the same type as the existing +# image. + +procedure iki_open (n_im, image, ksection, cl_index, cl_size, acmode, o_im) + +pointer n_im #I descriptor of new image (to be filled in) +char image[ARB] #I name of image or cl_index to be opened +char ksection[ARB] #I information to be passed on to kernel +int cl_index #I index of image within cl_index +int cl_size #I number of images in cl_index +int acmode #I access mode +pointer o_im #I existing image descriptor, if new_copy + +bool inherit +pointer sp, root, extn, textn, fextn +int status, clmode, i, k +errchk syserrs, zcalla +include "iki.com" + +begin + call smark (sp) + call salloc (root, SZ_PATHNAME, TY_CHAR) + call salloc (extn, MAX_LENEXTN, TY_CHAR) + call salloc (textn, MAX_LENEXTN, TY_CHAR) + call salloc (fextn, MAX_LENEXTN, TY_CHAR) + + # Compute the access mode for the ACCESS test, below. If opening an + # existing image, all we want to do here is test for the existence of + # the image. If opening a new image, use new image mode. + + if ((acmode == NEW_IMAGE || acmode == NEW_COPY)) + clmode = NEW_IMAGE + else + clmode = 0 + + # Parse the image name into the root and extn fields. + call iki_parse (image, Memc[root], Memc[extn]) + + # If we are opening a new image and an explicit extension is given + # this determines the type of image to be created. Otherwise if we + # are opening a new copy image and type inheritance is enabled, the + # new image will be the same type as the old one. Otherwise (new + # image, type not specified or inherited) the default image type + # specified by the IMTYPE mechanism is used. If opening an existing + # image the access method of each image kernel is called until a + # kernel recognizes the image. + + repeat { + # Is type inheritance permitted? + inherit = (k_inherit == YES) + if (inherit && acmode == NEW_COPY) + inherit = (and (IKI_FLAGS(IM_KERNEL(o_im)), IKF_NOCREATE) == 0) + + # Select the kernel to be used. + if (acmode == NEW_COPY && Memc[extn] == EOS && inherit) { + # Inherit the same type as an existing image. + k = IM_KERNEL(o_im) + break + + } else if (clmode == NEW_IMAGE && Memc[extn] == EOS) { + # Use the default type for new images. + k = k_defimtype + break + + } else { + # Select an image kernel by calling the access function in each + # loaded kernel until somebody claims the image. In the case + # of a new image, the access function tests only the legality + # of the extn. If no extn is given but the imagefile has an + # extension, the access procedure will fill in the extn field. + + k = 0 + for (i=1; i <= k_nkernels; i=i+1) { + call strcpy (Memc[extn], Memc[textn], MAX_LENEXTN) + call zcall5 (IKI_ACCESS(i), i, Memc[root], Memc[textn], + clmode, status) + + if (status == YES) { + if (k == 0) { + # Stop on the first match if an explicit extension + # was given. + + k = i + call strcpy (Memc[textn], Memc[fextn], MAX_LENEXTN) + if (Memc[extn] != EOS) + break + + } else if (Memc[extn] == EOS) { + # If no extension was given and we match multiple + # files then we have an ambiguous name and k=ERR. + + k = ERR + break + } + } + } + + # Update the selected extn field. + if (k > 0) + call strcpy (Memc[fextn], Memc[extn], MAX_LENEXTN) + + # If the search failed and an extension was given, maybe what + # we thought was an extension was really just part of the root + # filename. Try again with the extn folded into the root. + + if (k == 0 && Memc[extn] != EOS) { + call strcpy (image, Memc[root], SZ_PATHNAME) + Memc[extn] = EOS + } else + break + } + } + + # The image name is ambiguous; we don't know which image to open. + # This can only happen when opening an existing image and multiple + # images exist matching the name given. It is permissible to create + # multiple images with the same name but different types. + + if (k == ERR) + call syserrs (SYS_IKIAMBIG, IM_NAME(n_im)) + + # Illegal image type or image does not exist. + if (k == 0) { + if (acmode == NEW_IMAGE || acmode == NEW_COPY) + call syserrs (SYS_IKIEXTN, IM_NAME(n_im)) + else + call syserrs (SYS_IKIOPEN, IM_NAME(n_im)) + } + + # Set the image kernel (format) to be used. + IM_KERNEL(n_im) = k + + # Open/create the image. Save the kernel index in the image header + # so that subsequent IKI routines know which kernel to use. + + call zcalla (IKI_OPEN(k), k, n_im, o_im, Memc[root], Memc[extn], + ksection, cl_index, cl_size, acmode, status) + if (status == ERR) + call syserrs (SYS_IKIOPEN, IM_NAME(n_im)) + + call sfree (sp) +end diff --git a/sys/imio/iki/ikiopix.x b/sys/imio/iki/ikiopix.x new file mode 100644 index 00000000..33b3a9bc --- /dev/null +++ b/sys/imio/iki/ikiopix.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include "iki.h" + +# IKI_OPIX -- Open or create the pixel storage file, if any. We are called by +# IMIO when i/o is first done to the image. In the case of a new image, IMIO +# will already have set up the IM_NDIM and IM_LEN fields of the image header. + +procedure iki_opix (im) + +pointer im #I image descriptor +int status +include "iki.com" + +begin + iferr (call zcall2 (IKI_OPIX(IM_KERNEL(im)), im, status)) + status = ERR + if (status == ERR) + call syserrs (SYS_IKIOPIX, IM_NAME(im)) +end diff --git a/sys/imio/iki/ikiparse.x b/sys/imio/iki/ikiparse.x new file mode 100644 index 00000000..3ffb7d6c --- /dev/null +++ b/sys/imio/iki/ikiparse.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "iki.h" + +# IKI_PARSE -- Parse an image name into the root pathname and filename +# extension, if any. Only the known image type extensions are recognized +# as extensions, hence this routine cannot be used to parse general filenames. + +procedure iki_parse (image, root, extn) + +char image[ARB] #I input image name +char root[SZ_PATHNAME] #U output root pathname +char extn[MAX_LENEXTN] #O output extension + +pointer sp, imname +int ip, op, dot +int strlen(), iki_validextn() +bool streq() + +begin + call smark (sp) + call salloc (imname, SZ_PATHNAME, TY_CHAR) + + dot = 0 + op = 1 + + # The following is a backwards-compatibility kludge. If the image + # name we are given is the canonical standard test image STD_TESTIMAGE + # ("dev$pix") replace the name with the fully qualified name + # DEF_TESTIMAGE. This is necessary to avoid ambiguous image name + # errors due to pix.imh and pix.hhh being in the same directory; these + # are well known names, neither of which can easily be changed. + + if (streq (image, STD_TESTIMAGE)) + call strcpy (DEF_TESTIMAGE, Memc[imname], SZ_PATHNAME) + else + call strcpy (image, Memc[imname], SZ_PATHNAME) + + # Copy image name to root and mark the position of the last dot. + for (ip=1; Memc[imname+ip-1] != EOS; ip=ip+1) { + root[op] = Memc[imname+ip-1] + if (root[op] == '.') + dot = op + op = op + 1 + } + + root[op] = EOS + extn[1] = EOS + + # Reject . delimited fields longer than the maximum extension length. + if (op - dot - 1 > MAX_LENEXTN) + dot = NULL + + # If found extension, chop the root and fill in the extn field. + # If no extension found, we are all done. + + if (dot == NULL) { + call sfree (sp) + return + } else { + root[dot] = EOS + call strcpy (root[dot+1], extn, MAX_LENEXTN) + } + + # Search the list of legal imagefile extensions. If the extension + # given is not found in the list, tack it back onto the root and + # return a null extension. This is necessary if we are to allow + # dot delimited fields within image names without requiring the + # user to supply the image type extension. For example, "im.c" + # and "im.c.imh" must refer to the same image - ".c" is part of + # the image name, not an image type extension. + + if (strlen(extn) >= MIN_LENEXTN) + if (iki_validextn (0, extn) > 0) { + call sfree (sp) + return + } + + # Not a legal image header extension. Restore the extn field to the + # root and null the extn. + + root[dot] = '.' + extn[1] = EOS + call sfree (sp) +end diff --git a/sys/imio/iki/ikirename.x b/sys/imio/iki/ikirename.x new file mode 100644 index 00000000..cdeff731 --- /dev/null +++ b/sys/imio/iki/ikirename.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "iki.h" + +# IKI_RENAME -- Rename an entire image or group of images. + +procedure iki_rename (old, new) + +char old[ARB] #I old name of image +char new[ARB] #I new name of image + +int k, n, status +pointer new_root, new_extn +pointer sp, old_root, old_extn + +bool streq() +int iki_access() +errchk syserrs +include "iki.com" + +begin + call smark (sp) + call salloc (old_root, SZ_PATHNAME, TY_CHAR) + call salloc (old_extn, MAX_LENEXTN, TY_CHAR) + call salloc (new_root, SZ_PATHNAME, TY_CHAR) + call salloc (new_extn, MAX_LENEXTN, TY_CHAR) + + # Verify that the old image exists and determine its type. + k = iki_access (old, Memc[old_root], Memc[old_extn], 0) + if (k < 0) + call syserrs (SYS_IKIAMBIG, old) + else if (k == 0) + call syserrs (SYS_IKIIMNF, old) + + # Determine if the old image exists. New name is new root plus + # legal extn for old image. + + n = iki_access (new, Memc[new_root], Memc[new_extn], 0) + if (n <= 0) + call iki_parse (new, Memc[new_root], Memc[new_extn]) + + # If an extension was given for the new image, verify that it is a + # valid extension for an image of the same type as the old image. + # We cannot change the image type in a rename operation. + + if (Memc[new_extn] != EOS) { + call zcall5 (IKI_ACCESS(k), k, Memc[new_root], Memc[new_extn], + NEW_FILE, status) + if (status == NO) + call strcpy (Memc[old_extn], Memc[new_extn], MAX_LENEXTN) + } else + call strcpy (Memc[old_extn], Memc[new_extn], MAX_LENEXTN) + + # Make sure we will not be clobbering an existing image. Renaming + # an image onto itself is ok; what it means to do this is up to + # the specific image kernel. + + if (n > 0) { + if (streq (Memc[old_root], Memc[new_root]) && + streq (Memc[old_extn], Memc[new_extn])) + ; # rename x -> x; let kernel decide what to do + else + call syserrs (SYS_IKICLOB, new) + } + + # Rename the image. + call zcall6 (IKI_RENAME(k), k, Memc[old_root], Memc[old_extn], + Memc[new_root], Memc[new_extn], status) + if (status == ERR) + call syserrs (SYS_IKIRENAME, old) + + call sfree (sp) +end diff --git a/sys/imio/iki/ikiupdhdr.x b/sys/imio/iki/ikiupdhdr.x new file mode 100644 index 00000000..f7ad22b8 --- /dev/null +++ b/sys/imio/iki/ikiupdhdr.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include "iki.h" + +# IKI_UPDHDR -- Update the image header. + +procedure iki_updhdr (im) + +pointer im #I image descriptor + +int status +include "iki.com" + +begin + iferr (call zcall2 (IKI_UPDHDR(IM_KERNEL(im)), im, status)) + status = ERR + if (status == ERR) + call syserrs (SYS_IKIUPDHDR, IM_NAME(im)) +end diff --git a/sys/imio/iki/mkpkg b/sys/imio/iki/mkpkg new file mode 100644 index 00000000..cd8663e9 --- /dev/null +++ b/sys/imio/iki/mkpkg @@ -0,0 +1,28 @@ +# Make the Image Kernel Interface. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + @oif # Original IRAF format + @fxf # FITS extension format + @plf # PLIO mask image mini-kernel (partial) + @qpf # QPOE photon image kernel + @stf # ST SDAS/GEIS format + + ikiaccess.x iki.com iki.h <imhdr.h> + ikiclose.x iki.com iki.h <imhdr.h> <imio.h> + ikicopy.x iki.com iki.h + ikidelete.x iki.com iki.h + ikiextn.x iki.com iki.h <ctype.h> <imhdr.h> + ikiinit.x iki.com iki.h + ikildd.x iki.com iki.h + ikimkfn.x iki.h + ikiopen.x iki.com iki.h <imhdr.h> <imio.h> + ikiopix.x iki.com iki.h <imhdr.h> <imio.h> + ikiparse.x iki.h + ikirename.x iki.com iki.h + ikiupdhdr.x iki.com <imio.h> iki.h <imhdr.h> + ; diff --git a/sys/imio/iki/oif/README b/sys/imio/iki/oif/README new file mode 100644 index 00000000..01e30678 --- /dev/null +++ b/sys/imio/iki/oif/README @@ -0,0 +1 @@ +IKI/OIF -- IKI kernel for the old (original) IRAF image format. diff --git a/sys/imio/iki/oif/imhv1.h b/sys/imio/iki/oif/imhv1.h new file mode 100644 index 00000000..a9a37874 --- /dev/null +++ b/sys/imio/iki/oif/imhv1.h @@ -0,0 +1,75 @@ +# IMHV1.H -- Version 1 of the OIF binary file header (April 1988). + +define V1_MAGIC "imhdr" # file identification tag +define V1_PMAGIC "impix" # file identification tag +define V1_VERSION 1 # header version number + +define SZ_V1IMPIXFILE 79 # name of pixel storage file +define SZ_V1IMHDRFILE 79 # name of header storage file +define SZ_V1IMTITLE 79 # image title string +define SZ_V1IMHIST 511 # image history record +define SZ_V1BUNIT 9 # brightness units string +define SZ_V1CTYPE 9 # coord axes units string + +# The IMIO image header structure. + +# Parameters. +define LEN_V1IMHDR 513 # length of std header +define LEN_V1PIXHDR 183 # length of pixel file header +define V1U LEN_V1IMHDR # offset to user fields +define IM_V1USERAREA (P2C($1+V1U)) # user area (database) + +# Disk resident header. +define IM_V1MAGIC Memi[$1] # contains the string "imhdr" +define IM_V1HDRLEN Memi[$1+3] # length of image header +define IM_V1PIXTYPE Memi[$1+4] # datatype of the pixels +define IM_V1NDIM Memi[$1+5] # number of dimensions +define IM_V1LEN Meml[$1+$2+6-1] # length of the dimensions +define IM_V1PHYSLEN Meml[$1+$2+13-1] # physical length (as stored) +define IM_V1SSMTYPE Meml[$1+20] # type of subscript mapping +define IM_V1LUTOFF Meml[$1+21] # offset to subscript map luts +define IM_V1PIXOFF Meml[$1+22] # offset of the pixels +define IM_V1HGMOFF Meml[$1+23] # offset of hgm pixels +define IM_V1BLIST Meml[$1+24] # offset of bad pixel list +define IM_V1SZBLIST Meml[$1+25] # size of bad pixel list +define IM_V1NBPIX Meml[$1+26] # number of bad pixels +define IM_V1CTIME Meml[$1+27] # time of image creation +define IM_V1MTIME Meml[$1+28] # time of last modify +define IM_V1LIMTIME Meml[$1+29] # time min,max computed +define IM_V1MAX Memr[P2R($1+30)] # max pixel value +define IM_V1MIN Memr[P2R($1+31)] # min pixel value +define IM_V1HGM ($1+33) # histogram descriptor +define IM_V1CTRAN ($1+52) # coordinate transformations +define IM_V1PIXFILE Memc[P2C($1+103)] # name of pixel storage file +define IM_V1HDRFILE Memc[P2C($1+143)] # name of header storage file +define IM_V1TITLE Memc[P2C($1+183)] # image name string +define IM_V1HISTORY Memc[P2C($1+223)] # history comment string + +# The Histogram structure (field IM_HGM) +define LEN_HGMSTRUCT 20 +define HGM_TIME Meml[$1] # time when hgm was computed +define HGM_LEN Meml[$1+1] # number of bins in hgm +define HGM_NPIX Meml[$1+2] # npix used to compute hgm +define HGM_MIN Memr[P2R($1+3)] # min hgm value +define HGM_MAX Memr[P2R($1+4)] # max hgm value +define HGM_INTEGRAL Memr[P2R($1+5)] # integral of hgm +define HGM_MEAN Memr[P2R($1+6)] # mean value +define HGM_VARIANCE Memr[P2R($1+7)] # variance about mean +define HGM_SKEWNESS Memr[P2R($1+8)] # skewness of hgm +define HGM_MODE Memr[P2R($1+9)] # modal value of hgm +define HGM_LCUT Memr[P2R($1+10)] # low cutoff value +define HGM_HCUT Memr[P2R($1+11)] # high cutoff value +# next available field: ($1+12) + +# The Coordinate Transformation Structure (IM_CTRAN) +define LEN_CTSTRUCT 50 +define CT_VALID Memi[$1] # (y/n) is structure valid? +define CT_BSCALE Memr[P2R($1+1)] # pixval scale factor +define CT_BZERO Memr[P2R($1+2)] # pixval offset +define CT_CRVAL Memr[P2R($1+$2+3-1)] # value at pixel +define CT_CRPIX Memr[P2R($1+$2+10-1)] # index of pixel +define CT_CDELT Memr[P2R($1+$2+17-1)] # increment along axis +define CT_CROTA Memr[P2R($1+$2+24-1)] # rotation angle +define CT_BUNIT Memc[P2C($1+31)] # pixval ("brightness") units +define CT_CTYPE Memc[P2C($1+36)] # coord units string +# next available field: ($1+41) diff --git a/sys/imio/iki/oif/imhv2.h b/sys/imio/iki/oif/imhv2.h new file mode 100644 index 00000000..d7eaa1f7 --- /dev/null +++ b/sys/imio/iki/oif/imhv2.h @@ -0,0 +1,43 @@ +# IMHV2.H -- Version 2 of the OIF binary file header (March 1997). + +define V2_MAGIC "imhv2" # file identification tag +define V2_PMAGIC "impv2" # file identification tag +define V2_VERSION 2 # header version + +define SZ_V2IMPIXFILE 255 # name of pixel storage file +define SZ_V2IMHDRFILE 255 # name of header storage file +define SZ_V2IMTITLE 383 # image title string +define SZ_V2IMHIST 1023 # image history record + +# The IMIO image header structure. + +# Parameters. +define LEN_V2IMHDR 1024 # length of std header +define LEN_V2PIXHDR 293 # length of pixel file header +define V2U LEN_V2IMHDR # offset to user fields +define IM_V2USERAREA (P2C($1+V2U)) # user area (database) + +# Disk resident header. +define IM_V2MAGIC Memi[$1] # contains the string "imhdr" +define IM_V2HDRLEN Memi[$1+3] # length of image header +define IM_V2PIXTYPE Memi[$1+4] # datatype of the pixels +define IM_V2SWAPPED Memi[$1+5] # pixels are byte swapped +define IM_V2NDIM Memi[$1+6] # number of dimensions +define IM_V2LEN Meml[$1+$2+7-1] # length of the dimensions +define IM_V2PHYSLEN Meml[$1+$2+14-1] # physical length (as stored) +define IM_V2SSMTYPE Meml[$1+21] # type of subscript mapping +define IM_V2LUTOFF Meml[$1+22] # offset to subscript map luts +define IM_V2PIXOFF Meml[$1+23] # offset of the pixels +define IM_V2HGMOFF Meml[$1+24] # offset of hgm pixels +define IM_V2BLIST Meml[$1+25] # offset of bad pixel list +define IM_V2SZBLIST Meml[$1+26] # size of bad pixel list +define IM_V2NBPIX Meml[$1+27] # number of bad pixels +define IM_V2CTIME Meml[$1+28] # time of image creation +define IM_V2MTIME Meml[$1+29] # time of last modify +define IM_V2LIMTIME Meml[$1+30] # time min,max computed +define IM_V2MAX Memr[P2R($1+31)] # max pixel value +define IM_V2MIN Memr[P2R($1+32)] # min pixel value +define IM_V2PIXFILE Memc[P2C($1+37)] # name of pixel storage file +define IM_V2HDRFILE Memc[P2C($1+165)] # name of header storage file +define IM_V2TITLE Memc[P2C($1+293)] # image name string +define IM_V2HISTORY Memc[P2C($1+485)] # history comment string diff --git a/sys/imio/iki/oif/mkpkg b/sys/imio/iki/oif/mkpkg new file mode 100644 index 00000000..81a4d57e --- /dev/null +++ b/sys/imio/iki/oif/mkpkg @@ -0,0 +1,21 @@ +# Make the IKI/OIF interface (Old IRAF Format images) + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + oifaccess.x oif.h + oifclose.x <error.h> <imhdr.h> <imio.h> <protect.h> + oifcopy.x oif.h + oifdelete.x <error.h> <imhdr.h> <protect.h> + oifgpfn.x oif.h <knet.h> + oifmkpfn.x oif.h <imhdr.h> <imio.h> <knet.h> + oifopen.x oif.h <imhdr.h> <imio.h> <fio.h> <error.h> + oifopix.x oif.h <config.h> <imhdr.h> <imio.h> + oifrdhdr.x imhv1.h imhv2.h oif.h <imhdr.h> <imio.h> <mach.h> + oifrename.x oif.h <error.h> <imhdr.h> <imio.h> + oifupdhdr.x oif.h <error.h> <imhdr.h> <imio.h> + oifwrhdr.x imhv1.h imhv2.h oif.h <imhdr.h> <imio.h> <mach.h> + ; diff --git a/sys/imio/iki/oif/oif.h b/sys/imio/iki/oif/oif.h new file mode 100644 index 00000000..d1161659 --- /dev/null +++ b/sys/imio/iki/oif/oif.h @@ -0,0 +1,15 @@ +# OIF.H -- IKI/OIF internal definitions. + +define MAX_LENEXTN 3 # max length imagefile extension +define OIF_HDREXTN "imh" # image header filename extension +define OIF_PIXEXTN "pix" # image pixfile extension +define LEN_PIXHDR 512 # max length of PIXHDR structure +define COMPRESS NO # disable alignment of image lines? +define DEF_VERSION 2 # default file version + +define ENV_OIFVER "oifversion" # default format for new images +define HDR "HDR$" # stands for header directory +define STRLEN_HDR 4 + +define TY_IMHDR 1 # main imagefile header +define TY_PIXHDR 2 # pixel file header diff --git a/sys/imio/iki/oif/oifaccess.x b/sys/imio/iki/oif/oifaccess.x new file mode 100644 index 00000000..e5dfe28a --- /dev/null +++ b/sys/imio/iki/oif/oifaccess.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "oif.h" + +# OIF_ACCESS -- Test the accessibility or existence of an existing image, or +# the legality of the name of a new image. + +procedure oif_access (kernel, root, extn, acmode, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #U extension (SET on output if none specified) +int acmode #I access mode (0 to test only existence) +int status #O status + +pointer sp, fname +int btoi(), access(), iki_validextn() +string oif_extn OIF_HDREXTN +bool strne() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # If new image, test only the legality of the given extension. + # This is used to select a kernel given the imagefile extension. + + if (acmode == NEW_IMAGE || acmode == NEW_COPY) { + status = btoi (iki_validextn (kernel, extn) > 0) + call sfree (sp) + return + } + + # Reject image if an invalid extension is given. + if (extn[1] != EOS && strne (extn, oif_extn)) { + status = NO + call sfree (sp) + return + } + + # Check for the imagefile. + call iki_mkfname (root, oif_extn, Memc[fname], SZ_PATHNAME) + if (access (Memc[fname], acmode, 0) == YES) { + if (extn[1] == EOS) + call strcpy (oif_extn, extn, MAX_LENEXTN) + status = YES + } else + status = NO + + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifclose.x b/sys/imio/iki/oif/oifclose.x new file mode 100644 index 00000000..8eb58b4f --- /dev/null +++ b/sys/imio/iki/oif/oifclose.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <protect.h> +include <error.h> +include <imhdr.h> +include <imio.h> + +# OIF_CLOSE -- Close an OIF format image. There is little for us to do, since +# IMIO will already have updated the header if necessary and flushed any pixel +# output. Neither do we have to deallocate the IMIO descriptor, since it was +# allocated by IMIO. + +procedure oif_close (im, status) + +pointer im # image descriptor +int status + +int junk +int protect() + +begin + # Close the pixel file and header file, if open. + if (IM_PFD(im) != NULL) + call close (IM_PFD(im)) + if (IM_HFD(im) != NULL) + call close (IM_HFD(im)) + + # If we are closing a new image, set delete protection on the + # header file to prevent the user from using DELETE to delete + # the image header file, which would leave a headerless pixel + # storage file lying about somewhere. + + if (IM_ACMODE(im) == NEW_IMAGE || IM_ACMODE(im) == NEW_COPY) + iferr (junk = protect (IM_HDRFILE(im), SET_PROTECTION)) + call erract (EA_WARN) +end diff --git a/sys/imio/iki/oif/oifcopy.x b/sys/imio/iki/oif/oifcopy.x new file mode 100644 index 00000000..8a7ea41d --- /dev/null +++ b/sys/imio/iki/oif/oifcopy.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "oif.h" + +# OIF_COPY -- Copy an image. A special operator is provided for fast, blind +# copies of entire images. + +procedure oif_copy (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] # old image root name +char old_extn[ARB] # old image extn +char new_root[ARB] # new image root name +char new_extn[ARB] # new extn +int status + +pointer sp +pointer old_fname, new_fname + +begin + call smark (sp) + call salloc (old_fname, SZ_PATHNAME, TY_CHAR) + call salloc (new_fname, SZ_PATHNAME, TY_CHAR) + + # Get filename of old and new images. + call iki_mkfname (old_root, old_extn, Memc[old_fname], SZ_PATHNAME) + call iki_mkfname (new_root, OIF_HDREXTN, Memc[new_fname], SZ_PATHNAME) + + # For now, this is stubbed out. + status = ERR + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifdelete.x b/sys/imio/iki/oif/oifdelete.x new file mode 100644 index 00000000..758309a7 --- /dev/null +++ b/sys/imio/iki/oif/oifdelete.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <protect.h> +include <error.h> +include <imhdr.h> + +# OIF_DELETE -- Delete an image. A special operator is required since the +# image is stored as two files. + +procedure oif_delete (kernel, root, extn, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #U extension +int status + +int junk +pointer sp, fname, pixfile +int access(), protect() +pointer im, immapz() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (pixfile, SZ_PATHNAME, TY_CHAR) + + # Generate filename. + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + + iferr (im = immapz (Memc[fname], READ_ONLY, 0)) { + call erract (EA_WARN) + + } else { + if (IM_PIXFILE(im) != EOS) { + call oif_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), + Memc[pixfile], SZ_PATHNAME) + if (access (Memc[pixfile],0,0) == YES) + iferr (call delete (Memc[pixfile])) + call erract (EA_WARN) + } + + call imunmap (im) + + # Do not complain if the file is not protected. + iferr (junk = protect (Memc[fname], REMOVE_PROTECTION)) + ; + iferr (call delete (Memc[fname])) + call erract (EA_WARN) + } + + call sfree (sp) + status = OK +end diff --git a/sys/imio/iki/oif/oifgpfn.x b/sys/imio/iki/oif/oifgpfn.x new file mode 100644 index 00000000..cc9a7fef --- /dev/null +++ b/sys/imio/iki/oif/oifgpfn.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <knet.h> +include "oif.h" + +# OIF_GPIXFNAME -- Convert a logical pixfile name into a physical pathname. + +procedure oif_gpixfname (pixfile, hdrfile, path, maxch) + +char pixfile[ARB] # pixfile name +char hdrfile[ARB] # header file name (gives hdr directory) +char path[maxch] # receives pathname +int maxch + +int ip, nchars +pointer sp, fname, op +int strncmp(), fnldir() + +begin + # Merely return pathname if not case "HDR$". + if (strncmp (pixfile, HDR, STRLEN_HDR) != 0) { + call fpathname (pixfile, path, maxch) + return + } + + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # Get host pathname of pixel file directory. + nchars = fnldir (hdrfile, Memc[fname], SZ_PATHNAME) + call fpathname (Memc[fname], path, maxch) + + # Fold in any subdirectories from the pixfile name. + # (as in HDR$pixels/). + + op = fname + nchars = 0 + + for (ip=STRLEN_HDR+1; pixfile[ip] != EOS; ip=ip+1) { + if (pixfile[ip] == '/') { + Memc[op] = EOS + call zfsubd (path, maxch, Memc[fname], nchars) + op = fname + } else { + Memc[op] = pixfile[ip] + op = op + 1 + } + } + + # Tack on the pixel file name, which was left in the fname buf. + if (op > fname) { + Memc[op] = EOS + if (nchars > 0) + call strcpy (Memc[fname], path[nchars+1], maxch-nchars) + else + call strcat (Memc[fname], path, maxch) + } + + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifmkpfn.x b/sys/imio/iki/oif/oifmkpfn.x new file mode 100644 index 00000000..234fa706 --- /dev/null +++ b/sys/imio/iki/oif/oifmkpfn.x @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include <knet.h> +include "oif.h" + +# OIF_MKPIXFNAME -- Generate the pixel file name. Leave the logical pixfile +# name in the image header, and return the pathname to the pixel file in the +# output argument. + +procedure oif_mkpixfname (im, pixfile, maxch) + +pointer im # image descriptor +char pixfile[maxch] # receives pathname to pixfile +int maxch + +char suffix[2] +int len_osdir, len_root, len_extn, n +pointer sp, imdir, osdir, root, extn, subdir, fname, ip, op + +bool fnullfile() +int fnroot(), fnldir(), access(), envgets(), strncmp() +string pixextn OIF_PIXEXTN +errchk fmkdir, imerr + +begin + # Clear junk text at the end of the filename. + call aclrc (IM_PIXFILE(im), SZ_IMPIXFILE) + + # Check for the null image. + if (fnullfile (IM_HDRFILE(im))) { + call strcpy ("dev$null", IM_PIXFILE(im), SZ_IMPIXFILE) + call strcpy (IM_PIXFILE(im), pixfile, maxch) + return + } + + call smark (sp) + call salloc (imdir, SZ_PATHNAME, TY_CHAR) + call salloc (osdir, SZ_PATHNAME, TY_CHAR) + call salloc (root, SZ_PATHNAME, TY_CHAR) + call salloc (subdir, SZ_PATHNAME, TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + + if (envgets ("imdir", Memc[imdir], SZ_PATHNAME) <= 0) + call strcpy (HDR, Memc[imdir], SZ_PATHNAME) + + if (strncmp (Memc[imdir], HDR, STRLEN_HDR) == 0) { + # Put pixfile in same directory as the header or in a subdirectory. + # In the latter case, create the directory if it does not already + # exist. + + ip = imdir + STRLEN_HDR + for (op=subdir; Memc[ip] != EOS && Memc[ip] != '/'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + + if (Memc[subdir] != EOS) { + n = fnldir (IM_HDRFILE(im), Memc[fname], SZ_PATHNAME) + call fpathname (Memc[fname], Memc[fname], SZ_PATHNAME) + call zfsubd (Memc[fname], SZ_PATHNAME, Memc[subdir], n) + if (access (Memc[fname], 0, DIRECTORY_FILE) == NO) + call fmkdir (Memc[fname]) + } + } else + call fpathname (Memc[imdir], Memc[imdir], SZ_PATHNAME) + + # Make up the root name of the new pixel file. Take the root part of + # the header file and escape sequence encode it. We have to do this + # because it is to be concatenated to an OS directory name, which will + # prevent translation of the root file name during normal filename + # mapping. + + if (fnroot (IM_HDRFILE(im), Memc[fname], SZ_PATHNAME) <= 0) + call strcpy (pixextn, Memc[fname], SZ_PATHNAME) + call iki_mkfname (Memc[fname], pixextn, Memc[fname], SZ_PATHNAME) + call vfn_translate (Memc[fname], Memc[osdir], len_osdir, + Memc[root], len_root, Memc[extn], len_extn) + + suffix[1] = 'a' + suffix[2] = 'a' + suffix[3] = EOS + + for (n=0; ; n=n+1) { + call sprintf (IM_PIXFILE(im), SZ_PATHNAME, "%s%s.%s") + call pargstr (Memc[imdir]) + call pargstr (Memc[root]) + call pargstr (pixextn) + + call oif_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), pixfile, maxch) + + # Ensure that the filename is unique. + if (access (pixfile, 0,0) == YES) { + if (n == 0) { + for (op=root; Memc[op] != EOS; op=op+1) + ; + } else { + if (suffix[2] == 'z') { + suffix[2] = 'a' + if (suffix[1] == 'z') + call imerr (IM_NAME(im), SYS_FMKTEMP) + else + suffix[1] = suffix[1] + 1 + } else + suffix[2] = suffix[2] + 1 + } + + call strcpy (suffix, Memc[op], 2) + } else + break + } + + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifopen.x b/sys/imio/iki/oif/oifopen.x new file mode 100644 index 00000000..a280f163 --- /dev/null +++ b/sys/imio/iki/oif/oifopen.x @@ -0,0 +1,137 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imio.h> +include <fio.h> +include "oif.h" + +# OIF_OPEN -- Open/create an image. + +procedure oif_open (kernel, im, o_im, root, extn, ksection, cl_index, cl_size, acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I old image, if new_copy image +char root[ARB] #I root image name +char extn[ARB] #I extension, if any +char ksection[ARB] #I NOT USED +int cl_index #I NOT USED +int cl_size #I NOT USED +int acmode #I access mode +int status #O return value + +pointer sp, fname, pixfile +int hfd, nchars, mode, junk +int open(), oif_rdhdr(), access(), protect(), envgeti() +bool envgetb(), fnullfile() +errchk syserrs +define err_ 91 + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (pixfile, SZ_PATHNAME, TY_CHAR) + + status = OK + + # The only valid cl_index is -1 (none specified) or 1. + if (!(cl_index < 0 || cl_index == 1)) + goto err_ + + # This kernel does not permit a kernel section to be used. + if (ksection[1] != EOS) + call syserrs (SYS_IKIKSECTNS, Memc[fname]) + + # Determine access mode for header file. + if (acmode == NEW_COPY || acmode == NEW_IMAGE) + mode = NEW_FILE + else + mode = acmode + + # Generate full header file name; the extension may be either ".imh" + # or nothing, and was set earlier by oif_access(). + + if (mode == NEW_FILE && extn[1] == EOS) + call iki_mkfname (root, OIF_HDREXTN, Memc[fname], SZ_PATHNAME) + else + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + + # Delete any old image if one exists and imclobber is enabled. + if (mode == NEW_FILE && !fnullfile (Memc[fname]) && + (access (Memc[fname], 0,0) == YES)) { + + if (envgetb ("imclobber")) { + iferr (hfd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + status = ERR + goto err_ + } + nchars = LEN_IMHDR * SZ_MII_INT + if (oif_rdhdr (hfd, im, nchars, TY_IMHDR) < 0) { + status = ERR + goto err_ + } + if (IM_PIXFILE(im) != EOS) { + call oif_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), + Memc[pixfile], SZ_PATHNAME) + if (access (Memc[pixfile],0,0) == YES) + iferr (call delete (Memc[pixfile])) + call erract (EA_WARN) + } + call close (hfd) + iferr (junk = protect (Memc[fname], REMOVE_PROTECTION)) + ; + iferr (call delete (Memc[fname])) + call erract (EA_WARN) + } else + call syserrs (SYS_IKICLOB, Memc[fname]) + } + + # Open the image header file. + iferr (hfd = open (Memc[fname], mode, BINARY_FILE)) + goto err_ + + IM_HFD(im) = hfd + + # If opening an existing image, read the OIF fixed format binary + # image header into the image descriptor. If opening a new image, + # write out a generic image header so that the image can be accessed + # and deleted with imdelete should the operation be aborted before + # a full image is written. + + if (mode == NEW_FILE) { + iferr (IM_HDRVER(im) = envgeti (ENV_OIFVER)) + IM_HDRVER(im) = DEF_VERSION + call aclrc (IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (Memc[fname], IM_HDRFILE(im), SZ_IMHDRFILE) + iferr (call oif_updhdr (im, status)) + ; + } else { + iferr { + nchars = (IM_LENHDRMEM(im) - LEN_IMHDR) * SZ_MII_INT + if (oif_rdhdr (hfd, im, nchars, TY_IMHDR) < 0) + status = ERR + else { + call aclrc (IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (Memc[fname], IM_HDRFILE(im), SZ_IMHDRFILE) + } + } then + status = ERR + } + + # It is best to close the header file at this point for two reasons: + # to improve error recovery (if an abort occurs with a new file still + # open FIO will delete it) and to free file descriptors (important for + # applications that open many images). If the header needs to be + # updated, oif_updhdr will reopen the header file. + + call close (hfd) + IM_HFD(im) = NULL + + call sfree (sp) + return +err_ + status = ERR + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifopix.x b/sys/imio/iki/oif/oifopix.x new file mode 100644 index 00000000..c9652374 --- /dev/null +++ b/sys/imio/iki/oif/oifopix.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <config.h> +include <imhdr.h> +include <imio.h> +include "oif.h" + +# OIF_OPIX -- Open (or create) the pixel storage file. If the image header file +# is `image.imh' the associated pixel storage file will be `imdir$image.pix', +# or some variation thereon should a collision occur. The environment variable +# IMDIR controls where the pixfile will be placed. The following classes of +# values are provided: +# +# path Put pixfile in named absolute directory regardless of +# where the header file is. +# ./ Put pixfile in the current directory at image creation +# time (special case of previous case). +# HDR$ Put pixfile in the same directory as the header file. +# HDR$subdir/ Put pixfiles in the subdirectory `subdir' of the +# directory containing the header file. IMIO will +# create the subdirectory if necessary. + +procedure oif_opix (im, status) + +pointer im # image descriptor +int status # return status + +long pixoff +pointer sp, pixhdr, pixfile +int pfd, blklen + +int open(), fdevblk(), oif_rdhdr() +errchk open, falloc, fdevblk, imerr, oif_rdhdr, oif_updhdr +errchk imioff, oif_wrhdr, oif_mkpixfname, oif_gpixfname, flush + +begin + status = OK + if (IM_PFD(im) != NULL) + return + + + call smark (sp) + call salloc (pixhdr, LEN_IMDES + LEN_PIXHDR, TY_STRUCT) + call salloc (pixfile, SZ_PATHNAME, TY_CHAR) + + switch (IM_ACMODE(im)) { + case READ_ONLY, READ_WRITE, WRITE_ONLY, APPEND: + if (IM_PIXFILE(im) == EOS) + call imerr (IM_NAME(im), SYS_IMRDPIXFILE) + + call oif_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), Memc[pixfile], + SZ_PATHNAME) + pfd = open (Memc[pixfile], IM_ACMODE(im), STATIC_FILE) + + call seek (pfd, BOFL) + if (oif_rdhdr (pfd, pixhdr, 0, TY_PIXHDR) < 0) + call imerr (IM_NAME(im), SYS_IMRDPIXFILE) + + case NEW_COPY, NEW_FILE, TEMP_FILE: + # Generate the pixel file name. + call oif_mkpixfname (im, Memc[pixfile], SZ_PATHNAME) + + # Compute the offset to the pixels in the pixfile. Allow space + # for the pixhdr pixel storage file header and start the pixels + # on the next device block boundary. + + blklen = fdevblk (Memc[pixfile]) + pixoff = LEN_PIXHDR * SZ_MII_INT + call imalign (pixoff, blklen) + + # Call IMIO to initialize the physical dimensions of the image + # and the absolute file offsets of the major components of the + # pixel storage file. + + call imioff (im, pixoff, COMPRESS, blklen) + + # Open the new pixel storage file (preallocate space if + # enabled on local system). Save the physical pathname of + # the pixfile in the image header, in case "imdir$" changes. + + if (IM_FALLOC == YES) { + call falloc (Memc[pixfile], IM_HGMOFF(im) - 1) + pfd = open (Memc[pixfile], READ_WRITE, STATIC_FILE) + } else + pfd = open (Memc[pixfile], NEW_FILE, BINARY_FILE) + + # Write small header into pixel storage file. Allows detection of + # headerless pixfiles, and reconstruction of header if it gets lost. + + call oif_wrhdr (pfd, im, TY_PIXHDR) + call flush (pfd) + + # Update the image header so that it knows about the pixel file. + call oif_updhdr (im, status) + + default: + call imerr (IM_NAME(im), SYS_IMACMODE) + } + + IM_PFD(im) = pfd + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifrdhdr.x b/sys/imio/iki/oif/oifrdhdr.x new file mode 100644 index 00000000..b11601cb --- /dev/null +++ b/sys/imio/iki/oif/oifrdhdr.x @@ -0,0 +1,196 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <imhdr.h> +include <imio.h> +include "imhv1.h" +include "imhv2.h" +include "oif.h" + + +# OIF_RDHDR -- Read the image header. Either the main image header or the +# pixel file header can be read. + +int procedure oif_rdhdr (fd, im, uchars, htype) + +int fd #I header file descriptor +pointer im #I image descriptor +int uchars #I maxchars of user area data to read +int htype #I TY_IMHDR or TY_PIXHDR + +pointer sp, v1 +char immagic[SZ_IMMAGIC] +int sulen_userarea, hdrlen, nchars, status + +bool streq() +int miireadc(), miireadi(), miireadl(), miireadr() +int btoi(), read() + +errchk read, miireadc, miireadi, miireadl, miireadr +define readerr_ 91 + +begin + # Determine the file type. + call seek (fd, BOFL) + if (read (fd, immagic, SZ_IMMAGIC) != SZ_IMMAGIC) + return (ERR) + + if (htype == TY_PIXHDR && streq (immagic, V1_PMAGIC)) { + # V1 Pixel file header. + return (OK) + + } else if (htype == TY_IMHDR && streq (immagic, V1_MAGIC)) { + # Old V1 image header. + + call smark (sp) + call salloc (v1, LEN_V1IMHDR, TY_STRUCT) + + call seek (fd, BOFL) + nchars = LEN_V1IMHDR * SZ_MII_INT + if (read (fd, IM_V1MAGIC(v1), nchars) != nchars) { + call sfree (sp) + return (ERR) + } + + # Initialize the output image header. + call strcpy (IMH_MAGICSTR, IM_MAGIC(im), SZ_IMMAGIC) + IM_HDRVER(im) = V1_VERSION + + # The following is the length of the user area in SU. + sulen_userarea = IM_V1HDRLEN(v1) - LEN_V1IMHDR + IM_HDRLEN(im) = LEN_IMHDR + sulen_userarea + + IM_SWAP(im) = NO + IM_SWAPPED(im) = -1 + IM_PIXTYPE(im) = IM_V1PIXTYPE(v1) + + IM_NDIM(im) = IM_V1NDIM(v1) + call amovl (IM_V1LEN(v1,1), IM_LEN(im,1), IM_MAXDIM) + call amovl (IM_V1PHYSLEN(v1,1), IM_PHYSLEN(im,1), IM_MAXDIM) + + IM_SSMTYPE(im) = IM_V1SSMTYPE(v1) + IM_LUTOFF(im) = IM_V1LUTOFF(v1) + IM_PIXOFF(im) = IM_V1PIXOFF(v1) + IM_HGMOFF(im) = IM_V1HGMOFF(v1) + IM_CTIME(im) = IM_V1CTIME(v1) + IM_MTIME(im) = IM_V1MTIME(v1) + IM_LIMTIME(im) = IM_V1LIMTIME(v1) + IM_MAX(im) = IM_V1MAX(v1) + IM_MIN(im) = IM_V1MIN(v1) + + call strcpy (IM_V1PIXFILE(v1), IM_PIXFILE(im), SZ_IMPIXFILE) + call strcpy (IM_V1HDRFILE(v1), IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (IM_V1TITLE(v1), IM_TITLE(im), SZ_IMTITLE) + call strcpy (IM_V1HISTORY(v1), IM_HISTORY(im), SZ_IMHIST) + + # Read and output the user area. + if (uchars > 0 && sulen_userarea > 0) { + nchars = min (uchars, sulen_userarea * SZ_MII_INT) + if (read (fd, Memc[IM_USERAREA(im)], nchars) <= 0) + return (ERR) + } + + call sfree (sp) + return (OK) + } + + # Check for a new format header. + call seek (fd, BOFL) + if (miireadc (fd, immagic, SZ_IMMAGIC) < 0) + return (ERR) + + if (htype == TY_PIXHDR && streq (immagic, V2_PMAGIC)) { + # V2 Pixel file header. + return (OK) + + } else if (htype == TY_IMHDR && streq (immagic, V2_MAGIC)) { + # Newer V2 image header. + status = ERR + + # Initialize the output image header. + call strcpy (IMH_MAGICSTR, IM_MAGIC(im), SZ_IMMAGIC) + IM_HDRVER(im) = V2_VERSION + + # "sulen_userarea" is the length of the user area in SU. + if (miireadi (fd, hdrlen, 1) != 1) + goto readerr_ + sulen_userarea = hdrlen - LEN_V2IMHDR + IM_HDRLEN(im) = LEN_IMHDR + sulen_userarea + + if (miireadi (fd, IM_PIXTYPE(im), 1) != 1) + goto readerr_ + + # Determine whether to byte swap the pixels. + if (miireadi (fd, IM_SWAPPED(im), 1) != 1) + goto readerr_ + + IM_SWAP(im) = NO + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT: + IM_SWAP(im) = btoi (IM_SWAPPED(im) != BYTE_SWAP2) + case TY_INT, TY_LONG: + IM_SWAP(im) = btoi (IM_SWAPPED(im) != BYTE_SWAP4) + case TY_REAL: + if (IEEE_USED == YES) + IM_SWAP(im) = btoi (IM_SWAPPED(im) != IEEE_SWAP4) + case TY_DOUBLE: + if (IEEE_USED == YES) + IM_SWAP(im) = btoi (IM_SWAPPED(im) != IEEE_SWAP8) + } + + # Read the fixed-format fields of the header. + if (miireadi (fd, IM_NDIM(im), 1) < 0) + goto readerr_ + if (miireadi (fd, IM_LEN(im,1), IM_MAXDIM) < 0) + goto readerr_ + if (miireadl (fd, IM_PHYSLEN(im,1), IM_MAXDIM) < 0) + goto readerr_ + if (miireadl (fd, IM_SSMTYPE(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_LUTOFF(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_PIXOFF(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_HGMOFF(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_BLIST(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_SZBLIST(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_NBPIX(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_CTIME(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_MTIME(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_LIMTIME(im), 1) < 0) + goto readerr_ + + if (miireadr (fd, IM_MAX(im), 1) < 0) + goto readerr_ + if (miireadr (fd, IM_MIN(im), 1) < 0) + goto readerr_ + + if (miireadc (fd, IM_PIXFILE(im), SZ_V2IMPIXFILE) < 0) + goto readerr_ + if (miireadc (fd, IM_HDRFILE(im), SZ_V2IMHDRFILE) < 0) + goto readerr_ + if (miireadc (fd, IM_TITLE(im), SZ_V2IMTITLE) < 0) + goto readerr_ + if (miireadc (fd, IM_HISTORY(im), SZ_V2IMHIST) < 0) + goto readerr_ + + # Read the variable-length user area. + if (uchars > 0 && sulen_userarea > 0) { + nchars = min (uchars, sulen_userarea * SZ_MII_INT) + if (miireadc (fd, Memc[IM_USERAREA(im)], nchars) < 0) + goto readerr_ + } + + status = OK +readerr_ + return (status) + } + + return (ERR) +end diff --git a/sys/imio/iki/oif/oifrename.x b/sys/imio/iki/oif/oifrename.x new file mode 100644 index 00000000..edba1bcd --- /dev/null +++ b/sys/imio/iki/oif/oifrename.x @@ -0,0 +1,102 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include <imio.h> +include "oif.h" + +# OIF_RENAME -- Rename an image. A special operator is required since the image +# is stored as two files. + +procedure oif_rename (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] # old image root name +char old_extn[ARB] # old image extn +char new_root[ARB] # new image root name +char new_extn[ARB] # old image extn +int status + +pointer sp, im +bool heq, peq +pointer old_hfn, new_hfn +pointer old_pfn, new_pfn +int nchars, old_rootoff, new_rootoff, junk + +bool streq() +pointer immapz() +int access(), strlen(), strncmp() +errchk immapz, rename + +begin + call smark (sp) + call salloc (old_hfn, SZ_PATHNAME, TY_CHAR) + call salloc (new_hfn, SZ_PATHNAME, TY_CHAR) + call salloc (old_pfn, SZ_PATHNAME, TY_CHAR) + call salloc (new_pfn, SZ_PATHNAME, TY_CHAR) + + # Get filenames of old and new images. + call iki_mkfname (old_root, old_extn, Memc[old_hfn], SZ_PATHNAME) + call iki_mkfname (new_root, OIF_HDREXTN, Memc[new_hfn], SZ_PATHNAME) + heq = streq (Memc[old_hfn], Memc[new_hfn]) + + # Our task here is nontrivial as the pixel file must be renamed as + # well as the header file, e.g., since renaming the header file may + # move it to a different directory, and the PIXFILE field in the + # image header may indicate that the pixel file is in the same dir + # as the header. Must open image, get pixfile name from the header, + # and generate the new pixfile name. The CURRENT value of IMDIR is + # used to generate the new pixfile name. + + im = immapz (Memc[old_hfn], READ_WRITE, 0) + + if (IM_PIXFILE(im) != EOS) { + # Get old pixel file filename. + call oif_gpixfname (IM_PIXFILE(im), Memc[old_hfn], Memc[old_pfn], + SZ_PATHNAME) + + # Get new pixel file filename. + call strcpy (Memc[new_hfn], IM_HDRFILE(im), SZ_IMHDRFILE) + call oif_mkpixfname (im, Memc[new_pfn], SZ_PATHNAME) + + # Do not change the pixel file name if the name does not change + # other than by the addition of the "aa" style suffix added by + # mkpixfname. + + peq = false + call zfnbrk (old_root, old_rootoff, junk) + call zfnbrk (new_root, new_rootoff, junk) + peq = streq (old_root[old_rootoff], new_root[new_rootoff]) + + if (peq) { + nchars = strlen (Memc[new_pfn]) - strlen ("aa.imh") + peq = (strncmp (Memc[old_pfn], Memc[new_pfn], nchars) == 0) + } + + if (peq) + IM_UPDATE(im) = NO + else { + # If the pixel file rename fails do not rename the header file + # and do not change the name of the pixel file in the header. + + iferr (call rename (Memc[old_pfn], Memc[new_pfn])) { + if (access (Memc[old_pfn], 0, 0) == YES) { + IM_UPDATE(im) = NO + call imunmap (im) + call erract (EA_ERROR) + } + } + } + + } else + call strcpy (Memc[new_hfn], IM_HDRFILE(im), SZ_IMHDRFILE) + + call strcpy (Memc[old_hfn], IM_HDRFILE(im), SZ_IMHDRFILE) + call imunmap (im) + + # Rename the header file. + if (!heq) + call rename (Memc[old_hfn], Memc[new_hfn]) + + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifupdhdr.x b/sys/imio/iki/oif/oifupdhdr.x new file mode 100644 index 00000000..516d62c1 --- /dev/null +++ b/sys/imio/iki/oif/oifupdhdr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imio.h> +include "oif.h" + +# OIF_UPDHDR -- Update the image header. + +procedure oif_updhdr (im, status) + +pointer im #I image descriptor +int status #O return status + +int hfd +errchk imerr, open, oif_wrhdr, flush +int open() + +begin + status = OK + hfd = IM_HFD(im) + + if (IM_ACMODE(im) == READ_ONLY) + call imerr (IM_NAME(im), SYS_IMUPIMHDR) + if (hfd == NULL) + hfd = open (IM_HDRFILE(im), READ_WRITE, BINARY_FILE) + + call oif_wrhdr (hfd, im, TY_IMHDR) + call flush (hfd) + + if (IM_HFD(im) == NULL) + call close (hfd) +end diff --git a/sys/imio/iki/oif/oifwrhdr.x b/sys/imio/iki/oif/oifwrhdr.x new file mode 100644 index 00000000..7b4e7349 --- /dev/null +++ b/sys/imio/iki/oif/oifwrhdr.x @@ -0,0 +1,233 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <mach.h> +include <imio.h> +include "imhv1.h" +include "imhv2.h" +include "oif.h" + +# OIF_WRHDR -- Write an OIF image header. + +procedure oif_wrhdr (fd, im, htype) + +int fd #I header file descriptor +pointer im #I image descriptor +int htype #I TY_IMHDR or TY_PIXHDR + +pointer sp, v1, fname +int status, hdrlen, len_userarea +errchk write, miiwritec, miiwritei, miiwritel, miiwriter +int strlen() + +define v1done_ 91 +define v2start_ 92 +define v2done_ 93 + +begin + switch (IM_HDRVER(im)) { + case V1_VERSION: + # Old V1 image header. + # ---------------------- + + status = ERR + call smark (sp) + call salloc (v1, LEN_V1IMHDR, TY_STRUCT) + + # Initialize the output image header. + switch (htype) { + case TY_IMHDR: + call strcpy (V1_MAGIC, IM_V1MAGIC(v1), SZ_IMMAGIC) + hdrlen = LEN_V1IMHDR + case TY_PIXHDR: + call strcpy (V1_PMAGIC, IM_V1MAGIC(v1), SZ_IMMAGIC) + hdrlen = LEN_V1PIXHDR + default: + goto v1done_ + } + + # The following is the length of the user area in chars. + len_userarea = strlen (Memc[IM_USERAREA(im)]) + 1 + IM_V1HDRLEN(v1) = LEN_V1IMHDR + + (len_userarea + SZ_MII_INT-1) / SZ_MII_INT + + IM_V1PIXTYPE(v1) = IM_PIXTYPE(im) + IM_V1NDIM(v1) = IM_NDIM(im) + call amovl (IM_LEN(im,1), IM_V1LEN(v1,1), IM_MAXDIM) + call amovl (IM_PHYSLEN(im,1), IM_V1PHYSLEN(v1,1), IM_MAXDIM) + + IM_V1SSMTYPE(v1) = IM_SSMTYPE(im) + IM_V1LUTOFF(v1) = IM_LUTOFF(im) + IM_V1PIXOFF(v1) = IM_PIXOFF(im) + IM_V1HGMOFF(v1) = IM_HGMOFF(im) + IM_V1CTIME(v1) = IM_CTIME(im) + IM_V1MTIME(v1) = IM_MTIME(im) + IM_V1LIMTIME(v1) = IM_LIMTIME(im) + IM_V1MAX(v1) = IM_MAX(im) + IM_V1MIN(v1) = IM_MIN(im) + + if (strlen(IM_PIXFILE(im)) > SZ_V1IMPIXFILE) + goto v1done_ + if (strlen(IM_HDRFILE(im)) > SZ_V1IMHDRFILE) + goto v1done_ + + call strcpy (IM_PIXFILE(im), IM_V1PIXFILE(v1), SZ_V1IMPIXFILE) + call strcpy (IM_HDRFILE(im), IM_V1HDRFILE(v1), SZ_V1IMHDRFILE) + call strcpy (IM_TITLE(im), IM_V1TITLE(v1), SZ_V1IMTITLE) + call strcpy (IM_HISTORY(im), IM_V1HISTORY(v1), SZ_V1IMHIST) + + # For historical reasons the pixel file header stores the host + # pathname of the header file in the PIXFILE field of the pixel + # file header. + + if (htype == TY_PIXHDR) + call fpathname (IM_HDRFILE(im), IM_V1PIXFILE(v1), + SZ_V1IMPIXFILE) + + # Write the file header. + call seek (fd, BOFL) + call write (fd, IM_V1MAGIC(v1), hdrlen * SZ_MII_INT) + + # Write the user area. + if (htype == TY_IMHDR) + call write (fd, Memc[IM_USERAREA(im)], len_userarea) + + status = OK +v1done_ + call sfree (sp) + if (status != OK) + call syserrs (SYS_IKIUPDHDR, IM_NAME(im)) + + case V2_VERSION: + # Newer V2 image header. + # ---------------------- +v2start_ + status = ERR + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call seek (fd, BOFL) + + # Initialize the output image header. + switch (htype) { + case TY_IMHDR: + call miiwritec (fd, V2_MAGIC, SZ_IMMAGIC) + hdrlen = LEN_V2IMHDR + case TY_PIXHDR: + call miiwritec (fd, V2_PMAGIC, SZ_IMMAGIC) + hdrlen = LEN_V2PIXHDR + default: + goto v2done_ + } + + # The following is the length of the user area in SU. + len_userarea = strlen (Memc[IM_USERAREA(im)]) + 1 + hdrlen = LEN_V2IMHDR + (len_userarea + SZ_MII_INT-1) / SZ_MII_INT + + call miiwritei (fd, hdrlen, 1) + call miiwritei (fd, IM_PIXTYPE(im), 1) + + # Record the byte swapping used for this image. When writing a + # new image we use the native data type of the host and don't + # swap bytes, so IM_SWAPPED is YES if the host architecture is + # byte swapped. + + switch (IM_ACMODE(im)) { + case NEW_IMAGE, NEW_COPY, TEMP_FILE: + IM_SWAPPED(im) = -1 + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT: + IM_SWAPPED(im) = BYTE_SWAP2 + case TY_INT, TY_LONG: + IM_SWAPPED(im) = BYTE_SWAP4 + case TY_REAL: + if (IEEE_USED == YES) + IM_SWAPPED(im) = IEEE_SWAP4 + case TY_DOUBLE: + if (IEEE_USED == YES) + IM_SWAPPED(im) = IEEE_SWAP8 + } + default: + # IM_SWAPPED should already be set in header. + } + + call miiwritei (fd, IM_SWAPPED(im), 1) + call miiwritei (fd, IM_NDIM(im), 1) + call miiwritel (fd, IM_LEN(im,1), IM_MAXDIM) + call miiwritel (fd, IM_PHYSLEN(im,1), IM_MAXDIM) + call miiwritel (fd, IM_SSMTYPE(im), 1) + call miiwritel (fd, IM_LUTOFF(im), 1) + call miiwritel (fd, IM_PIXOFF(im), 1) + call miiwritel (fd, IM_HGMOFF(im), 1) + call miiwritel (fd, IM_BLIST(im), 1) + call miiwritel (fd, IM_SZBLIST(im), 1) + call miiwritel (fd, IM_NBPIX(im), 1) + call miiwritel (fd, IM_CTIME(im), 1) + call miiwritel (fd, IM_MTIME(im), 1) + call miiwritel (fd, IM_LIMTIME(im), 1) + call miiwriter (fd, IM_MAX(im), 1) + call miiwriter (fd, IM_MIN(im), 1) + + if (strlen(IM_PIXFILE(im)) > SZ_V2IMPIXFILE) + goto v2done_ + if (strlen(IM_HDRFILE(im)) > SZ_V2IMHDRFILE) + goto v2done_ + + # For historical reasons the pixel file header stores the host + # pathname of the header file in the PIXFILE field of the pixel + # file header. + + if (htype == TY_PIXHDR) { + call aclrc (Memc[fname], SZ_PATHNAME) + call fpathname (IM_HDRFILE(im), Memc[fname], SZ_PATHNAME) + call miiwritec (fd, Memc[fname], SZ_V2IMPIXFILE) + status = OK + goto v2done_ + } else + call miiwritec (fd, IM_PIXFILE(im), SZ_V2IMPIXFILE) + + call oif_trim (IM_HDRFILE(im), SZ_V2IMHDRFILE) + call miiwritec (fd, IM_HDRFILE(im), SZ_V2IMHDRFILE) + + call oif_trim (IM_TITLE(im), SZ_V2IMTITLE) + call miiwritec (fd, IM_TITLE(im), SZ_V2IMTITLE) + + call oif_trim (IM_HISTORY(im), SZ_V2IMHIST) + call miiwritec (fd, IM_HISTORY(im), SZ_V2IMHIST) + + # Write the variable-length user area. + call miiwritec (fd, Memc[IM_USERAREA(im)], len_userarea) + + status = OK +v2done_ + call sfree (sp) + if (status != OK) + call syserrs (SYS_IKIUPDHDR, IM_NAME(im)) + + default: + IM_HDRVER(im) = V2_VERSION + goto v2start_ + } +end + + +# OIF_TRIM -- Trim trailing garbage at the end of a string. This does not +# affect the value of the string, but makes the contents of the output file +# clearer when examined with file utilities. + +procedure oif_trim (s, nchars) + +char s[ARB] +int nchars + +int n, ntrim +int strlen() + +begin + n = strlen(s) + 1 + ntrim = nchars - n + + if (ntrim > 0) + call aclrc (s[n], ntrim) +end diff --git a/sys/imio/iki/plf/README b/sys/imio/iki/plf/README new file mode 100644 index 00000000..0a2065c7 --- /dev/null +++ b/sys/imio/iki/plf/README @@ -0,0 +1,5 @@ +PLF -- Partial, IKI mini-driver for the pixel list (PLIO) image format. + +Only part of the IKI routines are implemented here. The open/close, header +access, and i/o functions are handled as a special case directly in the +IMIO code (see the impm*.x routines, and im[rd|wr]px.x). diff --git a/sys/imio/iki/plf/mkpkg b/sys/imio/iki/plf/mkpkg new file mode 100644 index 00000000..4253544e --- /dev/null +++ b/sys/imio/iki/plf/mkpkg @@ -0,0 +1,17 @@ +# Make the PLF image kernel (PLIO mask image kernel). + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + plfaccess.x plf.h + plfclose.x <imhdr.h> <imio.h> <plset.h> + plfcopy.x plf.h <error.h> + plfdelete.x <error.h> + plfnull.x + plfopen.x <imhdr.h> <imio.h> <plio.h> <pmset.h> + plfrename.x plf.h <error.h> + plfupdhdr.x <imhdr.h> <imio.h> <plset.h> + ; diff --git a/sys/imio/iki/plf/plf.h b/sys/imio/iki/plf/plf.h new file mode 100644 index 00000000..7fc666a9 --- /dev/null +++ b/sys/imio/iki/plf/plf.h @@ -0,0 +1,4 @@ +# PLF.H -- IKI/PLF internal definitions. + +define PLF_EXTN "pl" # image header filename extension +define MAX_LENEXTN 3 # max length imagefile extension diff --git a/sys/imio/iki/plf/plfaccess.x b/sys/imio/iki/plf/plfaccess.x new file mode 100644 index 00000000..bf4ed5a9 --- /dev/null +++ b/sys/imio/iki/plf/plfaccess.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "plf.h" + +# PLF_ACCESS -- Test the accessibility or existence of an existing image, +# or the legality of the name of a new image. + +procedure plf_access (kernel, root, extn, acmode, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #U extension (SET on output if none specified) +int acmode #I access mode (0 to test only existence) +int status #O ok or err + +pointer sp, fname +int btoi(), access(), iki_validextn() +string plf_extn PLF_EXTN + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # If new image, test only the legality of the given extension. + # This is used to select a kernel given the imagefile extension. + + status = NO + if (extn[1] != EOS) + status = btoi (iki_validextn (kernel, extn) > 0) + + if (acmode != NEW_IMAGE && acmode != NEW_COPY) { + if (extn[1] == EOS) { + call iki_mkfname (root, plf_extn, Memc[fname], SZ_PATHNAME) + status = access (Memc[fname], acmode, 0) + if (status != NO) + call strcpy (plf_extn, extn, MAX_LENEXTN) + } else if (status != NO) { + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + status = access (Memc[fname], acmode, 0) + } + } + + call sfree (sp) +end diff --git a/sys/imio/iki/plf/plfclose.x b/sys/imio/iki/plf/plfclose.x new file mode 100644 index 00000000..2d2454e0 --- /dev/null +++ b/sys/imio/iki/plf/plfclose.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <plset.h> + +# PLF_CLOSE -- Close a mask image. + +procedure plf_close (im, status) + +pointer im #I image descriptor +int status #O output status + +begin + if (IM_PFD(im) != NULL) + call close (IM_PFD(im)) + if (and (IM_PLFLAGS(im), PL_CLOSEPL) != 0) + call pl_close (IM_PL(im)) + + IM_PL(im) = NULL +end diff --git a/sys/imio/iki/plf/plfcopy.x b/sys/imio/iki/plf/plfcopy.x new file mode 100644 index 00000000..4cfb2b6e --- /dev/null +++ b/sys/imio/iki/plf/plfcopy.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include "plf.h" + +# PLF_COPY -- Copy an image. A special operator is provided for fast, blind +# copies of entire images. + +procedure plf_copy (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] #I old image root name +char old_extn[ARB] #I old image extn +char new_root[ARB] #I new image root name +char new_extn[ARB] #I new extn +int status #O output status + +pointer sp +pointer oldname, newname + +begin + call smark (sp) + call salloc (oldname, SZ_PATHNAME, TY_CHAR) + call salloc (newname, SZ_PATHNAME, TY_CHAR) + + # Get filename of old and new images. + call iki_mkfname (old_root, old_extn, Memc[oldname], SZ_PATHNAME) + call iki_mkfname (new_root, PLF_EXTN, Memc[newname], SZ_PATHNAME) + + # Copy the PLIO mask save file. + iferr (call fcopy (Memc[oldname], Memc[newname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/plf/plfdelete.x b/sys/imio/iki/plf/plfdelete.x new file mode 100644 index 00000000..4fad68aa --- /dev/null +++ b/sys/imio/iki/plf/plfdelete.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> + +# PLF_DELETE -- Delete a PLIO mask savefile (mask image). + +procedure plf_delete (kernel, root, extn, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #I extension +int status #O output status + +pointer sp, fname +errchk delete + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + iferr (call delete (Memc[fname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/plf/plfnull.x b/sys/imio/iki/plf/plfnull.x new file mode 100644 index 00000000..83ec77cd --- /dev/null +++ b/sys/imio/iki/plf/plfnull.x @@ -0,0 +1,9 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PLF_NULL -- Null driver entry point. + +procedure plf_null() + +begin + call error (1, "PLF image kernel abort - null driver entry point") +end diff --git a/sys/imio/iki/plf/plfopen.x b/sys/imio/iki/plf/plfopen.x new file mode 100644 index 00000000..ec65d647 --- /dev/null +++ b/sys/imio/iki/plf/plfopen.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include <pmset.h> +include <plio.h> + + +# PLF_OPEN -- Open a PMIO mask on an image descriptor. + +procedure plf_open (kernel, im, o_im, + root, extn, ksection, cl_index, cl_size, acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I [not used] +char root[ARB] #I root image name +char extn[ARB] #I filename extension +char ksection[ARB] #I QPIO filter expression +int cl_index #I [not used] +int cl_size #I [not used] +int acmode #I [not used] +int status #O ok|err + +pointer sp, fname, hp, pl +int naxes, axlen[IM_MAXDIM], depth +bool envgetb(), fnullfile() +pointer pl_open() +int access() +errchk imerr + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (hp, IM_LENHDRMEM(im), TY_CHAR) + + # The only valid cl_index for a PL image is -1 (none specified) or 1. + if (!(cl_index < 0 || cl_index == 1)) { + call sfree (sp) + status = ERR + return + } + + # Get mask file name. + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + call aclrc (IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (Memc[fname], IM_HDRFILE(im), SZ_IMHDRFILE) + + # Open an empty mask. + pl = pl_open (NULL) + + if (acmode == NEW_IMAGE || acmode == NEW_COPY) { + # Check that we will not be clobbering an existing mask. + if (!fnullfile(Memc[fname]) && access (Memc[fname], 0, 0) == YES) + if (envgetb ("imclobber")) { + iferr (call delete (Memc[fname])) + ; + } else { + call pl_close (pl) + call imerr (IM_NAME(im), SYS_IKICLOB) + } + } else { + # Load the named mask if opening an existing mask image. + iferr (call pl_loadf (pl,Memc[fname],Memc[hp],IM_LENHDRMEM(im))) { + call pl_close (pl) + call sfree (sp) + status = ERR + return + } + + # Set the image size. + call pl_gsize (pl, naxes, axlen, depth) + + IM_NDIM(im) = naxes + call amovl (axlen, IM_LEN(im,1), IM_MAXDIM) + call imioff (im, 1, YES, 1) + + # Restore the header cards. + call im_pmldhdr (im, hp) + } + + # More set up of the image descriptor. + IM_PL(im) = pl + IM_PLFLAGS(im) = PL_CLOSEPL + IM_PIXTYPE(im) = TY_INT + + status = OK + call sfree (sp) +end diff --git a/sys/imio/iki/plf/plfrename.x b/sys/imio/iki/plf/plfrename.x new file mode 100644 index 00000000..1ab47507 --- /dev/null +++ b/sys/imio/iki/plf/plfrename.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include "plf.h" + +# PLF_RENAME -- Rename a PLIO mask savefile (mask image). + +procedure plf_rename (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] #I old image root name +char old_extn[ARB] #I old image extn +char new_root[ARB] #I new image root name +char new_extn[ARB] #I old image extn +int status #O output status + +pointer sp, oldname, newname +errchk rename + +begin + call smark (sp) + call salloc (oldname, SZ_PATHNAME, TY_CHAR) + call salloc (newname, SZ_PATHNAME, TY_CHAR) + + # Get filenames of old and new datafiles. + call iki_mkfname (old_root, old_extn, Memc[oldname], SZ_PATHNAME) + call iki_mkfname (new_root, PLF_EXTN, Memc[newname], SZ_PATHNAME) + + # Rename the datafile. + iferr (call rename (Memc[oldname], Memc[newname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/plf/plfupdhdr.x b/sys/imio/iki/plf/plfupdhdr.x new file mode 100644 index 00000000..e8cb8784 --- /dev/null +++ b/sys/imio/iki/plf/plfupdhdr.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <plset.h> + +# PLF_UPDHDR -- Update the image header. + +procedure plf_updhdr (im, status) + +pointer im #I image descriptor +int status #O output status + +pointer bp +int nchars, flags, sz_buf +int im_pmsvhdr() + +begin + status = OK + + flags = 0 + if (IM_ACMODE(im) == READ_WRITE) + flags = PL_UPDATE + + bp = NULL + iferr { + nchars = im_pmsvhdr (im, bp, sz_buf) + call pl_savef (IM_PL(im), IM_HDRFILE(im), Memc[bp], flags) + } then + status = ERR + + call mfree (bp, TY_CHAR) +end diff --git a/sys/imio/iki/qpf/README b/sys/imio/iki/qpf/README new file mode 100644 index 00000000..cea44538 --- /dev/null +++ b/sys/imio/iki/qpf/README @@ -0,0 +1,2 @@ +IKI/QPF -- IKI kernel for the QPOE (position ordered event file) image format. +See the QPOE source directories for additional information on QPOE. diff --git a/sys/imio/iki/qpf/mkpkg b/sys/imio/iki/qpf/mkpkg new file mode 100644 index 00000000..eb3e8efd --- /dev/null +++ b/sys/imio/iki/qpf/mkpkg @@ -0,0 +1,22 @@ +# Make the IKI/QPF interface (photon image kernel). + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + qpfaccess.x qpf.h + qpfclose.x qpf.h <imhdr.h> <imio.h> + qpfcopy.x qpf.h <error.h> + qpfcopypar.x qpf.h <error.h> <imhdr.h> <imio.h> <qpset.h> + qpfdelete.x <error.h> + qpfopen.x qpf.h <error.h> <imhdr.h> <imio.h> <mach.h>\ + <qpioset.h> <qpset.h> + qpfopix.x qpf.h <imhdr.h> <imio.h> + qpfrename.x qpf.h <error.h> + qpfupdhdr.x + qpfwattr.x qpf.h <ctype.h> <qpioset.h> + qpfwfilter.x qpf.h + zfioqp.x qpf.h <fio.h> <imhdr.h> <imio.h> <mach.h> <qpioset.h> + ; diff --git a/sys/imio/iki/qpf/qpf.h b/sys/imio/iki/qpf/qpf.h new file mode 100644 index 00000000..37e29cee --- /dev/null +++ b/sys/imio/iki/qpf/qpf.h @@ -0,0 +1,20 @@ +# QPF.H -- IKI/QPF internal definitions. + +define QPF_EXTN "qp" # image header filename extension +define MAX_LENEXTN 3 # max length imagefile extension +define SZ_KWNAME 8 # size of a FITS keyword name +define SZ_BIGSTR 64 # max length string per FITS card +define SZ_MAXFILTER 4096 # max size QPIO filter (for log only) + +define LEN_QPFDES 10 +define QPF_IM Memi[$1] # backpointer to image descriptor +define QPF_QP Memi[$1+1] # QPOE datafile descriptor +define QPF_IO Memi[$1+2] # QPIO descriptor +define QPF_XBLOCK Memr[P2R($1+3)] # X block factor for sampling +define QPF_YBLOCK Memr[P2R($1+4)] # Y block factor for sampling +define QPF_VS Memi[$1+5+$2-1] # start vector of active rect +define QPF_VE Memi[$1+7+$2-1] # end vector of active rect +define QPF_IOSTAT Memi[$1+9] # i/o status (byte count) + +# QPOE parameters to be omitted from the IMIO header user parameter list. +define OMIT "|naxes|axlen|datamin|datamax|cretime|modtime|limtime|" diff --git a/sys/imio/iki/qpf/qpfaccess.x b/sys/imio/iki/qpf/qpfaccess.x new file mode 100644 index 00000000..52d0b06f --- /dev/null +++ b/sys/imio/iki/qpf/qpfaccess.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpf.h" + +# QPF_ACCESS -- Test the accessibility or existence of an existing image, +# or the legality of the name of a new image. + +procedure qpf_access (kernel, root, extn, acmode, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #U extension (SET on output if none specified) +int acmode #I access mode (0 to test only existence) +int status #O ok or err + +pointer sp, fname +int btoi(), qp_access(), iki_validextn() +string qpf_extn QPF_EXTN + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # If new image, test only the legality of the given extension. + # This is used to select a kernel given the imagefile extension. + + status = NO + if (extn[1] != EOS) + status = btoi (iki_validextn (kernel, extn) > 0) + + if (acmode != NEW_IMAGE && acmode != NEW_COPY) { + if (extn[1] == EOS) { + call iki_mkfname (root, qpf_extn, Memc[fname], SZ_PATHNAME) + status = qp_access (Memc[fname], acmode) + if (status != NO) + call strcpy (qpf_extn, extn, MAX_LENEXTN) + } else if (status != NO) { + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + status = qp_access (Memc[fname], acmode) + } + } + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfclose.x b/sys/imio/iki/qpf/qpfclose.x new file mode 100644 index 00000000..b4bad7b4 --- /dev/null +++ b/sys/imio/iki/qpf/qpfclose.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "qpf.h" + +# QPF_CLOSE -- Close a QPOE image. + +procedure qpf_close (im, status) + +pointer im #I image descriptor +int status #O output status + +pointer qpf + +begin + # Close the QPF virtual file driver. + if (IM_PFD(im) != NULL) + call close (IM_PFD(im)) + + # Close the various descriptors. + qpf = IM_KDES(im) + if (QPF_IO(qpf) != NULL) + call qpio_close (QPF_IO(qpf)) + if (QPF_QP(qpf) != NULL) + call qp_close (QPF_QP(qpf)) + + call mfree (qpf, TY_STRUCT) +end diff --git a/sys/imio/iki/qpf/qpfcopy.x b/sys/imio/iki/qpf/qpfcopy.x new file mode 100644 index 00000000..ebc2fa5b --- /dev/null +++ b/sys/imio/iki/qpf/qpfcopy.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include "qpf.h" + +# QPF_COPY -- Copy an image. A special operator is provided for fast, blind +# copies of entire images. + +procedure qpf_copy (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] #I old image root name +char old_extn[ARB] #I old image extn +char new_root[ARB] #I new image root name +char new_extn[ARB] #I new extn +int status #O output status + +pointer sp +pointer oldname, newname +errchk qp_copy + +begin + call smark (sp) + call salloc (oldname, SZ_PATHNAME, TY_CHAR) + call salloc (newname, SZ_PATHNAME, TY_CHAR) + + # Get filename of old and new images. + call iki_mkfname (old_root, old_extn, Memc[oldname], SZ_PATHNAME) + call iki_mkfname (new_root, QPF_EXTN, Memc[newname], SZ_PATHNAME) + + # Copy the datafile. + iferr (call qp_copy (Memc[oldname], Memc[newname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfcopypar.x b/sys/imio/iki/qpf/qpfcopypar.x new file mode 100644 index 00000000..cfa94c62 --- /dev/null +++ b/sys/imio/iki/qpf/qpfcopypar.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include <imio.h> +include <qpset.h> +include "qpf.h" + +# QPF_COPYPARAMS -- Copy parameters from the QPOE datafile header into the +# image header. Only scalar parameters are copied. + +procedure qpf_copyparams (im, qp) + +pointer im #I image descriptor +pointer qp #I QPOE descriptor + +int nelem, dtype, maxelem, flags +pointer sp, param, text, comment, datatype, fl, qpf, mw, io + +pointer qp_ofnlu(), qpio_loadwcs() +int qp_gnfn(), qp_queryf(), stridx(), strdic() +errchk qp_ofnlu, qp_gnfn, qp_queryf, imaddi, qp_geti, mw_saveim + +bool qp_getb() +short qp_gets() +int qp_geti(), qp_gstr() +real qp_getr() +double qp_getd() + +begin + call smark (sp) + call salloc (text, SZ_LINE, TY_CHAR) + call salloc (param, SZ_FNAME, TY_CHAR) + call salloc (comment, SZ_COMMENT, TY_CHAR) + call salloc (datatype, SZ_DATATYPE, TY_CHAR) + + qpf = IM_KDES(im) + + # Copy QPOE special keywords. + call imaddi (im, "NAXES", qp_geti(qp,"naxes")) + call imaddi (im, "AXLEN1", qp_geti(qp,"axlen[1]")) + call imaddi (im, "AXLEN2", qp_geti(qp,"axlen[2]")) + call imaddr (im, "XBLOCK", QPF_XBLOCK(qpf)) + call imaddr (im, "YBLOCK", QPF_YBLOCK(qpf)) + + # Output the QPOE filter. + iferr (call qpf_wfilter (qpf, im)) + call erract (EA_WARN) + + # Compute and output any filter attributes. + iferr (call qpf_wattr (qpf, im)) + call erract (EA_WARN) + + # Copy the WCS, if any. + io = QPF_IO(qpf) + if (io != NULL) + ifnoerr (mw = qpio_loadwcs (io)) { + call mw_saveim (mw, im) + call mw_close (mw) + } + + # Copy general keywords. + fl = qp_ofnlu (qp, "*") + + while (qp_gnfn (fl, Memc[param], SZ_FNAME) != EOF) { + # Get the next scalar parameter which has a nonnull value. + nelem = qp_queryf (qp, Memc[param], Memc[datatype], maxelem, + Memc[comment], flags) + if (strdic (Memc[param], Memc[text], SZ_LINE, OMIT) > 0) + next + + dtype = stridx (Memc[datatype], "bcsilrdx") + + # Make entry for a parameter which has no value, or an unprintable + # value. + + if (nelem == 0 || (nelem > 1 && dtype != TY_CHAR) || + dtype < TY_BOOL || dtype > TY_COMPLEX) { + + call sprintf (Memc[text], SZ_LINE, "%14s[%03d] %s") + call pargstr (Memc[datatype]) + call pargi (nelem) + call pargstr (Memc[comment]) + + iferr (call imastr (im, Memc[param], Memc[text])) + call erract (EA_WARN) + next + } + + # Copy parameter to image header. + iferr { + switch (dtype) { + case TY_BOOL: + call imaddb (im, Memc[param], qp_getb(qp,Memc[param])) + case TY_CHAR: + if (qp_gstr (qp, Memc[param], Memc[text], SZ_LINE) > 0) + call imastr (im, Memc[param], Memc[text]) + case TY_SHORT: + call imadds (im, Memc[param], qp_gets(qp,Memc[param])) + case TY_INT, TY_LONG: + call imaddi (im, Memc[param], qp_geti(qp,Memc[param])) + case TY_REAL: + call imaddr (im, Memc[param], qp_getr(qp,Memc[param])) + case TY_DOUBLE: + call imaddd (im, Memc[param], qp_getd(qp,Memc[param])) + case TY_COMPLEX: + ; # not supported. + } + } then { + call erract (EA_WARN) + break + } + } + + call qp_cfnl (fl) + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfdelete.x b/sys/imio/iki/qpf/qpfdelete.x new file mode 100644 index 00000000..c503c174 --- /dev/null +++ b/sys/imio/iki/qpf/qpfdelete.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> + +# QPF_DELETE -- Delete a datafile. + +procedure qpf_delete (kernel, root, extn, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #I extension +int status #O output status + +pointer sp, fname +errchk qp_delete + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + iferr (call qp_delete (Memc[fname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfopen.x b/sys/imio/iki/qpf/qpfopen.x new file mode 100644 index 00000000..99a57df1 --- /dev/null +++ b/sys/imio/iki/qpf/qpfopen.x @@ -0,0 +1,165 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <mach.h> +include <imhdr.h> +include <imio.h> +include <qpset.h> +include <qpioset.h> +include "qpf.h" + +# QPF_OPEN -- Open a QPOE image. New QPOE images can only be written by +# calling QPOE directly; under IMIO, only READ_ONLY access is supported. + +procedure qpf_open (kernel, im, o_im, + root, extn, ksection, cl_index, cl_size, acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I [not used] +char root[ARB] #I root image name +char extn[ARB] #I filename extension +char ksection[ARB] #I QPIO filter expression +int cl_index #I [not used] +int cl_size #I [not used] +int acmode #I [not used] +int status #O ok|err + +int n +real xblock, yblock, tol +pointer sp, qp, io, v, fname, qpf + +pointer qp_open, qpio_open() +real qpio_statr(), qp_statr() +int qpio_getrange(), qp_geti(), qp_gstr(), qp_lenf() +define err_ 91 + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (v, SZ_FNAME, TY_CHAR) + + io = NULL + qp = NULL + qpf = NULL + tol = EPSILONR * 100 + + # The only valid cl_index for a QPOE image is -1 (none specified) or 1. + if (!(cl_index < 0 || cl_index == 1)) + goto err_ + + call malloc (qpf, LEN_QPFDES, TY_STRUCT) + + # Open the QPOE file. + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + iferr (qp = qp_open (Memc[fname], READ_ONLY, 0)) { + qp = NULL + goto err_ + } + + # Open the event list under QPIO for sampled (pixel) i/o. + iferr (io = qpio_open (qp, ksection, READ_ONLY)) + io = NULL + + # Determine the data range and pixel type. + iferr (IM_CTIME(im) = qp_geti (qp, "cretime")) + IM_CTIME(im) = 0 + iferr (IM_MTIME(im) = qp_geti (qp, "modtime")) + IM_MTIME(im) = 0 + iferr (IM_LIMTIME(im) = qp_geti (qp, "limtime")) + IM_LIMTIME(im) = 0 + + # The min and max pixel values for a sampled event file depend + # strongly on the blocking factor, which is a runtime variable. + # Ideally when the poefile is written the vectors 'datamin' and + # 'datamax' should be computed for the main event list. These + # give the min and max pixel values (counts/pixel) for each blocking + # factor from 1 to len(data[min|max]), i.e., the blocking factor + # serves as the index into these vectors. + + if (io != NULL) { + xblock = max (1.0, qpio_statr (io, QPIO_XBLOCKFACTOR)) + yblock = max (1.0, qpio_statr (io, QPIO_YBLOCKFACTOR)) + } else { + xblock = max (1.0, qp_statr (qp, QPOE_XBLOCKFACTOR)) + yblock = max (1.0, qp_statr (qp, QPOE_YBLOCKFACTOR)) + } + call strcpy ("datamax", Memc[v], SZ_FNAME) + n = qp_lenf (qp, Memc[v]) + + if (n >= max(xblock,yblock)) { + call sprintf (Memc[v+7], SZ_FNAME-7, "[%d]") + call pargi (nint((xblock+yblock)/2)) + IM_MAX(im) = qp_geti (qp, Memc[v]) + Memc[v+5] = 'i'; Memc[v+6] = 'n' + IM_MIN(im) = qp_geti (qp, Memc[v]) + } else + IM_LIMTIME(im) = 0 + + # Set the image pixel type. This is arbitrary, provided we have + # enough dynamic range to represent the maximum pixel value. + + IM_PIXTYPE(im) = TY_INT + if (IM_LIMTIME(im) != 0 && IM_LIMTIME(im) >= IM_MTIME(im)) + if (int(IM_MAX(im)) <= MAX_SHORT) + IM_PIXTYPE(im) = TY_SHORT + + # Set the image size parameters. If the user has specified a rect + # within which i/o is to occur, set the logical image size to the + # size of the rect rather than the full matrix. + + if (io != NULL) { + IM_NDIM(im) = qpio_getrange (io, QPF_VS(qpf,1), QPF_VE(qpf,1), 2) + IM_LEN(im,1) = (QPF_VE(qpf,1) - QPF_VS(qpf,1) + 1) / xblock + tol + IM_LEN(im,2) = (QPF_VE(qpf,2) - QPF_VS(qpf,2) + 1) / yblock + tol + } else { + IM_NDIM(im) = 2 + IM_LEN(im,1) = qp_geti (qp, "axlen[1]") / xblock + tol + IM_LEN(im,2) = qp_geti (qp, "axlen[2]") / yblock + tol + QPF_VS(qpf,1) = 1; QPF_VE(qpf,1) = IM_LEN(im,1) + QPF_VS(qpf,2) = 1; QPF_VE(qpf,2) = IM_LEN(im,2) + } + call imioff (im, 1, YES, 1) + + iferr (n = qp_gstr (qp, "title", IM_TITLE(im), SZ_IMTITLE)) + IM_TITLE(im) = EOS + iferr (n = qp_gstr (qp, "history", IM_HISTORY(im), SZ_IMHIST)) + IM_HISTORY(im) = EOS + + call strcpy (root, IM_HDRFILE(im), SZ_IMHDRFILE) + IM_PIXFILE(im) = EOS + IM_HFD(im) = NULL + IM_PFD(im) = NULL + + # Set up the QPF descriptor. + QPF_IM(qpf) = im + QPF_QP(qpf) = qp + QPF_IO(qpf) = io + QPF_XBLOCK(qpf) = xblock + QPF_YBLOCK(qpf) = yblock + QPF_IOSTAT(qpf) = 0 + + IM_KDES(im) = qpf + + # Copy any scalar QPOE file header parameters into the IMIO header. + iferr (call qpf_copyparams (im, qp)) + call erract (EA_WARN) + + status = OK + call sfree (sp) + return + +err_ + # Error abort. + if (io != NULL) + call qpio_close (io) + if (qp != NULL) + call qp_close (qp) + + call mfree (qpf, TY_STRUCT) + IM_KDES(im) = NULL + + status = ERR + call erract (EA_WARN) + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfopix.x b/sys/imio/iki/qpf/qpfopix.x new file mode 100644 index 00000000..9b5750ff --- /dev/null +++ b/sys/imio/iki/qpf/qpfopix.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "qpf.h" + +# QPF_OPIX -- Open the "pixel storage file", i.e., open the special QPF/QPOE +# virtual file driver, which samples the QPOE event list in real time to +# produce image "pixels", where each pixel contains a count of the number of +# photons mapping to that point in the output image matrix. + +procedure qpf_opix (im, status) + +pointer im #I image descriptor +int status #O return status + +pointer sp, fname, qpf +extern qpfzop(), qpfzrd(), qpfzwr(), qpfzwt(), qpfzst(), qpfzcl() +int fopnbf() + +begin + status = OK + if (IM_PFD(im) != NULL) + return + + # Verify that the QPIO open succeeded at open time; if not, the file + # may not have an event list (which is legal, but not for pixel i/o). + + qpf = IM_KDES(im) + if (QPF_IO(qpf) == NULL) { + status = ERR + return + } + + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Encode the QPF descriptor as a pseudo-filename to pass the descriptor + # through fopnbf to the QPF virtual binary file driver. + + call sprintf (Memc[fname], SZ_FNAME, "QPF%d") + call pargi (IM_KDES(im)) + + # Open a file descriptor for the dummy QPOE file driver, used to access + # the event list as a virtual pixel array (sampled at runtime). + + iferr (IM_PFD(im) = fopnbf (Memc[fname], READ_ONLY, + qpfzop, qpfzrd, qpfzwr, qpfzwt, qpfzst, qpfzcl)) { + + IM_PFD(im) = NULL + status = ERR + } + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfrename.x b/sys/imio/iki/qpf/qpfrename.x new file mode 100644 index 00000000..70f90626 --- /dev/null +++ b/sys/imio/iki/qpf/qpfrename.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include "qpf.h" + +# QPF_RENAME -- Rename a datafile. + +procedure qpf_rename (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] #I old image root name +char old_extn[ARB] #I old image extn +char new_root[ARB] #I new image root name +char new_extn[ARB] #I old image extn +int status #O output status + +pointer sp, oldname, newname +errchk qp_rename + +begin + call smark (sp) + call salloc (oldname, SZ_PATHNAME, TY_CHAR) + call salloc (newname, SZ_PATHNAME, TY_CHAR) + + # Get filenames of old and new datafiles. + call iki_mkfname (old_root, old_extn, Memc[oldname], SZ_PATHNAME) + call iki_mkfname (new_root, QPF_EXTN, Memc[newname], SZ_PATHNAME) + + # Rename the datafile. + iferr (call qp_rename (Memc[oldname], Memc[newname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfupdhdr.x b/sys/imio/iki/qpf/qpfupdhdr.x new file mode 100644 index 00000000..9dd67ea6 --- /dev/null +++ b/sys/imio/iki/qpf/qpfupdhdr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# QPF_UPDHDR -- Update the image header. This is a no-op for QPF since the +# datafiles can only be accessed READ_ONLY via IMIO. + +procedure qpf_updhdr (im, status) + +pointer im #I image descriptor +int status #O output status + +begin + status = OK +end diff --git a/sys/imio/iki/qpf/qpfwattr.x b/sys/imio/iki/qpf/qpfwattr.x new file mode 100644 index 00000000..b48a6793 --- /dev/null +++ b/sys/imio/iki/qpf/qpfwattr.x @@ -0,0 +1,191 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <qpioset.h> +include "qpf.h" + +# QPF_WATTR -- Record information about the attributes of the filter +# expression used to generate an image. Currently the only value which can be +# computed and recorded is total range (integral of the in-range intervals) of +# the range list defining an attribute, for example, the total exposure time +# defined by the time range list used to filter the data. +# +# This routine is driven by a set of optional QPOE header keywords of the +# form +# +# Keyword String Value +# +# defattrN <param-name> = "integral" <attribute-name>[:type] +# e.g. +# defattr1 "exptime = integral time:d" +# +# where param-name is the parameter name to be written to the output image +# header, "integral" is the value to be computed, and attribute-name is the +# QPEX attribute (e.g., "time") to be used for the computation. A finite +# value is returned for the integral if a range list is given for the named +# attribute and the range is closed. If the range is open on either or both +# ends, or no range expression is defined for the attribute, then INDEF is +# returned for the value of the integral. + +procedure qpf_wattr (qpf, im) + +pointer qpf #I QPF descriptor +pointer im #I image descriptor + +real r1, r2, rsum +double d1, d2, dsum +int dtype, i, j, xlen, nranges, i1, i2, isum +pointer sp, io, qp, ex, kwname, kwval, pname, funame, atname, ip, xs, xe + +bool strne() +pointer qpio_stati() +int qp_gstr(), ctowrd(), qp_accessf() +int qpex_attrli(), qpex_attrlr(), qpex_attrld() +errchk qpex_attrli, qpex_attrlr, qpex_attrld, imaddi, imaddr, imaddd + +begin + io = QPF_IO(qpf) + if (io == NULL) + return + + qp = QPF_QP(qpf) + ex = qpio_stati (io, QPIO_EX) + + call smark (sp) + call salloc (kwname, SZ_FNAME, TY_CHAR) + call salloc (kwval, SZ_LINE, TY_CHAR) + call salloc (pname, SZ_FNAME, TY_CHAR) + call salloc (funame, SZ_FNAME, TY_CHAR) + call salloc (atname, SZ_FNAME, TY_CHAR) + + # Process a sequence of "defattrN" header parameter definitions. + # Each defines a parameter to be computed and added to the output + # image header. + + do i = 1, ARB { + # Check for a parameter named "defattrN", get string value. + call sprintf (Memc[kwname], SZ_FNAME, "defattr%d") + call pargi (i) + + if (qp_accessf (qp, Memc[kwname]) == NO) + break + if (qp_gstr (qp, Memc[kwname], Memc[kwval], SZ_LINE) <= 0) + break + + # Parse string value into parameter name, function name, + # expression attribute name, and datatype. + + ip = kwval + if (ctowrd (Memc, ip, Memc[pname], SZ_FNAME) <= 0) + break + while (IS_WHITE(Memc[ip]) || Memc[ip] == '=') + ip = ip + 1 + if (ctowrd (Memc, ip, Memc[funame], SZ_FNAME) <= 0) + break + if (ctowrd (Memc, ip, Memc[atname], SZ_FNAME) <= 0) + break + + dtype = TY_INT + for (ip=atname; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ':') { + Memc[ip] = EOS + if (Memc[ip+1] == 'd') + dtype = TY_DOUBLE + else if (Memc[ip+1] == 'r') + dtype = TY_REAL + else + call eprintf ("QPF.defattr: datatype not recognized\n") + } + + # Verify known function type. + if (strne (Memc[funame], "integral")) { + call eprintf ("QPF.defattr: function `%s' not recognized\n") + call pargstr (Memc[funame]) + break + } + + # Compute the integral of the range list for the named attribute. + xlen = 0 + xs = NULL + xe = NULL + + switch (dtype) { + case TY_REAL: + if (ex == NULL) + nranges = 0 + else + nranges = qpex_attrlr (ex, Memc[atname], xs, xe, xlen) + + if (nranges <= 0) + rsum = INDEFR + else { + rsum = 0 + do j = 1, nranges { + r1 = Memr[xs+j-1] + r2 = Memr[xe+j-1] + if (IS_INDEFR(r1) || IS_INDEFR(r2)) { + rsum = INDEFR + break + } else + rsum = rsum + (r2 - r1) + } + } + + call mfree (xs, TY_REAL) + call mfree (xe, TY_REAL) + call imaddr (im, Memc[pname], rsum) + + case TY_DOUBLE: + if (ex == NULL) + nranges = 0 + else + nranges = qpex_attrld (ex, Memc[atname], xs, xe, xlen) + + if (nranges <= 0) + dsum = INDEFD + else { + dsum = 0 + do j = 1, nranges { + d1 = Memd[xs+j-1] + d2 = Memd[xe+j-1] + if (IS_INDEFD(d1) || IS_INDEFD(d2)) { + dsum = INDEFD + break + } else + dsum = dsum + (d2 - d1) + } + } + + call mfree (xs, TY_DOUBLE) + call mfree (xe, TY_DOUBLE) + call imaddd (im, Memc[pname], dsum) + + default: + if (ex == NULL) + nranges = 0 + else + nranges = qpex_attrli (ex, Memc[atname], xs, xe, xlen) + + if (nranges <= 0) + isum = INDEFI + else { + isum = 0 + do j = 1, nranges { + i1 = Memi[xs+j-1] + i2 = Memi[xe+j-1] + if (IS_INDEFI(i1) || IS_INDEFI(i2)) { + isum = INDEFI + break + } else + isum = isum + (i2 - i1) + } + } + + call mfree (xs, TY_INT) + call mfree (xe, TY_INT) + call imaddi (im, Memc[pname], isum) + } + } + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfwfilter.x b/sys/imio/iki/qpf/qpfwfilter.x new file mode 100644 index 00000000..e521cbc6 --- /dev/null +++ b/sys/imio/iki/qpf/qpfwfilter.x @@ -0,0 +1,53 @@ +include "qpf.h" + +# QPF_WFILTER -- Record the QPIO filter used to generate an image as a series +# of FITS cards in the image header. Note: excessively long filters are +# truncated to avoid overfilling the image header. + +procedure qpf_wfilter (qpf, im) + +pointer qpf #I QPF descriptor +pointer im #I image descriptor + +int nchars, nleft, index +pointer io, sp, bp, ip, kw, strval +errchk qpio_getfilter, impstr +int qpio_getfilter() + +begin + io = QPF_IO(qpf) + if (io == NULL) + return + + call smark (sp) + call salloc (kw, SZ_KWNAME, TY_CHAR) + call salloc (bp, SZ_MAXFILTER, TY_CHAR) + call salloc (strval, SZ_BIGSTR, TY_CHAR) + + # Get the filter as as string from QPIO. + nchars = qpio_getfilter (io, Memc[bp], SZ_MAXFILTER) + + # If the filter is longer than our string buffer, write a "..." at + # the end of the filter to indicate that it is being truncated. + + if (nchars == SZ_MAXFILTER) + call strcpy ("...", Memc[bp+nchars-3], 3) + + index = 1 + ip = bp + + # Output a series of QPFILTnn cards to record the full filter. + for (nleft = nchars; nleft > 0; nleft = nleft - SZ_BIGSTR) { + call strcpy (Memc[ip], Memc[strval], SZ_BIGSTR) + call sprintf (Memc[kw], SZ_KWNAME, "QPFILT%02d") + call pargi (index) + iferr (call imaddf (im, Memc[kw], "c")) + ; + call impstr (im, Memc[kw], Memc[strval]) + + ip = ip + SZ_BIGSTR + index = index + 1 + } + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/zfioqp.x b/sys/imio/iki/qpf/zfioqp.x new file mode 100644 index 00000000..0e1c38ff --- /dev/null +++ b/sys/imio/iki/qpf/zfioqp.x @@ -0,0 +1,189 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <imhdr.h> +include <imio.h> +include <fio.h> +include <qpioset.h> +include "qpf.h" + +# ZFIOQP -- QPF virtual file driver. This driver presents to the caller a +# virtual file space containing a two dimensional array of type short or int +# pixels, wherein each "pixel" is a count of the number of events from a +# QPOE event list which map into that pixel. An i/o request results in +# runtime filtering and sampling of the event list, mapping each event which +# passes the filter into the corresponding output pixel, and incrementing the +# value of that pixel to count the event. + +# QPFZOP -- Open the file driver for i/o on the QPIO descriptor opened at +# qpf_open time. + +procedure qpfzop (pkfn, mode, status) + +char pkfn[ARB] #I packed virtual filename from FIO +int mode #I file access mode (ignored) +int status #O output status - i/o channel if successful + +int ip +pointer sp, fn, qpf +int ctoi() + +begin + call smark (sp) + call salloc (fn, SZ_FNAME, TY_CHAR) + + # The QPF descriptor is passed encoded in the pseudo filename as + # "QPFxxxx" (decimal). Extract this and return it as the i/o + # channel for the driver. + + ip = 4 + call strupk (pkfn, Memc[fn], SZ_FNAME) + if (ctoi (Memc[fn], ip, qpf) <= 0) + status = ERR + else + status = qpf + + QPF_IOSTAT(qpf) = 0 + call sfree (sp) +end + + +# QPFZCL -- Close the QPF binary file driver. + +procedure qpfzcl (chan, status) + +int chan #I QPF i/o channel +int status #O output status + +begin + status = OK +end + + +# QPFZRD -- Read a segment of the virtual pixel array into the output buffer, +# i.e., zero the output buffer and sample the event list, accumulating counts +# in the output array. + +procedure qpfzrd (chan, obuf, nbytes, boffset) + +int chan #I QPF i/o channel +char obuf[ARB] #O output buffer +int nbytes #I nbytes to be read +int boffset #I file offset at which read commences + +pointer qpf, im, io +int vs[2], ve[2] +real xblock, yblock +int szb_pixel, ncols, pixel, nev, xoff, yoff +int qpio_readpixs(), qpio_readpixi() + +include <szpixtype.inc> + +begin + qpf = chan + im = QPF_IM(qpf) + io = QPF_IO(qpf) + + xblock = QPF_XBLOCK(qpf) + yblock = QPF_YBLOCK(qpf) + ncols = IM_PHYSLEN(im,1) + xoff = QPF_VS(qpf,1) + yoff = QPF_VS(qpf,2) + szb_pixel = pix_size[IM_PIXTYPE(im)] * SZB_CHAR + + # Convert boffset, nbytes to vs, ve. + pixel = (boffset - 1) / szb_pixel + vs[1] = (mod (pixel, ncols)) * xblock + xoff + vs[2] = (pixel / ncols) * yblock + yoff + + pixel = (boffset-1 + nbytes - szb_pixel) / szb_pixel + ve[1] = (mod (pixel, ncols)) * xblock + (xblock-1) + xoff + ve[2] = (pixel / ncols) * yblock + (yblock-1) + yoff + + # Call readpix to sample image into the output buffer. Zero the buffer + # first since the read is additive. + + call aclrc (obuf, nbytes / SZB_CHAR) + iferr { + switch (IM_PIXTYPE(im)) { + case TY_SHORT: + nev = qpio_readpixs (io, obuf, vs, ve, 2, xblock, yblock) + case TY_INT: + nev = qpio_readpixi (io, obuf, vs, ve, 2, xblock, yblock) + } + } then { + QPF_IOSTAT(qpf) = ERR + } else + QPF_IOSTAT(qpf) = nbytes +end + + +# QPFZWR -- Write to the virtual pixel array. QPF permits only read-only +# access, but we ignore write requests, so return OK and do nothing if this +# routine is called. + +procedure qpfzwr (chan, ibuf, nbytes, boffset) + +int chan #I QPF i/o channel +char ibuf[ARB] #O datg buffer +int nbytes #I nbytes to be written +int boffset #I file offset to write at + +pointer qpf + +begin + qpf = chan + QPF_IOSTAT(qpf) = nbytes +end + + +# QPFZWT -- Return the number of virtual bytes transferred in the last i/o +# request. + +procedure qpfzwt (chan, status) + +int chan #I QPF i/o channel +int status #O i/o channel status + +pointer qpf + +begin + qpf = chan + status = QPF_IOSTAT(qpf) +end + + +# QPFZST -- Query device/file parameters. + +procedure qpfzst (chan, param, value) + +int chan #I QPF i/o channel +int param #I parameter to be returned +int value #O parameter value + +pointer qpf, im, io +int szb_pixel, npix +int qpio_stati() + +include <szpixtype.inc> + +begin + qpf = chan + im = QPF_IM(qpf) + io = QPF_IO(qpf) + npix = IM_PHYSLEN(im,1) * IM_PHYSLEN(im,2) + szb_pixel = pix_size[IM_PIXTYPE(im)] * SZB_CHAR + + switch (param) { + case FSTT_BLKSIZE: + value = 1 + case FSTT_FILSIZE: + value = npix * szb_pixel + case FSTT_OPTBUFSIZE: + value = min (npix*szb_pixel, qpio_stati(io,QPIO_OPTBUFSIZE)) + case FSTT_MAXBUFSIZE: + value = npix * szb_pixel + default: + value = ERR + } +end diff --git a/sys/imio/iki/stf/README b/sys/imio/iki/stf/README new file mode 100644 index 00000000..5540110b --- /dev/null +++ b/sys/imio/iki/stf/README @@ -0,0 +1,300 @@ +IKI/STF -- IKI kernel for the STScI SDAS/GEIS image format. This format stores +images in a format which resembles FITS group format. A GROUP FORMAT IMAGE is +a set of one or more images, all of which are the same size, dimension, and +datatype, and which share a common FITS header. The individual images in a +group each has a binary GROUP PARAMETER BLOCK (GPB). The image and associated +group parameter block are commonly referred to as a GROUP. A group format +image consists of two files, the FITS format header file for the group, +and the pixel file containing the image data and GPBs. + + +1. Typical STF group format FITS image header (imname.hhh) + + SIMPLE = F / Standard STF keywords + BITPIX = 32 + DATATYPE= 'REAL*4 ' + NAXIS = 2 + NAXIS1 = 512 + NAXIS2 = 512 + GROUPS = T + PSIZE = 512 + GCOUNT = 1 + PCOUNT = 12 + + PTYPE1 = 'DATAMIN ' / Define binary group params + PSIZE1 = 32 + PDTYPE1 = 'REAL*4 ' + (etc, for a total of 3*PCOUNT entries) + + (special keywords and HISTORY cards) + + +2. Pixel file format (imname.hhd) (byte stream, no alignment, no header) + + [1].pixels + [1].group parameter block + [2].pixels + [2].group parameter block + ... + [GCOUNT].pixels + [GCOUNT].group parameter block + + +The chief problems with this format are that the FITS format header can contain +only parameters which pertain to the group as a whole, while the format of the +GPBs is fixed at image creation time. Images may be neither deleted from nor +added to a group. It is possible for parameters in the FITS header to have +the same names as parameters in the GPBs. Multiple entries for the same +keyword may appear in the FITS header and the format does not define how +these are to be handled. Although the format is general enough to support +any datatype pixels, in practice only REAL*4 can be used as the SDAS software +maps the pixfile directly into virtual memory. + +CAVEAT -- This is an awkward interface and some liberties have been taken in +the code (hidden, subtle semantics, etc.). At least we were able to confine +the bad code to this one directory; any problems can be fixed without any +changes to the rest of IMIO. All of this low level code is expected to be +thrown out when IMIO is cut over onto DBIO (the upcoming IRAF database +interface). + + +IKI/STF Pseudocode +---------------------------- + +1. Data structures: + + 1.1 IMIO image descriptor + header, pixel file descriptors + pointer to additional kernel descriptor, if any + index of IKI kernel in use + pathnames of header, pixel files + IM_NDIM, IM_LEN, etc., physical image parameters + + 1.2 STF image descriptor + Pointed to by IM_KDES field of IMIO descriptor. + Contains values of all reserved fields of STF image header, + some of which duplicate values in IMIO descriptor. + Group, gcount, size of a group in pixfile, description of + the group parameter block, i.e., for each parameter, + the offset, datatype type, name, length if array, etc. + + 1.3 IMIO user area (FITS cards) + While an image is open, the first few cards in the user area + contain the FITS encoded group parameters. + The remainder of the user area contains an exact image of + all non-reserved keyword cards found in the STF image + header (or in the header of some other type of image + when making a new_copy of an image stored in some other + format). + + +2. Major Procedures + +procedure open_image + +begin + if (mode is not new_image or new_copy) { + open_existing_image + return + } + + We are opening a new_image or new_copy image. The problem here is + that the new image might be a group within an existing group format + image. This ambiguity is resolved by a simple test on the group + index, rather than by a context dependent test on the existence of + the group format image. If the mode is new_whatever and the group + is 1, a new group format image is created, else if the group is > 1, + the indicated group is initialized in an existing group format image. + + if (group > 1) { + We are opening a new group within an existing group format image. + + Call open_existing_image to open the group without reading the + group parameter block, which has not yet been initialized. + + if (mode is new_image) + initialize GPB to pixel coords + else if (mode is new_copy) + copy old GPB to new image; transform coords if necessary + + Note that when opening a new copy of an existing image as a new + group within a group format image, it is not clear what to do + with the FITS header of the old image. Our solution is to ignore + it, and retain only the GPB, the only part of the old header + pertaining directly to the group being accessed. + + } else if (opening group 1 of a new image) { + We are creating a new group format image. + + if (mode is new_image) + open_new_image + else + open_new_copy + } +end + + +procedure open_existing_image + +begin + Allocate STF descriptor, save pointer in imio descriptor. + Open image header. + + Read header: + process reserved cards into STF descriptor + spool other cards + + Load group data block from pixfile, get datamin/datamax: + if (there is a gdb) { + open pixfile + read gdb into buffer + for (each param in gdb) { + set up parameter descriptor + format FITS card and put in imio user area + } + } + + fetch datamin, datamax from user area + + Set IM_MIN, IM_MAX, IM_LIMTIME from DATAMIN, DATAMAX. + Mark end of user area. + Copy spooled cards to user area. + (increase size of user area if necessary) + + Call imioff to set up imio pixel offset parameters +end + + +procedure open_new_image + +begin + Upon entry, the imio iminie procedure has already been called to + initialize the imio descriptor for the new image. + + Allocate STF descriptor, save pointer in imio descriptor. + Create header file from template dev$pix.hhh. + Open new image header. + + (At this point the IMIO header fields IM_NDIM, IM_LEN, etc., and + (the STF descriptor fields have not yet been set, and cannot be set + (until the image dimensions have been defined by the high level code. + (imopix() will later have to fix up the remaining header fields and + (set up the default group data block. +end + + +procedure open_new_copy + +begin + Upon entry, the imio immaky procedure has already been called to + copy the old header to the new and initialize the data + dependent fields. This will include the FITS encoded group + parameters in the user area of the old image. + + Allocate STF descriptor, save pointer in imio descriptor. + Create header file from template dev$pix.hhh. + Open new image header. + + Copy the STF descriptor of the old image to the new. Preserve + the parameter marking the end of the GPB area of the old + user area, as we do not want to write these cards when the + header is updated. + + (At this point all header information is set up, except that there + (is no pixel file and the pixfile offsets have not been set. + (Provided the image dimensions do not change, one could simply + (set the pixfile name, call imioff, and do i/o to the image. +end + + +procedure open_pixel_file + +begin + (We are called when the first i/o is done to an image. When writing + (to a new image, the user may change any of the image header attributes + (after the open and before we are called. + + if (pixel file already open) + return + else if (opening existing image) { + open pixel file + return + } + + if (opening a new image) { + Given the values of IM_NDIM and IM_LEN set by the user, set up the + STF descriptor including the default group parameter block. Add + the FITS encoded cards for the GPB to the image header. Mark the + end of the GPB cards, i.e., the start of the real user parameter + area. Ignore IM_PIXTYPE; always open an image of type real since + that is what the SDAS software requires. Set up the WCS to linear + pixel coordinates. + + } else if (opening a new_copy image) { + (The STF descriptor and GPB will already have been set up as a + (copy of the data structures used by the old image. However, + (the user may have changed the values of IM_NDIM and IM_LEN + (since the image was opened, and the value of GCOUNT set when + (the image was opened may be different than that of the old image. + + Transform the coordinate system of the old image to produce the + WCS for the new image, i.e., if an image section was used to + reference the old image. + + Make a new STF descriptor using the values of IM_NDIM and IM_LEN + given, as for a new_image, but using the WCS information for the + new image. The FITS encoded fields in the IMIO user area will be + automatically updated by the IMADD functions, or new cards added + if not present. + + Merge any additional fields from the old STF descriptor into the + new one, e.g., any instrument dependent parameters stored in the + GPB. + + (The STF and FITS encoded user area should now contain a full + (description of the GPB for the new image. + } + + Allocate the pixel file, using the GCOUNT parameter set in the + STF descriptor at stf_open time. + Open the pixel file. + + Set IM_MIN and IM_MAX to zero (not defined). + Call IMIOFF to initialize the pixel offsets. +end + + +procedure update_image_header + +begin + Update the values of DATAMIN, DATAMAX from the IMIO header fields. + + Update the binary GPB in the pixel file from the FITS encoded GPB + in the IMIO user area, using the GPB structure defined in the + STF descriptor. + + Update the STF image header file: + Open a new, empty header file using FMKCOPY and OPEN. + Format and output FITS cards for the reserved header fields, + e.g., SIMPLE, BITPIX, GCOUNT, the GPB information, etc. + Copy the user area to the new header file, excluding the + GPB cards at the beginning of the user area. + Close the new header file and replace the old header file + with the new one via a rename operation. +end + + +procedure close_image + +begin + (We assume that IMIO has already update the image header if such + (is necessary. + + if (pixel file open) + close pixel file + if (header file open) + close header file + + deallocate STF descriptor + (IMIO will deallocate the IMIO descriptor) +end diff --git a/sys/imio/iki/stf/mkpkg b/sys/imio/iki/stf/mkpkg new file mode 100644 index 00000000..b28ace96 --- /dev/null +++ b/sys/imio/iki/stf/mkpkg @@ -0,0 +1,36 @@ +# Make the IKI/STF interface (STScI SDAS/GEIS group format images) + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + #$set XFLAGS = "$(XFLAGS) -qfx" + #$set XFLAGS = "$(XFLAGS) -/pg" + + stfaccess.x stf.h + stfaddpar.x <imhdr.h> <imio.h> <mach.h> stf.h + stfclose.x stf.h <imhdr.h> <imio.h> + stfcopy.x stf.h <error.h> + stfcopyf.x stf.h + stfctype.x stf.h <ctype.h> + stfdelete.x stf.h <error.h> <imhdr.h> + stfget.x stf.h <ctype.h> + stfhextn.x stf.h <imhdr.h> <imio.h> + stfiwcs.x stf.h <imhdr.h> + stfmerge.x stf.h <imhdr.h> <imio.h> <mach.h> + stfmkpfn.x stf.h + stfnewim.x stf.h <imhdr.h> <imio.h> <mach.h> + stfopen.x stf.h <error.h> <imhdr.h> <imio.h> + stfopix.x stf.h <fset.h> <imhdr.h> <imio.h> <mach.h> + stfordgpb.x stf.h <mach.h> + stfrdhdr.x stf.h <finfo.h> <imhdr.h> <imio.h> <mach.h> + stfreblk.x stf.h <imhdr.h> <imio.h> + stfrename.x stf.h <error.h> + stfrfits.x stf.h <ctype.h> <finfo.h> <fset.h> <imhdr.h> <imio.h> + stfrgpb.x stf.h <imhdr.h> <imio.h> <mach.h> + stfupdhdr.x stf.h <imhdr.h> <imio.h> + stfwfits.x stf.h <error.h> <fio.h> <imhdr.h> <imio.h> + stfwgpb.x stf.h <error.h> <imhdr.h> <imio.h> <mach.h> + ; diff --git a/sys/imio/iki/stf/stf.h b/sys/imio/iki/stf/stf.h new file mode 100644 index 00000000..bf99a07c --- /dev/null +++ b/sys/imio/iki/stf/stf.h @@ -0,0 +1,77 @@ +# STF.H -- IKI/STF internal definitions. + +define HDR_TEMPLATE "dev$pix.hhh" # used by fmkcopy to create new header +define MAX_LENEXTN 3 # max length imagefile extension +define STF_HDRPATTERN "^??h" # class of legal header extensions +define STF_DEFHDREXTN "hhh" # default header file extension +define STF_DEFPIXEXTN "hhd" # default pixel file extension +define ENV_DEFIMTYPE "imtype" # name of environment variable +define STF_MAXDIM 7 # max NAXIS +define MAX_CACHE 5 # max cached header files +define DEF_CACHE 3 # default size of header file cache +define ENV_STFCACHE "stfcache" # environment variable for cache size +define MAX_PCOUNT 99 # max param descriptors +define SZ_DATATYPE 16 # e.g., `REAL*4' +define SZ_KEYWORD 8 # size of a FITS keyword +define SZ_PTYPE 8 # e.g., `CRPIX1' +define SZ_PDTYPE 16 # e.g., `CHAR*8' +define SZ_COMMENT FITS_SZCOMMENT # comment string for GPB card +define SZ_EXTRASPACE (81*32) # extra space for new cards in header + +define FITS_RECLEN 80 # length of a FITS record (card) +define FITS_STARTVALUE 10 # first column of value field +define FITS_ENDVALUE 30 # last column of value field +define FITS_SZVALSTR 21 # nchars in value string +define FITS_SZCOMMENT 50 # max chars in comment, incl. / + +# STF image descriptor, used internally by the STF interface. The required +# header parameters are maintained in this descriptor, everything else is +# simply copied into the user area of the IMIO descriptor. + +define LEN_STFDES (LEN_STFBASE+MAX_PCOUNT*LEN_PDES) +define STF_CACHE STF_BITPIX # cache descriptor starting here +define STF_CACHELEN (33+STF_PCOUNT($1)*LEN_PDES) +define LEN_STFBASE 43 + +define STF_ACMODE Memi[$1] # image access mode +define STF_NEWIMAGE Memi[$1+1] # creating entire new STF format image? +define STF_GROUP Memi[$1+2] # group to be accessed +define STF_SZGROUP Memi[$1+3] # size of image+hdr in pixfile, chars +define STF_PFD Memi[$1+4] # pixfile file descriptor +define STF_GRARG Memi[$1+5] # group index given in image name + # (extra space) +define STF_BITPIX Memi[$1+10] # bits per pixel +define STF_NAXIS Memi[$1+11] # number of axes in image +define STF_GROUPS Memi[$1+12] # group format? +define STF_GCOUNT Memi[$1+13] # number of groups in STF image +define STF_PSIZE Memi[$1+14] # size of GPB, bits +define STF_PCOUNT Memi[$1+15] # number of parameters in GPB +define STF_DATATYPE Memc[P2C($1+16)]# datatype string +define STF_LENAXIS Memi[$1+35+$2-1]# 35:41 = [7] max +define STF_PDES (($1)+43+((($2)-1)*LEN_PDES)) + +# GPB Parameter descriptor. +define LEN_PDES 81 +define P_OFFSET Memi[$1] # struct offset of parameter +define P_SPPTYPE Memi[$1+1] # SPP datatype of parameter +define P_LEN Memi[$1+2] # number of elements +define P_PSIZE Memi[$1+3] # field size, bits +define P_PTYPEP (P2C($1+4)) # pointer to parameter name +define P_PTYPE Memc[P2C($1+4)] # parameter name +define P_PDTYPE Memc[P2C($1+13)]# datatype string +define P_COMMENT Memc[P2C($1+30)]# comment string + +# Reserved FITS keywords known to this code. +define KW_BITPIX 1 +define KW_DATATYPE 2 +define KW_END 3 +define KW_GCOUNT 4 +define KW_GROUPS 5 +define KW_NAXIS 6 +define KW_NAXISN 7 +define KW_PCOUNT 8 +define KW_PDTYPE 9 +define KW_PSIZE 10 +define KW_PSIZEN 11 +define KW_PTYPE 12 +define KW_SIMPLE 13 diff --git a/sys/imio/iki/stf/stfaccess.x b/sys/imio/iki/stf/stfaccess.x new file mode 100644 index 00000000..40907c69 --- /dev/null +++ b/sys/imio/iki/stf/stfaccess.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stf.h" + +# STF_ACCESS -- Test the accessibility or existence of an existing image, or +# the legality of the name of a new image. + +procedure stf_access (kernel, root, extn, acmode, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #I extension (SET on output if none specified) +int acmode #I access mode (0 to test only existence) +int status #O return value + +int i +pointer sp, fname, kextn +int access(), iki_validextn(), iki_getextn(), btoi() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (kextn, MAX_LENEXTN, TY_CHAR) + + # If new image, test only the legality of the given extension. + # This is used to select a kernel given the imagefile extension. + + if (acmode == NEW_IMAGE || acmode == NEW_COPY) { + status = btoi (iki_validextn (kernel, extn) > 0) + call sfree (sp) + return + } + + status = NO + + # If no extension was given, look for a file with the default + # extension, and return the actual extension if an image with the + # default extension is found. + + if (extn[1] == EOS) { + do i = 1, ARB { + if (iki_getextn (kernel, i, Memc[kextn], MAX_LENEXTN) <= 0) + break + call iki_mkfname (root, Memc[kextn], Memc[fname], SZ_PATHNAME) + if (access (Memc[fname], acmode, 0) == YES) { + call strcpy (Memc[kextn], extn, MAX_LENEXTN) + status = YES + break + } + } + } else if (iki_validextn (kernel, extn) == kernel) { + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + if (access (Memc[fname], acmode, 0) == YES) + status = YES + } + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfaddpar.x b/sys/imio/iki/stf/stfaddpar.x new file mode 100644 index 00000000..65a90f80 --- /dev/null +++ b/sys/imio/iki/stf/stfaddpar.x @@ -0,0 +1,94 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <mach.h> +include "stf.h" + +# STF_ADDPAR -- Encode a parameter in FITS format and add it to the FITS format +# IMIO user area; initialize the entry for the parameter in the GPB descriptor +# as well. + +procedure stf_addpar (im, pname, dtype, plen, pval, pno) + +pointer im #I image descriptor +char pname[ARB] #I parameter name +int dtype #I SPP datatype of parameter +int plen #I length (> 1 if array) +char pval[ARB] #I string encoded initial parameter value +int pno #U parameter number + +bool bval +real rval +double dval +short sval +long lval +pointer pp, stf + +bool initparam +int ival, ip, junk +int ctoi(), ctor(), ctod(), imaccf() +errchk imadds, imaddl, imaddr, imaddd, imastr + +begin + stf = IM_KDES(im) + pp = STF_PDES(stf,pno) + ip = 1 + + call strcpy (pname, P_PTYPE(pp), SZ_PTYPE) + + # Initialize the parameter only if not already defined in header. + initparam = (imaccf (im, pname) == NO) + + switch (dtype) { + case TY_BOOL: + call strcpy ("LOGICAL*4", P_PDTYPE(pp), SZ_PDTYPE) + P_PSIZE(pp) = plen * SZ_BOOL * SZB_CHAR * NBITS_BYTE + if (initparam) { + bval = (pval[1] == 'T') + call imaddb (im, P_PTYPE(pp), bval) + } + case TY_SHORT: + call strcpy ("INTEGER*2", P_PDTYPE(pp), SZ_PDTYPE) + P_PSIZE(pp) = plen * SZ_SHORT * SZB_CHAR * NBITS_BYTE + if (initparam) { + junk = ctoi (pval, ip, ival) + sval = ival + call imadds (im, P_PTYPE(pp), sval) + } + case TY_LONG: + call strcpy ("INTEGER*4", P_PDTYPE(pp), SZ_PDTYPE) + P_PSIZE(pp) = plen * SZ_LONG * SZB_CHAR * NBITS_BYTE + if (initparam) { + junk = ctoi (pval, ip, ival) + lval = ival + call imaddl (im, P_PTYPE(pp), lval) + } + case TY_REAL: + call strcpy ("REAL*4", P_PDTYPE(pp), SZ_PDTYPE) + P_PSIZE(pp) = plen * SZ_REAL * SZB_CHAR * NBITS_BYTE + if (initparam) { + junk = ctor (pval, ip, rval) + call imaddr (im, P_PTYPE(pp), rval) + } + case TY_DOUBLE: + call strcpy ("REAL*8", P_PDTYPE(pp), SZ_PDTYPE) + P_PSIZE(pp) = plen * SZ_DOUBLE * SZB_CHAR * NBITS_BYTE + if (initparam) { + junk = ctod (pval, ip, dval) + call imaddd (im, P_PTYPE(pp), dval) + } + default: + call sprintf (P_PDTYPE(pp), SZ_PDTYPE, "CHARACTER*%d") + call pargi (plen) + P_PSIZE(pp) = plen * NBITS_BYTE + if (initparam) + call imastr (im, P_PTYPE(pp), pval) + } + + P_OFFSET(pp) = 0 + P_SPPTYPE(pp) = dtype + P_LEN(pp) = plen + + pno = pno + 1 +end diff --git a/sys/imio/iki/stf/stfclose.x b/sys/imio/iki/stf/stfclose.x new file mode 100644 index 00000000..89981578 --- /dev/null +++ b/sys/imio/iki/stf/stfclose.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "stf.h" + +# STF_CLOSE -- Close an STF format image. There is little for us to do, since +# IMIO will already have updated the header if necessary and flushed any pixel +# output. Neither do we have to deallocate the IMIO descriptor, since it was +# allocated by IMIO. + +procedure stf_close (im, status) + +pointer im # image descriptor +int status + +pointer stf +errchk close + +begin + stf = IM_KDES(im) + + # Close the pixel file and header file, if open. + if (STF_PFD(stf) != NULL) + call close (STF_PFD(stf)) + if (IM_HFD(im) != NULL) + call close (IM_HFD(im)) + + # Deallocate the STF descirptor. + call mfree (IM_KDES(im), TY_STRUCT) + status = OK +end diff --git a/sys/imio/iki/stf/stfcopy.x b/sys/imio/iki/stf/stfcopy.x new file mode 100644 index 00000000..e8643600 --- /dev/null +++ b/sys/imio/iki/stf/stfcopy.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include "stf.h" + +# STF_COPY -- Copy an image. A special operator is provided for fast, blind +# copies of entire images. + +procedure stf_copy (kernel, oroot, oextn, nroot, nextn, status) + +int kernel #I IKI kernel +char oroot[ARB] # old image root name +char oextn[ARB] # old image extn +char nroot[ARB] # new image root name +char nextn[ARB] # old image extn +int status + +pointer sp +pointer ohdr_fname, opix_fname, nhdr_fname, npix_fname + +begin + call smark (sp) + call salloc (ohdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (opix_fname, SZ_PATHNAME, TY_CHAR) + call salloc (nhdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (npix_fname, SZ_PATHNAME, TY_CHAR) + + # Generate filenames. + call iki_mkfname (oroot, oextn, Memc[ohdr_fname], SZ_PATHNAME) + call iki_mkfname (nroot, nextn, Memc[nhdr_fname], SZ_PATHNAME) + + call stf_mkpixfname (oroot, oextn, Memc[opix_fname], SZ_PATHNAME) + call stf_mkpixfname (nroot, nextn, Memc[npix_fname], SZ_PATHNAME) + + # If the header cannot be copied, leave the pixfile alone. + iferr (call fcopy (Memc[ohdr_fname], Memc[nhdr_fname])) + call erract (EA_WARN) + else iferr (call fcopy (Memc[opix_fname], Memc[npix_fname])) + call erract (EA_WARN) + + call sfree (sp) + status = OK +end diff --git a/sys/imio/iki/stf/stfcopyf.x b/sys/imio/iki/stf/stfcopyf.x new file mode 100644 index 00000000..7402c879 --- /dev/null +++ b/sys/imio/iki/stf/stfcopyf.x @@ -0,0 +1,92 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stf.h" + +define NKW 4 # number of reserved header keywords + + +# STF_COPYFITS -- Copy the spooled FITS header, separating out the GPB cards +# and returning either or both types of cards on the two output streams. + +procedure stf_copyfits (stf, spool, gpb, user) + +pointer stf #I pointer to STF descriptor +int spool #I spooled header to read +int gpb #I stream to receive GPB cards, or NULL +int user #I stream to receive user cards, or NULL + +bool keyword +int p_ch[MAX_PCOUNT+NKW] +pointer p_len[MAX_PCOUNT+NKW] +pointer p_namep[MAX_PCOUNT+NKW] +int delim, ch, npars, ngpbpars, i +pointer sp, lbuf, sbuf, pp, op, kw[NKW] +int strncmp(), getline(), strlen(), gstrcpy() +errchk getline, putline + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (sbuf, SZ_LINE, TY_CHAR) + + # The following reserved keywords describing the GPB are added to + # the user area by stf_rdheader, and must be filtered out along with + # the group parameters. Since the number of reserved or group + # parameters is normally small (only a dozen or so typically) a + # simple 1 character - 2 thread hashing scheme is probably faster, + # and certainly simpler, than a full hash table keyword lookup. + + op = sbuf + npars = NKW + kw[1] = op; op = op + gstrcpy ("GROUPS", Memc[op], ARB) + 1 + kw[2] = op; op = op + gstrcpy ("GCOUNT", Memc[op], ARB) + 1 + kw[3] = op; op = op + gstrcpy ("PCOUNT", Memc[op], ARB) + 1 + kw[4] = op; op = op + gstrcpy ("PSIZE", Memc[op], ARB) + 1 + + do i = 1, npars { + p_namep[i] = kw[i] + p_len[i] = strlen(Memc[kw[i]]) + p_ch[i] = Memc[kw[i]+2] + } + + # Add the GPB parameters to the list of group related parameters. + ngpbpars = min (MAX_PCOUNT, STF_PCOUNT(stf)) + do i = 1, ngpbpars { + npars = npars + 1 + pp = STF_PDES(stf,i) + p_namep[npars] = P_PTYPEP(pp) + p_len[npars] = strlen(P_PTYPE(pp)) + p_ch[npars] = Memc[p_namep[npars]+2] + } + + # Determine the type of each card and copy it to the appropriate + # output stream. + + while (getline (spool, Memc[lbuf]) != EOF) { + # Does this user card redefine a reserved keyword? + keyword = false + ch = Memc[lbuf+2] + do i = 1, npars { + if (ch != p_ch[i]) + next + delim = Memc[lbuf+p_len[i]] + if (delim != ' ' && delim != '=') + next + if (strncmp (Memc[lbuf], Memc[p_namep[i]], p_len[i]) == 0) { + keyword = true + break + } + } + + # Copy the card to the appropriate stream. + if (keyword) { + if (gpb != NULL) + call putline (gpb, Memc[lbuf]) + } else { + if (user != NULL) + call putline (user, Memc[lbuf]) + } + } + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfctype.x b/sys/imio/iki/stf/stfctype.x new file mode 100644 index 00000000..9c48f65a --- /dev/null +++ b/sys/imio/iki/stf/stfctype.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include "stf.h" + +# STF_CTYPE -- Determine the type of a FITS card. STF recognizes only those +# cards which define the image format and the group parameter block. + +int procedure stf_ctype (card, index) + +char card[ARB] #I FITS card (or keyword) +int index #O index number, if any + +int ch1, ch2, ip +int strncmp(), ctoi() + +begin + ch1 = card[1] + ch2 = card[2] + + # The set of keywords is fixed and small, so a simple brute force + # recognizer is about as good as anything. + + if (ch1 == 'B') { + if (ch2 == 'I') + if (strncmp (card, "BITPIX ", 8) == 0) + return (KW_BITPIX) # BITPIX + } else if (ch1 == 'D') { + if (ch2 == 'A') + if (strncmp (card, "DATATYPE", 8) == 0) + return (KW_DATATYPE) # DATATYPE + } else if (ch1 == 'E') { + if (ch2 == 'N') + if (card[3] == 'D' && card[4] == ' ') + return (KW_END) # END card + } else if (ch1 == 'G') { + if (ch2 == 'C') { + if (strncmp (card, "GCOUNT ", 8) == 0) + return (KW_GCOUNT) # GCOUNT + } else if (ch2 == 'R') { + if (strncmp (card, "GROUPS ", 8) == 0) + return (KW_GROUPS) # GROUPS + } + } else if (ch1 == 'N') { + if (ch2 == 'A') + if (strncmp (card, "NAXIS", 5) == 0) + if (card[6] == ' ') + return (KW_NAXIS) # NAXIS + else if (IS_DIGIT(card[6])) { + index = TO_INTEG(card[6]) + return (KW_NAXISN) # NAXISn + } + } else if (ch1 == 'P') { + if (ch2 == 'C') { + if (strncmp (card, "PCOUNT ", 8) == 0) + return (KW_PCOUNT) # PCOUNT + } else if (ch2 == 'D') { + if (strncmp (card, "PDTYPE", 6) == 0) { + ip = 7 + if (ctoi (card, ip, index) > 0) + return (KW_PDTYPE) # PDTYPEn + } + } else if (ch2 == 'S') { + if (strncmp (card, "PSIZE", 5) == 0) { + ip = 6 + if (card[ip] == ' ') + return (KW_PSIZE) + else if (ctoi (card, ip, index) > 0) + return (KW_PSIZEN) # PSIZEn + } + } else if (ch2 == 'T') { + if (strncmp (card, "PTYPE", 5) == 0) { + ip = 6 + if (ctoi (card, ip, index) > 0) + return (KW_PTYPE) # PTYPEn + } + } + } else if (ch1 == 'S') { + if (ch2 == 'I') + if (strncmp (card, "SIMPLE ", 8) == 0) + return (KW_SIMPLE) # SIMPLE + } + + return (ERR) +end diff --git a/sys/imio/iki/stf/stfdelete.x b/sys/imio/iki/stf/stfdelete.x new file mode 100644 index 00000000..dd319f12 --- /dev/null +++ b/sys/imio/iki/stf/stfdelete.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include "stf.h" + +# STF_DELETE -- Delete an image. A special operator is required since the +# image is stored as two files. + +procedure stf_delete (kernel, root, extn, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #U header file extension +int status #O return value + +pointer sp +pointer hdr_fname, pix_fname +int access() + +begin + call smark (sp) + call salloc (hdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (pix_fname, SZ_PATHNAME, TY_CHAR) + + # Generate filename. + call iki_mkfname (root, extn, Memc[hdr_fname], SZ_PATHNAME) + call stf_mkpixfname (root, extn, Memc[pix_fname], SZ_PATHNAME) + + # If the header cannot be deleted, leave the pixfile alone. + iferr (call delete (Memc[hdr_fname])) + call erract (EA_WARN) + else if (access (Memc[pix_fname],0,0) == YES) { + iferr (call delete (Memc[pix_fname])) + call erract (EA_WARN) + } + + status = OK + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfget.x b/sys/imio/iki/stf/stfget.x new file mode 100644 index 00000000..bacbc8d7 --- /dev/null +++ b/sys/imio/iki/stf/stfget.x @@ -0,0 +1,97 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include "stf.h" + +# STF_GETI -- Return the integer value of a FITS encoded card. + +procedure stf_geti (card, ival) + +char card[ARB] # card to be decoded +int ival # receives integer value + +int ip, ctoi() +char sval[FITS_SZVALSTR] + +begin + call stf_gets (card, sval, FITS_SZVALSTR) + ip = 1 + if (ctoi (sval, ip, ival) <= 0) + ival = 0 +end + + +# STF_GETB -- Return the boolean/integer value of a FITS encoded card. + +procedure stf_getb (card, bval) + +char card[ARB] # card to be decoded +int bval # receives YES/NO + +char sval[FITS_SZVALSTR] + +begin + call stf_gets (card, sval, FITS_SZVALSTR) + if (sval[1] == 'T') + bval = YES + else + bval = NO +end + + +# STF_GETS -- Get the string value of a FITS encoded card. Strip leading +# and trailing whitespace and any quotes. + +procedure stf_gets (card, outstr, maxch) + +char card[ARB] # FITS card to be decoded +char outstr[ARB] # output string to receive parameter value +int maxch + +int ip, op +int ctowrd(), strlen() + +begin + ip = FITS_STARTVALUE + if (ctowrd (card, ip, outstr, maxch) > 0) { + # Strip trailing whitespace. + op = strlen (outstr) + while (op > 0 && (IS_WHITE(outstr[op]) || outstr[op] == '\n')) + op = op - 1 + outstr[op+1] = EOS + } else + outstr[1] = EOS +end + + +# STF_GETCMT -- Get the comment field of a FITS encoded card. + +procedure stf_getcmt (card, comment, maxch) + +char card[ARB] #I FITS card to be decoded +char comment[ARB] #O output string to receive comment +int maxch #I max chars out + +int ip, op +int lastch + +begin + # Find the slash which marks the beginning of the comment field. + ip = FITS_ENDVALUE + 1 + while (card[ip] != EOS && card[ip] != '\n' && card[ip] != '/') + ip = ip + 1 + + # Copy the comment to the output string, omitting the /, any + # trailing blanks, and the newline. + + lastch = 0 + do op = 1, maxch { + if (card[ip] == EOS) + break + ip = ip + 1 + comment[op] = card[ip] + if (card[ip] > ' ') + lastch = op + } + comment[lastch+1] = EOS +end diff --git a/sys/imio/iki/stf/stfhextn.x b/sys/imio/iki/stf/stfhextn.x new file mode 100644 index 00000000..45e89f7a --- /dev/null +++ b/sys/imio/iki/stf/stfhextn.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "stf.h" + + +# STF_GETHDREXTN -- Get the default header file extension. + +procedure stf_gethdrextn (im, o_im, acmode, outstr, maxch) + +pointer im, o_im #I image descriptors +int acmode #I access mode +char outstr[maxch] #O receives header extension +int maxch #I max chars out + +bool inherit +int kernel, old_kernel +int fnextn(), iki_getextn(), iki_getpar() + +begin + # Use the same extension as the input file if this is a new copy + # image of the same type as the input and inherit is enabled. + # If we have to get the extension using iki_getextn, the default + # extension for a new image is the first extension defined (index=1). + + kernel = IM_KERNEL(im) + + old_kernel = 0 + if (acmode == NEW_COPY && o_im != NULL) + old_kernel = IM_KERNEL(o_im) + + inherit = (iki_getpar ("inherit") == YES) + if (inherit && acmode == NEW_COPY && kernel == old_kernel) { + if (fnextn (IM_HDRFILE(im), outstr, maxch) <= 0) + call strcpy (STF_DEFHDREXTN, outstr, maxch) + } else if (iki_getextn (kernel, 1, outstr, maxch) < 0) + call strcpy (STF_DEFHDREXTN, outstr, maxch) +end diff --git a/sys/imio/iki/stf/stfiwcs.x b/sys/imio/iki/stf/stfiwcs.x new file mode 100644 index 00000000..415b9a76 --- /dev/null +++ b/sys/imio/iki/stf/stfiwcs.x @@ -0,0 +1,60 @@ +include <imhdr.h> +include "stf.h" + +# STF_INITWCS -- Check for an unitialized WCS and set up a unitary pixel +# WCS in this case. + +procedure stf_initwcs (im) + +pointer im #I image descriptor + +real v +int ndim, i, j +bool have_wcs, wcsok +char pname[SZ_KEYWORD] +bool fp_equalr() +real imgetr() + +begin + ndim = IM_NDIM(im) + have_wcs = false + wcsok = false + + # Scan the header to determine if we have any WCS information (assume + # there is a WCS if any CDi_j cards are found) and if it has been + # initialized (at least one matrix element is nonzero). Note that + # we are checking only to see if the WCS has been initialized, not + # if it is a valid WCS. + + do j = 1, ndim { + do i = 1, ndim { + call sprintf (pname, SZ_KEYWORD, "CD%d_%d") + call pargi (i) + call pargi (j) + ifnoerr (v = imgetr (im, pname)) { + have_wcs = true + if (!fp_equalr (v, 0.0)) { + wcsok = true + break + } + } + } + if (wcsok) + break + } + + # If we found some WCS information and the CD matrix is zero, init + # the WCS. + + if (have_wcs && !wcsok) + do i = 1, ndim { + call sprintf (pname, SZ_KEYWORD, "CTYPE%d") + call pargi (i) + call imastr (im, pname, "PIXEL") + + call sprintf (pname, SZ_KEYWORD, "CD%d_%d") + call pargi (i) + call pargi (i) + call imaddr (im, pname, 1.0) + } +end diff --git a/sys/imio/iki/stf/stfmerge.x b/sys/imio/iki/stf/stfmerge.x new file mode 100644 index 00000000..a98ee877 --- /dev/null +++ b/sys/imio/iki/stf/stfmerge.x @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <mach.h> +include "stf.h" + +# STF_MERGEGPB -- Merge the non-reserved parameters from an existing GPB into +# a new GPB; called to construct a new GPB when an image is opened in new-copy +# mode. Since the new copy may not be the same size and dimension as the +# original, the reserved parameters must be set up fresh for the new copy +# image, i.e., we cannot simply copy them from the old image. Likewise, the +# WCS must be transformed if the new copy image does not geometrically overlay +# the original. +# +# NOTE: no longer called by stf_opix; save this code for future use! +# <dlb--11/4/87> + +procedure stf_mergegpb (n_im, o_im) + +pointer n_im # new copy image +pointer o_im # image being copied + +bool match +int n_i, o_i, n, ip, axis +int up_psize +pointer sp, cd_pat, n_stf, o_stf, n_pp, o_pp +int strncmp(), strlen(), patmake(), patmatch(), ctoi() + +begin + call smark (sp) + call salloc (cd_pat, SZ_LINE, TY_CHAR) + + # Make a pattern to match the CDa_b parameter names. + if (patmake ("CD[0-9]_[0-9]", Memc[cd_pat], SZ_LINE) < 0) + ; # cannot happen + + n_stf = IM_KDES(n_im) + o_stf = IM_KDES(o_im) + + # Examine each parameter in the old GPB and make an entry for the new + # ones in the new GPB. Note that all we are doing here is defining + # the structure; the GPB data is not physically written until the new + # header is updated on disk. The FITS encoded values for the GPB + # parameters will already have been copied to the user area of the + # new image. + + up_psize = 0 + for (o_i=1; o_i <= STF_PCOUNT(o_stf); o_i=o_i+1) { + o_pp = STF_PDES(o_stf,o_i) + n = strlen (P_PTYPE(o_pp)) + + if (P_PTYPE(o_pp) == 'C') + if (strncmp (P_PTYPE(o_pp), "CRPIX", 5) == 0 || + strncmp (P_PTYPE(o_pp), "CRVAL", 5) == 0 || + strncmp (P_PTYPE(o_pp), "CTYPE", 5) == 0 || + patmatch (P_PTYPE(o_pp), Memc[cd_pat]) > 0) { + + ip = 6 + if (ctoi (P_PTYPE(o_pp), ip, axis) <= 0) + axis = IM_MAXDIM + 1 + if (axis <= STF_NAXIS(n_stf)) + next + } + + # Is there a parameter of the same name in the new descriptor? + match = false + for (n_i=1; n_i <= STF_PCOUNT(n_stf); n_i=n_i+1) { + n_pp = STF_PDES(n_stf,n_i) + if (strncmp (P_PTYPE(o_pp), P_PTYPE(n_pp), n) == 0) { + match = true + break + } + } + + # If there was no match for the parameter, add a definition for + # it to the GPB descriptor for the new image. + + if (!match) { + n = STF_PCOUNT(n_stf) + 1 + if (n > MAX_PCOUNT) + call error (4, "stf_merge: too many group parameters") + + STF_PCOUNT(n_stf) = n + up_psize = up_psize + P_PSIZE(o_pp) + n_pp = STF_PDES(n_stf,n) + + P_SPPTYPE(n_pp) = P_SPPTYPE(o_pp) + P_PSIZE(n_pp) = P_PSIZE(o_pp) + P_LEN(n_pp) = P_LEN(o_pp) + + call strcpy (P_PTYPE(o_pp), P_PTYPE(n_pp), SZ_PTYPE) + call strcpy (P_PDTYPE(o_pp), P_PDTYPE(n_pp), SZ_PDTYPE) + } + } + + # Moved the PSIZE, SZGROUP calculations here to fix error in the + # computation of PSIZE--dlb, 11/2/87 + + STF_PSIZE(n_stf) = STF_PSIZE(n_stf) + up_psize + STF_SZGROUP(n_stf) = STF_SZGROUP(n_stf) + + up_psize / (SZB_CHAR * NBITS_BYTE) + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfmkpfn.x b/sys/imio/iki/stf/stfmkpfn.x new file mode 100644 index 00000000..4568efd8 --- /dev/null +++ b/sys/imio/iki/stf/stfmkpfn.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stf.h" + +# STF_MKPIXFNAME -- Given the root and extn fields of the image header filename, +# construct the pixel file name. The pixel file has the same root name as +# the header and the first two characters of the extension are the same as for +# the header, if a header extension was given. + +procedure stf_mkpixfname (hdr_root, hdr_extn, pixfname, maxch) + +char hdr_root[ARB] # root name of header file +char hdr_extn[ARB] # extension of header file +char pixfname[maxch] # receives pixel filename +int maxch + +int i +char pix_extn[MAX_LENEXTN] + +begin + call strcpy (STF_DEFPIXEXTN, pix_extn, MAX_LENEXTN) + if (hdr_extn[1] != EOS) { + for (i=1; i < MAX_LENEXTN; i=i+1) + pix_extn[i] = hdr_extn[i] + } + + call iki_mkfname (hdr_root, pix_extn, pixfname, maxch) +end diff --git a/sys/imio/iki/stf/stfnewim.x b/sys/imio/iki/stf/stfnewim.x new file mode 100644 index 00000000..3e8a95ed --- /dev/null +++ b/sys/imio/iki/stf/stfnewim.x @@ -0,0 +1,146 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <mach.h> +include "stf.h" + +define NBITS_CHAR (SZB_CHAR * NBITS_BYTE) + + +# STF_NEWIMAGE -- Set up the IMIO/STF descriptor for an image opened with mode +# new_image or new_copy of non-STF images. Note that the parameters GROUP +# and GCOUNT were set earlier by stf_open(). + +procedure stf_newimage (im) + +pointer im # image descriptor + +pointer stf +pointer o_im +long totpix +char pname[SZ_KEYWORD] +int old_kernel, pixtype, bitpix, nbytes, pno, ndim, i, j +errchk stf_addpar +string zero "0" +string one "1" + +include <szpixtype.inc> + +begin + # Get length of axes and datatype from imio descriptor; + # these may be changed by the user between image mapping + # and first i/o to pixfile so we set up the group parameter block + # and size of pixfile on first i/o operation + + stf = IM_KDES(im) + o_im = IM_OHDR(im) + ndim = IM_NDIM(im) + STF_NAXIS(stf) = ndim + do i = 1, ndim + STF_LENAXIS(stf,i) = IM_LEN(im,i) + + # Get datatype for the pixfile; stf_open has set this to datatype + # of template file if it exists, otherwise defaults to real(assuming + # the user hasn't changed it by now) + + pixtype = IM_PIXTYPE(im) + + bitpix = pix_size[pixtype] * NBITS_CHAR + nbytes = bitpix / NBITS_BYTE + + call sprintf (STF_DATATYPE(stf), SZ_DATATYPE, "%s*%d") + switch (pixtype) { + case TY_USHORT: + call pargstr ("UNSIGNED") + case TY_SHORT, TY_LONG, TY_INT: + call pargstr ("INTEGER") + case TY_REAL, TY_DOUBLE: + call pargstr ("REAL") + case TY_COMPLEX: + call pargstr ("COMPLEX") + default: + pixtype = TY_REAL + bitpix = SZ_REAL * NBITS_CHAR + nbytes = bitpix / NBITS_BYTE + call pargstr ("REAL") + } + call pargi (nbytes) + + STF_BITPIX(stf) = bitpix + + # Set the IMIO min/max fields. + + IM_MIN(im) = 0. + IM_MAX(im) = 0. + IM_LIMTIME(im) = 0 + + # For a new copy image(of an already-existing file), DO NOT add group + # parameters to the GPB, unless the original image is not an STF + # image. The following are the "standard" set of datamin/max and the + # FITS coordinate parms which SDAS files are supposed to have. + + if (IM_ACMODE(im) == NEW_COPY && o_im != NULL) + old_kernel = IM_KERNEL(o_im) + + if ((IM_ACMODE(im) == NEW_FILE) || + ((IM_ACMODE(im) == NEW_COPY) && IM_KERNEL(im) != old_kernel)) { + + # Set up the standard STF group parameter block parameters. + STF_GROUPS(stf) = YES + STF_PCOUNT(stf) = 2 + (ndim * 3) + (ndim * ndim) + STF_PSIZE(stf) = 2 * (SZ_REAL * NBITS_CHAR) + # DATAMIN/MAX + ndim * (SZ_DOUBLE * NBITS_CHAR) + # CRVALn + ndim * (SZ_REAL * NBITS_CHAR) + # CRPIXn + ndim * (8 * NBITS_BYTE) + # CTYPEn + (ndim * ndim) * (SZ_REAL * NBITS_CHAR) # CD matrix + + # Free any unneeded space in the STF descriptor. + if (STF_PCOUNT(stf) > 0) { + call realloc (stf, + LEN_STFBASE + STF_PCOUNT(stf)*LEN_PDES, TY_STRUCT) + IM_KDES(im) = stf + } + + # Set up the group data block in the STF descriptor and in + # the IMIO FITS format user area. WARNING--the STF kernel + # is implicitly assuming that the GPB related parameters + # in non-STF format images are at the beginning of the user + # area, if they are present at all. If this is not true + # then the following code will APPEND them to the user area. + # At STScI, non-STF format images are usually made from STF + # images and these parameters are at the beginning of the user + # area in that case. + + pno = 1 + call stf_addpar (im, "DATAMIN", TY_REAL, 1, zero, pno) + call stf_addpar (im, "DATAMAX", TY_REAL, 1, zero, pno) + + do i = 1, ndim { + call sprintf (pname, SZ_KEYWORD, "CRPIX%d"); call pargi (i) + call stf_addpar (im, pname, TY_REAL, 1, zero, pno) + call sprintf (pname, SZ_KEYWORD, "CRVAL%d"); call pargi (i) + call stf_addpar (im, pname, TY_DOUBLE, 1, zero, pno) + call sprintf (pname, SZ_KEYWORD, "CTYPE%d"); call pargi (i) + call stf_addpar (im, pname, TY_CHAR, 8, "PIXEL", pno) + + do j = 1, ndim { + call sprintf (pname, SZ_KEYWORD, "CD%d_%d") + call pargi (j) + call pargi (i) + if (i == j) + call stf_addpar (im, pname, TY_REAL, 1, one, pno) + else + call stf_addpar (im, pname, TY_REAL, 1, zero, pno) + } + } + } + + # Compute the size of each group in the pixel file, in chars. + totpix = IM_LEN(im,1) + do i = 2, ndim + totpix = totpix * IM_LEN(im,i) + + STF_SZGROUP(stf) = totpix * pix_size[IM_PIXTYPE(im)] + + STF_PSIZE(stf) / (SZB_CHAR * NBITS_BYTE) +end diff --git a/sys/imio/iki/stf/stfopen.x b/sys/imio/iki/stf/stfopen.x new file mode 100644 index 00000000..016c557e --- /dev/null +++ b/sys/imio/iki/stf/stfopen.x @@ -0,0 +1,225 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imio.h> +include "stf.h" + +# STF_OPEN -- Open/create an STF group format image. + +procedure stf_open (kernel, im, o_im, + root, extn, ksection, gr_arg, gc_arg, acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I other descriptor for NEW_COPY image +char root[ARB] #I root image name +char extn[ARB] #I extension, if any +char ksection[ARB] #I NOT USED +int gr_arg #I index of group to be accessed +int gc_arg #I number of groups in STF image +int acmode #I access mode +int status #O return value + +bool subimage +pointer sp, fname, stf, stf_extn, ua, o_stf +int group, gcount, newimage, gpb, hdr, o_stflen + +bool fnullfile(), envgetb() +int open(), stropen(), access() +errchk stf_initwcs, fmkcopy, calloc, realloc, syserrs +define err_ 91 + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (stf_extn, MAX_LENEXTN, TY_CHAR) + + ua = IM_USERAREA(im) + + # Allocate internal STF image descriptor. + call calloc (stf, LEN_STFDES, TY_STRUCT) + IM_KDES(im) = stf + + group = max (1, gr_arg) + gcount = max (group, gc_arg) + + STF_GRARG(stf) = max (0, gr_arg) + STF_GROUP(stf) = group + STF_GCOUNT(stf) = gcount + STF_ACMODE(stf) = acmode + STF_PFD(stf) = NULL + + # If a nonzero gcount is specified when a new-image or new-copy image + # is opened (e.g., [1/10] we assume that an entire new group format + # image is to be created with the given group count. If neither the + # group or gcount values are specified we assume that a new image is + # to be created. If the gcount field is zero (e.g., [1/0] or just [1]) + # then we assume that the image already exists and that we are being + # asked to rewrite the indexed image. + + newimage = NO + if (acmode == NEW_IMAGE || acmode == NEW_COPY) + if (gc_arg > 0 || (gr_arg <= 0 && gc_arg <= 0)) + newimage = YES + STF_NEWIMAGE(stf) = newimage + + # Generate full header file name. + if (extn[1] == EOS) { + call stf_gethdrextn (im, o_im, acmode, Memc[stf_extn], MAX_LENEXTN) + call iki_mkfname (root, Memc[stf_extn], Memc[fname], SZ_PATHNAME) + call strcpy (Memc[stf_extn], extn, MAX_LENEXTN) + } else + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + + call strcpy (Memc[fname], IM_HDRFILE(im), SZ_IMHDRFILE) + + # Generate full pixel file name. + call stf_mkpixfname (root, extn, Memc[fname], SZ_PATHNAME) + call strcpy (Memc[fname], IM_PIXFILE(im), SZ_IMPIXFILE) + + # Create and open the image header file if create a new physical + # image. If opening an existing image we do not open the header file + # here since the header may already be in the STF header cache. + # Since STF header files have a weird file type on some systems (VMS) + # we must create a new header file with FMKCOPY rather than OPEN. + + if (STF_NEWIMAGE(stf) == YES && !fnullfile (IM_HDRFILE(im))) { + if (access (IM_HDRFILE(im), 0,0) == YES) { + subimage = (gr_arg > 0 && gr_arg <= gc_arg) + if (subimage || envgetb ("imclobber")) { + iferr (call delete (IM_PIXFILE(im))) + goto err_ + iferr (call delete (IM_HDRFILE(im))) + goto err_ + } else { + call mfree (stf, TY_STRUCT) + call syserrs (SYS_IKICLOB, IM_HDRFILE(im)) + } + } + iferr (call fmkcopy (HDR_TEMPLATE, IM_HDRFILE(im))) + goto err_ + iferr (IM_HFD(im) = open (IM_HDRFILE(im), READ_WRITE, TEXT_FILE)) + goto err_ + } + + # If opening an existing image, read the image header into the STF + # image descriptor. + + switch (acmode) { + case NEW_IMAGE: + # For group formatted images, open NEW_IMAGE can mean either + # creating a new group format image, or opening a new group + # within an existing group format image. The latter case is + # indicated by a group index greater than 1. If we are creating + # a new group format image, wait until the user has set up the + # dimension parameters before doing anything further (in stfopix). + + if (STF_NEWIMAGE(stf) == NO) + iferr (call stf_rdheader (im, group, acmode)) + goto err_ + + case NEW_COPY: + # Make sure the FITS encoded user area we inherited is blocked. + + ### For now, always reblock the old header as the blocked flag + ### does not seem to be reliable and a header with variable length + ### lines can cause the header update to fail. This should be + ### fixed as a reblock of the full header is expensive. + + ### if (IM_UABLOCKED(o_im) != YES) + call stf_reblock (im) + + if (STF_NEWIMAGE(stf) == NO) { + # Open new group within existing GF image. The FITS header and + # GPB structure of the image being opened must be used, but the + # default data values for the GPB parameters are inherited from + # the image being copied. + + # Filter the copied user area to retain only the GPB cards. + # Opening the user area on two string file descriptors is a + # bit tricky, but will work since fixed size cards are copied, + # and the EOS isn't written until close time. + + if (IM_KDES(o_im) != NULL && IM_KERNEL(o_im) == IM_KERNEL(im)) { + hdr = stropen (Memc[ua], ARB, READ_ONLY) + gpb = stropen (Memc[ua], ARB, NEW_FILE) + call stf_copyfits (IM_KDES(o_im), hdr, gpb, NULL) + call close (gpb) + call close (hdr) + } + + # Read in the FITS header of the new image after the inherited + # GPB data cards, and set up the STF descriptor for the new GPB + # as defined in the new FITS header. + + iferr (call stf_rdheader (im, group, acmode)) + goto err_ + + # Initialize the WCS description if this is not done by the + # inherited user header. + + call stf_initwcs (im) + + } else { + # Completely new copy of an existing image, which may or may + # not be an STF format image. IMIO has already copied the + # size parameters of the old image as well as the cards in the + # user area of the old image (but without leaving space for + # the GPB cards if not an STF image). Copy old STF descriptor + # if the old image is also an STF format image, to inherit + # GPB structure. Wait until opix time to init the rest of the + # descriptor. + + if (IM_KDES(o_im) != NULL && IM_KERNEL(o_im) == IM_KERNEL(im)) { + o_stf = IM_KDES(o_im) + o_stflen = LEN_STFBASE + STF_PCOUNT(o_stf) * LEN_PDES + call amovi (Memi[o_stf], Memi[stf], o_stflen) + STF_ACMODE(stf) = acmode + STF_GROUP(stf) = group + STF_GCOUNT(stf) = gcount + STF_NEWIMAGE(stf) = newimage + STF_PFD(stf) = NULL + if (gcount > 1) + STF_GROUPS(stf) = YES + } else + STF_GROUPS(stf) = YES + + # Inherit datatype of input template image if specified, + # otherwise default datatype to real. + + if (IM_PIXTYPE(o_im) != NULL) + IM_PIXTYPE(im) = IM_PIXTYPE(o_im) + else + IM_PIXTYPE(im) = TY_REAL + } + + default: + # Open an existing group within an existing image. + iferr (call stf_rdheader (im, group, acmode)) + goto err_ + } + + # Set group number and count for the external world if this is a group + # format image. + + if (STF_GROUPS(stf) == YES) { + IM_CLINDEX(im) = STF_GROUP(stf) + IM_CLSIZE(im) = STF_GCOUNT(stf) + } + + # Free any unneeded space in the STF descriptor. + if (STF_PCOUNT(stf) > 0) + call realloc (stf, + LEN_STFBASE + STF_PCOUNT(stf)*LEN_PDES, TY_STRUCT) + IM_KDES(im) = stf + status = OK + + call sfree (sp) + return +err_ + status = ERR + call mfree (stf, TY_STRUCT) + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfopix.x b/sys/imio/iki/stf/stfopix.x new file mode 100644 index 00000000..da353119 --- /dev/null +++ b/sys/imio/iki/stf/stfopix.x @@ -0,0 +1,202 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include <fset.h> +include <mach.h> +include "stf.h" + +define NBITS_CHAR (SZB_CHAR * NBITS_BYTE) + +# STF_OPIX -- Open (or create) the pixel storage file. If the image header file +# is `image.hhh' the associated pixel storage file will be `image.hhd' in the +# same directory as the header file. STF_PFD is set if the pixel file is +# physically open. IM_PFD is not set until we have been called by IMIO, since +# we must be called to once set up all the descriptors, even if the pixel file +# was already opened to read the GPB. +# +# dlb, 18-may-88: added code to zero out gpb's in multi-group image for groups +# other than current; prevents strange numbers and when later programs try to +# read the gpb of an otherwise uninitialized group of the image. +# dlb, 29-dec-1988: added code to get default set of GPB parameters and +# correctly initialize STF-kernel descriptor. + +procedure stf_opix (im, status) + +pointer im # image descriptor +int status # return status + +int compress, blklen +bool copy_of_stf_image +int pfd, sz_gpb, group, i +pointer stf, o_stf, o_im, ua, gpb +long sz_pixfile, pixoff, totpix, offset + +int open() +errchk open, fseti, falloc, seek, syserrs, imioff, calloc +errchk write + +include <szpixtype.inc> + +begin + status = OK + if (IM_PFD(im) != NULL) + return + + o_im = IM_OHDR(im) + stf = IM_KDES(im) + ua = IM_USERAREA(im) + + pfd = STF_PFD(stf) + compress = YES + blklen = 1 + pixoff = 1 + + switch (IM_ACMODE(im)) { + case READ_ONLY, READ_WRITE, WRITE_ONLY, APPEND: + if (pfd == NULL) + pfd = open (IM_PIXFILE(im), IM_ACMODE(im), BINARY_FILE) + + case NEW_COPY, NEW_FILE: + # Initialize the IMIO and STF descriptors and allocate the pixel + # file. + + if (STF_NEWIMAGE(stf) == YES) { + # Normalize IMIO header parameters for new image. + call imioff (im, pixoff, compress, blklen) + + # Set up the required GPB parameters for the new image. + # Note - this call can change the STF pointer. + + call stf_newimage (im) + stf = IM_KDES(im) + + # Save the size of the old GPB user area header if we are + # making a new copy of an old STF format image. + + copy_of_stf_image = false + if (IM_ACMODE(im) == NEW_COPY && o_im != NULL) + if (IM_KERNEL(o_im) == IM_KERNEL(im)) + copy_of_stf_image = true + + if (copy_of_stf_image) { + o_stf = IM_KDES(o_im) + STF_PCOUNT(stf) = STF_PCOUNT(o_stf) + STF_PSIZE(stf) = STF_PSIZE(o_stf) + } + +# Since the stf_mergegpb code below has been deactivated, +# there is no need to do the complex and expensive spool/copy +# operation below. (dct 1/4/90) +# ------------------------------- +# # We have to have space for the GPB data cards at the beginning +# # of the user area, so spool any existing user cards in a +# # buffer and truncate the user area at the end of the GPB. +# +# ua_fd = stropen (Memc[ua+sz_gpbhdr], ARB, READ_ONLY) +# spool = open ("opix_spool", READ_WRITE, SPOOL_FILE) +# call fcopyo (ua_fd, spool) +# call close (ua_fd) +# Memc[ua+sz_gpbhdr] = EOS +# +# # Merge any extra GPB parameters from the old image into the +# # GPB structure of the new image. The GPB data cards for +# # these parameters should already be in the user area. +# # Order the group parameters to match the ordering in the +# # old image. NOTE: since the STF now copies all relevant +# # GPB parameters from an old image into the new or +# # generates a default standard set (in stf_newimage), +# # the following is no longer necessary. Note that if we +# # eventually may add parameters to the GPB, these routines +# # will again be useful! +# +# #if (copy_of_stf_image) { +# # call stf_mergegpb (im, o_im) +# # call stf_ordergpb (o_stf, stf) +# #} +# +# # Now append the spooled user header cards to the new user +# # area following the GPB data cards, deleting any user cards +# # which redefine GPB cards in the process. +# +# call seek (spool, BOFL) +# ua_size = (IM_LENHDRMEM(im) - LEN_IMHDR) * SZ_STRUCT +# ua_fd = stropen (Memc[ua], ua_size, APPEND) +# call stf_copyfits (stf, spool, NULL, ua_fd) +# call close (ua_fd) +# call close (spool) +# +# # Compute the length of the new header +# IM_HDRLEN(im) = LEN_IMHDR + +# (strlen(Memc[ua]) + SZ_STRUCT-1) / SZ_STRUCT + + # Open the new pixel storage file (preallocate space if + # enabled on local system). Save the physical pathname of + # the pixfile in the image header, in case "imdir$" changes. + + sz_pixfile = STF_SZGROUP(stf) * STF_GCOUNT(stf) + call falloc (IM_PIXFILE(im), sz_pixfile) + + # Zero out all remaining groups of the image + # Open pixel file if not already open + + if (STF_PFD(stf) == NULL) + pfd = open (IM_PIXFILE(im), READ_WRITE, BINARY_FILE) + + # Allocate a zeroed block of memory whose length is the same + # as that of the group parameter block + + sz_gpb = STF_PSIZE(stf) / NBITS_BYTE / SZB_CHAR + call calloc (gpb, sz_gpb, TY_CHAR) + + # Zero out every group except the current one. + do group = 1, STF_GCOUNT(stf) { + if (group != STF_GROUP(stf)) { + offset = (group * STF_SZGROUP(stf) + 1) - sz_gpb + call seek (pfd, offset) + call write (pfd, Memc[gpb], sz_gpb) + } + } + + # Free the block of memory. + call mfree (gpb, TY_CHAR) + + } else { + # If we are writing to a group of an existing multigroup image, + # verify that the important image parameters have not been + # changed. + + if (STF_NAXIS(stf) != IM_NDIM(im)) + call syserrs (SYS_IMGSZNEQ, IM_NAME(im)) + do i = 1, IM_NDIM(im) + if (STF_LENAXIS(stf,i) != IM_LEN(im,i)) + call syserrs (SYS_IMGSZNEQ, IM_NAME(im)) + + # Added 5/15/87--dlb to get correct size of each data portion + # of a group if image opened NEW_COPY and input file was a + # template of a different dimensionality used to get GPB. + # Compute the size of each group in the pixel file, in chars. + + totpix = IM_LEN(im,1) + do i = 2, IM_NDIM(im) + totpix = totpix * IM_LEN(im,i) + + STF_SZGROUP(stf) = totpix * pix_size[IM_PIXTYPE(im)] + + STF_PSIZE(stf) / (SZB_CHAR * NBITS_BYTE) + } + + if (pfd == NULL) + pfd = open (IM_PIXFILE(im), READ_WRITE, BINARY_FILE) + + # Tell IMIO where the pixels are. + pixoff = (STF_GROUP(stf) - 1) * STF_SZGROUP(stf) + 1 + call imioff (im, pixoff, compress, blklen) + + default: + call imerr (IM_NAME(im), SYS_IMACMODE) + } + + STF_PFD(stf) = pfd + IM_PFD(im) = pfd +end diff --git a/sys/imio/iki/stf/stfordgpb.x b/sys/imio/iki/stf/stfordgpb.x new file mode 100644 index 00000000..7099e106 --- /dev/null +++ b/sys/imio/iki/stf/stfordgpb.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include "stf.h" + +# STF_ORDERGPB -- Order the GPB, putting the group parameters in the +# new image in the same order as in the old image. +# NOTE: no longer called by stf_opix; save this code for future use! +# <dlb--11/4/87> + +procedure stf_ordergpb (o_stf, n_stf) + +pointer o_stf # STF descriptor of old image +pointer n_stf # STF descriptor of new image + +pointer sp, temp_pdes, pp, o_plist, n_plist +int o_pcount, n_pcount, otop, ntop, op, np, offset, sz_param, pn +bool streq() + +begin + o_pcount = STF_PCOUNT(o_stf) + n_pcount = STF_PCOUNT(n_stf) + if (o_pcount <= 0) + return + + call smark (sp) + call salloc (temp_pdes, LEN_PDES, TY_STRUCT) + + o_plist = STF_PDES(o_stf,1) + n_plist = STF_PDES(n_stf,1) + otop = (o_pcount * LEN_PDES) + ntop = (n_pcount * LEN_PDES) + + # Search the new parameter list for a parameter with the same name + # as a parameter in the old parameter list. When a match is found, + # move the new parameter into the same position as it is in the + # old parameter list. + + for (op=0; op < otop; op=op+LEN_PDES) + for (np=op; np < ntop; np=np+LEN_PDES) + if (streq (P_PTYPE(o_plist+op), P_PTYPE(n_plist+np))) { + if (op != np) { + # Swap parameters between old and new positions + call amovi (Memi[n_plist+op], Memi[temp_pdes], + LEN_PDES) + call amovi (Memi[n_plist+np], Memi[n_plist+op], + LEN_PDES) + call amovi (Memi[temp_pdes], Memi[n_plist+np], + LEN_PDES) + } + break + } + + # Update the field offsets. + offset = 0 + for (pn=1; pn <= n_pcount; pn=pn+1) { + pp = STF_PDES(n_stf,pn) + P_OFFSET(pp) = offset + sz_param = P_PSIZE(pp) / NBITS_BYTE / SZB_CHAR + offset = offset + sz_param + } + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfrdhdr.x b/sys/imio/iki/stf/stfrdhdr.x new file mode 100644 index 00000000..2c11fec9 --- /dev/null +++ b/sys/imio/iki/stf/stfrdhdr.x @@ -0,0 +1,186 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <finfo.h> +include <imhdr.h> +include <imio.h> +include <mach.h> +include "stf.h" + +# STF_RDHEADER -- Read the STF format image header for a single group into the +# IMIO descriptor. The standard fields are processed into the fields of the +# descriptor. The GPB binary parameters are encoded as FITS cards and placed +# in the IMIO user area, followed by all extra cards in the FITS format STF +# group header. Note that no distinction is made between the common FITS +# keywords and the GPB group parameters at the IMIO level and above. + +procedure stf_rdheader (im, group, acmode) + +pointer im # image descriptor +int group # group to be accessed +int acmode # access mode + +long pixoff +long fi[LEN_FINFO] +real datamin, datamax +pointer sp, stf, lbuf, root, extn, op +int compress, devblksz, ival, ch, i , junk +int fits, fitslen, sz_userarea, sz_gpbhdr, len_hdrmem +long totpix, mtime, ctime + +real imgetr() +int fnroot(), strlen(), finfo(), imaccf() +errchk stf_rfitshdr, stf_rgpb, open, realloc, imaddb, imaddi, imgetr + +include <szpixtype.inc> + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + + stf = IM_KDES(im) + + # Read the FITS header, setting the values of all reserved fields + # in the STF descriptor and saving all the user FITS cards in the + # save buffer "fits". + + call stf_rfitshdr (im, fits, fitslen) + + # Process the reserved keywords (set in the STF descriptor) into the + # corresponding fields of the IMIO descriptor. + + # Set group keywords if STF_GROUPS is NO (BPS 12.06.91). + if (STF_GROUPS(stf) == NO) { + STF_GCOUNT(stf) = 1 + STF_PCOUNT(stf) = 0 + STF_PSIZE(stf) = 0 + } + + if (acmode != NEW_COPY) { + IM_NDIM(im) = STF_NAXIS(stf) # IM_NDIM + do ival = 1, IM_MAXDIM # IM_LEN + IM_LEN(im,ival) = STF_LENAXIS(stf,ival) + } + + ch = STF_DATATYPE(stf) # IM_PIXTYPE + switch (STF_BITPIX(stf)) { + case 16: + if (ch == 'U') + ival = TY_USHORT + else + ival = TY_SHORT + case 32: + if (ch == 'R') + ival = TY_REAL + else + ival = TY_LONG + case 64: + if (ch == 'R') + ival = TY_DOUBLE + else + ival = TY_COMPLEX + default: + ival = ERR + } + IM_PIXTYPE(im) = ival + + call iki_parse (IM_HDRFILE(im), Memc[root], Memc[extn]) + call stf_mkpixfname (Memc[root], Memc[extn], IM_PIXFILE(im), + SZ_IMPIXFILE) + + if (finfo (IM_PIXFILE(im), fi) != ERR) { + mtime = FI_MTIME(fi) + ctime = FI_CTIME(fi) + } + + IM_NBPIX(im) = 0 # no. bad pixels + IM_CTIME(im) = ctime # creation time + IM_MTIME(im) = mtime # modify time + IM_LIMTIME(im) = mtime - 1 # time max/min last updated + IM_UABLOCKED(im) = YES # ua cards blocked to 80 chars + + IM_HISTORY(im) = EOS + junk = fnroot (IM_HDRFILE(im), Memc[lbuf], SZ_LINE) + call strupr (Memc[lbuf]) + call sprintf (IM_TITLE(im), SZ_IMTITLE, "%s[%d/%d]") + call pargstr (Memc[lbuf]) + call pargi (STF_GROUP(stf)) + call pargi (STF_GCOUNT(stf)) + + # Compute the size of each group in the pixel file, in chars. + totpix = IM_LEN(im,1) + do i = 2, IM_NDIM(im) + totpix = totpix * IM_LEN(im,i) + + STF_SZGROUP(stf) = totpix * pix_size[IM_PIXTYPE(im)] + + STF_PSIZE(stf) / (SZB_CHAR * NBITS_BYTE) + + # Write GPB related cards to the beginning of the IMIO user area. + call imaddb (im, "GROUPS", STF_GROUPS(stf) == YES) + call imaddi (im, "GCOUNT", STF_GCOUNT(stf)) + call imaddi (im, "PCOUNT", STF_PCOUNT(stf)) + call imaddi (im, "PSIZE", STF_PSIZE(stf)) + + # Extract the group parameter block from the pixfile, encoding the + # group parameters as FITS cards and appending to the cards above. + # Get the values of DATAMIN and DATAMAX from the GPB so that we can + # update the IMIO min/max fields. + + call stf_rgpb (im, group, acmode, datamin, datamax) + + # Reallocate the image descriptor to allow space for the spooled user + # FITS cards plus a little extra for new parameters. + + sz_gpbhdr = strlen (Memc[IM_USERAREA(im)]) + sz_userarea = sz_gpbhdr + fitslen + SZ_EXTRASPACE + + IM_HDRLEN(im) = LEN_IMHDR + + (sz_userarea - SZ_EXTRASPACE + SZ_MII_INT-1) / SZ_MII_INT + len_hdrmem = LEN_IMHDR + + (sz_userarea+1 + SZ_MII_INT-1) / SZ_MII_INT + + if (IM_LENHDRMEM(im) < len_hdrmem) { + IM_LENHDRMEM(im) = len_hdrmem + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + } + + # Append the saved FITS cards from the STF header to the user area. + # Any cards which redefine GPB cards were already deleted when the + # fits save buffer was created (we don't want the GPB cards since + # we already output a FITS card for each GPB parameter above). + + op = IM_USERAREA(im) + sz_gpbhdr + call amovc (Memc[fits], Memc[op], fitslen+1) + + # Set the IMIO min/max fields. If the GPB datamin >= datamax the + # values are invalidated by setting IM_LIMTIME to before the image + # modification time. Although datamin/datamax were returned by + # stg_rgpb above, we refetch the values here to pick up the values + # from the spooled main header in case there were no entries for + # these keywords in the GPB (if there are values in the GPB they + # will override those in the main header). + + if (imaccf (im, "DATAMIN") == YES) + datamin = imgetr (im, "DATAMIN") + if (imaccf (im, "DATAMAX") == YES) + datamax = imgetr (im, "DATAMAX") + + IM_MIN(im) = datamin + IM_MAX(im) = datamax + if (datamin < datamax) + IM_LIMTIME(im) = IM_MTIME(im) + 1 + else + IM_LIMTIME(im) = IM_MTIME(im) - 1 + + # Call up IMIO set set up the remaining image header fields used to + # define the physical offsets of the pixels in the pixfile. + + compress = YES # do not align image lines on blocks + devblksz = 1 # disable all alignment + + pixoff = (group - 1) * STF_SZGROUP(stf) + 1 + call imioff (im, pixoff, compress, devblksz) + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfreblk.x b/sys/imio/iki/stf/stfreblk.x new file mode 100644 index 00000000..9519bd08 --- /dev/null +++ b/sys/imio/iki/stf/stfreblk.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "stf.h" + +# STF_REBLOCK -- If the user area is not blocked to fixed length records, e.g., +# as is possible in a new copy image, reblock it fixed length. + +procedure stf_reblock (im) + +pointer im # image descriptor + +pointer sp, lbuf, op, ua +int fd, spool, nlines, nchars, sz_userarea, len_hdrmem +errchk stropen, open, getline, putline, realloc, seek, fcopyo +int open(), stropen(), getline() + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + ua = IM_USERAREA(im) + fd = stropen (Memc[ua], ARB, READ_ONLY) + spool = open ("rb_spool", READ_WRITE, SPOOL_FILE) + + # Reblock into a spool file, counting the lines. + for (nlines=0; ; nlines=nlines+1) { + nchars = getline (fd, Memc[lbuf]) + if (nchars <= 0) + break + + for (op=nchars; op <= FITS_RECLEN; op=op+1) + Memc[lbuf+op-1] = ' ' + Memc[lbuf+FITS_RECLEN] = '\n' + Memc[lbuf+FITS_RECLEN+1] = EOS + + call putline (spool, Memc[lbuf]) + } + + call close (fd) + + # Reallocate header the right size. + sz_userarea = nlines * (FITS_RECLEN+1) + SZ_EXTRASPACE + + IM_HDRLEN(im) = LEN_IMHDR + + (sz_userarea - SZ_EXTRASPACE + SZ_MII_INT-1) / SZ_MII_INT + len_hdrmem = LEN_IMHDR + + (sz_userarea+1 + SZ_MII_INT-1) / SZ_MII_INT + + if (IM_LENHDRMEM(im) < len_hdrmem) { + IM_LENHDRMEM(im) = len_hdrmem + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + } + + # Move spooled data back to user area. + ua = IM_USERAREA(im) + fd = stropen (Memc[ua], sz_userarea, NEW_FILE) + call seek (spool, BOFL) + call fcopyo (spool, fd) + + call close (fd) + call close (spool) + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfrename.x b/sys/imio/iki/stf/stfrename.x new file mode 100644 index 00000000..0d3c43fd --- /dev/null +++ b/sys/imio/iki/stf/stfrename.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include "stf.h" + +# STF_RENAME -- Rename an image. A special operator is required since the image +# is stored as two files. +# +# [NOTE] - Name changed to `rname' rather than `rename' to avoid a name +# collision with the SYMTAB procedure `stfree' (first such collision!). + +procedure stf_rname (kernel, oroot, oextn, nroot, nextn, status) + +int kernel #I IKI kernel +char oroot[ARB] # old image root name +char oextn[ARB] # old image extn +char nroot[ARB] # new image root name +char nextn[ARB] # old image extn +int status + +pointer sp +pointer ohdr_fname, opix_fname, nhdr_fname, npix_fname +bool streq() + +begin + call smark (sp) + call salloc (ohdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (opix_fname, SZ_PATHNAME, TY_CHAR) + call salloc (nhdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (npix_fname, SZ_PATHNAME, TY_CHAR) + + # Generate filenames. + call iki_mkfname (oroot, oextn, Memc[ohdr_fname], SZ_PATHNAME) + call iki_mkfname (nroot, nextn, Memc[nhdr_fname], SZ_PATHNAME) + + if (!streq (Memc[ohdr_fname], Memc[nhdr_fname])) { + call stf_mkpixfname (oroot, oextn, Memc[opix_fname], SZ_PATHNAME) + call stf_mkpixfname (nroot, nextn, Memc[npix_fname], SZ_PATHNAME) + + # If the header cannot be renamed, don't leave the pixfile alone. + iferr (call rename (Memc[ohdr_fname], Memc[nhdr_fname])) + call erract (EA_WARN) + else iferr (call rename (Memc[opix_fname], Memc[npix_fname])) + call erract (EA_WARN) + } + + call sfree (sp) + status = OK +end diff --git a/sys/imio/iki/stf/stfrfits.x b/sys/imio/iki/stf/stfrfits.x new file mode 100644 index 00000000..8ec9e9b0 --- /dev/null +++ b/sys/imio/iki/stf/stfrfits.x @@ -0,0 +1,266 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <ctype.h> +include <imhdr.h> +include <imio.h> +include <finfo.h> +include <fset.h> +include "stf.h" + +# STF_RFITSHDR -- Read a STF FITS image header, processing all reserved GPB +# definition keywords into the STF descriptor in the image descriptor, and +# saving the remaining cards (excluding cards which GPB keyword names) in +# in a save buffer. +# +# This routine implements a simple cache of FITS headers. If a given header +# is already in the cache and the cached entry is up to date, the cached +# spool file containing the user FITS cards and the saved STF descriptor are +# returned immediately without need to access the header file on disk. +# Otherwise, the new header is read into the oldest cache slot and the cached +# entry returned in the usual fashion. Any modifications to the header file +# which affect the file modify date will invalidate the cached entry. Note +# that multiple processes may cache the same header, so it is not permitted +# to modify the cached entry once the header file has been read. +# +# The following reserved keywords are recognized: +# +# SIMPLE BITPIX DATATYPE NAXIS* GROUPS GCOUNT PCOUNT PSIZE +# PTYPE* PDTYPE* PSIZE* +# +# All unrecognized cards, including HISTORY and COMMENT cards, blank lines, +# and any other garbage in the header, are preserved in the user area of the +# IMIO descriptor (i.e., in the spoolfile). Certain of the standard reserved +# cards (GROUPS, GCOUNT, etc.) are saved in the IMIO user area for the sake +# of the user, although the real values of these parameters are maintained only +# in the STF descriptor. + +procedure stf_rfitshdr (im, fits, fitslen) + +pointer im #I image descriptor +pointer fits #O pointer to saved FITS cards +int fitslen #O length of FITS save area + +long fi[LEN_FINFO] +pointer sp, pp, stf, o_stf, lbuf, op, hdrfile +int in, index, nchars, spool, slot, user, i + +bool streq() +long clktime(), fstatl() +int envgeti(), stf_ctype(), finfo(), getline(), open(), stropen() +errchk getline, putline, syserrs, open, seek, calloc, realloc +errchk fpathname, malloc, stf_copyfits + +bool initialized # CACHE definitions... +bool reload # reload cache +int rf_refcount # reference count +int rf_cachesize # number of cache slots +pointer rf_stf[MAX_CACHE] # STF descriptor +int rf_lru[MAX_CACHE] # lowest value is oldest slot +long rf_time[MAX_CACHE] # time when entry was cached +long rf_mtime[MAX_CACHE] # modify time of file in cache +int rf_fits[MAX_CACHE] # FITS data +int rf_fitslen[MAX_CACHE] # size of data area +char rf_fname[SZ_PATHNAME,MAX_CACHE] # header file pathname +data initialized /false/ + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + # Initialize the header file cache on the first call. + if (!initialized) { + rf_refcount = 0 + do i = 1, MAX_CACHE + rf_stf[i] = 0 + + iferr (rf_cachesize = envgeti (ENV_STFCACHE)) + rf_cachesize = DEF_CACHE + if (rf_cachesize > MAX_CACHE) { + call eprintf ("A maximum of %d STF headers may be cached\n") + call pargi (MAX_CACHE) + rf_cachesize = MAX_CACHE + } else if (rf_cachesize <= 0) + rf_cachesize = 0 + + initialized = true + } + + rf_refcount = rf_refcount + 1 + o_stf = IM_KDES(im) + reload = false + slot = 1 + + # Get file system info on the desired header file. + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + if (finfo (Memc[hdrfile], fi) == ERR) + call syserrs (SYS_FOPEN, IM_HDRFILE(im)) + + repeat { + # Search the header file cache for the named image. + do i = 1, max(1,rf_cachesize) { + if (rf_stf[i] == NULL) { + slot = i + next + } + + if (streq (Memc[hdrfile], rf_fname[1,i])) { + # File is in cache; is cached entry still valid? + if (FI_MTIME(fi) != rf_mtime[i]) { + # File modify date has changed, reuse slot. + slot = i + break + + } else if (!reload && clktime(rf_time[i]) < 2) { + # The file modify date has not changed, but the cache + # was loaded within the last clock "tick" (second), + # so we cannot be sure that the file was not modified. + # The cache must be reloaded, but set a flag so that + # rf_time is not changed, so that when the cache entry + # ages sufficiently it will be considered valid. + + reload = true + slot = i + break + + } else { + # Return the cached header. + rf_lru[i] = rf_refcount + call amovi (STF_CACHE(rf_stf[i]), STF_CACHE(o_stf), + STF_CACHELEN(rf_stf[i])) + fits = rf_fits[i] + fitslen = rf_fitslen[i] + + # Invalidate entry if cache is disabled. + if (rf_cachesize <= 0) + rf_time[i] = 0 + + call sfree (sp) + return # IN CACHE + } + + } else { + # Keep track of least recently used slot. + if (rf_lru[i] < rf_lru[slot]) + slot = i + } + } + + # Either the image header is not in the cache, or the cached + # entry is invalid. Prepare the given cache slot and read the + # header into it. + + # Free old save buffer and descriptor. + if (rf_stf[slot] != NULL) { + call mfree (rf_stf[slot], TY_STRUCT) + call mfree (rf_fits[slot], TY_CHAR) + } + + # Open the header file. + if (IM_HFD(im) == NULL) + in = open (Memc[hdrfile], READ_ONLY, TEXT_FILE) + else { + in = IM_HFD(im) + call seek (in, BOFL) + } + + # Allocate a spool file for the FITS data. + call sprintf (rf_fname[1,slot], SZ_PATHNAME, "STFHC#%d") + call pargi (slot) + spool = open (rf_fname[1,slot], READ_WRITE, SPOOL_FILE) + call fseti (spool, F_BUFSIZE, FI_SIZE(fi)) + + # Allocate cache version of STF descriptor. + call calloc (stf, LEN_STFDES, TY_STRUCT) + + # Initialize the cache entry. + call strcpy (Memc[hdrfile], rf_fname[1,slot], SZ_PATHNAME) + rf_stf[slot] = stf + rf_lru[slot] = rf_refcount + rf_mtime[slot] = FI_MTIME(fi) + if (!reload) + rf_time[slot] = clktime (0) + reload = true + + # Read successive lines of the FITS header. Process reserved + # keywords into the STF descriptor and spool the remaining cards + # to the fits spool file. + + repeat { + # Get the next input line. + nchars = getline (in, Memc[lbuf]) + if (nchars == EOF) + break + + # Block it out to 80 chars (plus newline) if it is not already. + if (nchars != FITS_RECLEN + 1) { + for (op=nchars; op <= FITS_RECLEN; op=op+1) + Memc[lbuf+op-1] = ' ' + Memc[lbuf+FITS_RECLEN] = '\n' + Memc[lbuf+FITS_RECLEN+1] = EOS + } + + # Process the header card. + switch (stf_ctype (Memc[lbuf], index)) { + case KW_BITPIX: + call stf_geti (Memc[lbuf], STF_BITPIX(stf)) + case KW_DATATYPE: + call stf_gets (Memc[lbuf], STF_DATATYPE(stf), SZ_DATATYPE) + case KW_END: + break + case KW_GCOUNT: + call stf_geti (Memc[lbuf], STF_GCOUNT(stf)) + case KW_GROUPS: + call stf_getb (Memc[lbuf], STF_GROUPS(stf)) + case KW_NAXIS: + call stf_geti (Memc[lbuf], STF_NAXIS(stf)) + case KW_NAXISN: + call stf_geti (Memc[lbuf], STF_LENAXIS(stf,index)) + case KW_PCOUNT: + call stf_geti (Memc[lbuf], STF_PCOUNT(stf)) + case KW_PDTYPE: + pp = STF_PDES(stf,min(index,MAX_PCOUNT)) + call stf_gets (Memc[lbuf], P_PDTYPE(pp), SZ_PDTYPE) + case KW_PSIZE: + call stf_geti (Memc[lbuf], STF_PSIZE(stf)) + case KW_PSIZEN: + pp = STF_PDES(stf,min(index,MAX_PCOUNT)) + call stf_geti (Memc[lbuf], P_PSIZE(pp)) + case KW_PTYPE: + pp = STF_PDES(stf,min(index,MAX_PCOUNT)) + call stf_gets (Memc[lbuf], P_PTYPE(pp), SZ_PTYPE) + call stf_getcmt (Memc[lbuf], P_COMMENT(pp), SZ_COMMENT) + case KW_SIMPLE: + ; + default: + call putline (spool, Memc[lbuf]) + } + } + + # Close the header file if opened locally. + if (IM_HFD(im) == NULL) + call close (in) + + # Free any unneeded space in the STF descriptor. + if (STF_PCOUNT(stf) > 0) { + call realloc (stf, + LEN_STFBASE + STF_PCOUNT(stf)*LEN_PDES, TY_STRUCT) + rf_stf[slot] = stf + } + + # Filter the spooled FITS cards to delete any cards which redefine + # GPB keywords. Store the filtered FITS data in the cache. + + call seek (spool, BOFL) + nchars = fstatl (spool, F_FILESIZE) + call malloc (fits, nchars, TY_CHAR) + user = stropen (Memc[fits], nchars, NEW_FILE) + call stf_copyfits (stf, spool, NULL, user) + + rf_fits[slot] = fits + rf_fitslen[slot] = fstatl (user, F_FILESIZE) + call close (user) + call close (spool) + } +end diff --git a/sys/imio/iki/stf/stfrgpb.x b/sys/imio/iki/stf/stfrgpb.x new file mode 100644 index 00000000..15c4da0a --- /dev/null +++ b/sys/imio/iki/stf/stfrgpb.x @@ -0,0 +1,179 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <mach.h> +include "stf.h" + +# STF_RGPB -- Read the group data block into the first few cards of the user +# area of the IMIO image header. The GPB is stored as a binary data structure +# in the STF pixfile. The values of the standard GPB parameters DATAMIN and +# DATAMAX are returned as output arguments. +# +# DLB--11/03/87: Made changes to allow i*2 and i*4 integer parameters in GPB. +# DLB--11/11/87: Changed calculation of character string length in GPB to +# avoid integer truncation error by using P_PSIZE directly. + +procedure stf_rgpb (im, group, acmode, datamin, datamax) + +pointer im # IMIO image descriptor +int group # group to be accessed +int acmode # image access mode +real datamin, datamax # min,max pixel values from GPB + +real rval +double dval +short sval +long lval, offset +bool bval, newgroup +pointer sp, stf, gpb, lbuf, pp +int pfd, pn, sz_param, sz_gpb +errchk imaddb, imadds, imaddl, imaddr, imaddd, imastr +errchk imputd, impstr, open, read +int open(), read(), imaccf() +real imgetr() + +string readerr "cannot read group data block - no such group?" +string badtype "illegal group data parameter datatype" +string nogroup "group index out of range" +define minmax_ 91 + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + stf = IM_KDES(im) + pfd = STF_PFD(stf) + + # Verify that the given group exists. + if (group < 1 || group > STF_GCOUNT(stf)) + call error (1, nogroup) + + # Skip ahead if there is no group parameter block. + if (STF_PSIZE(stf) == 0) + goto minmax_ + + # Open the pixel file if not already open. + if (pfd == NULL) { + iferr { + if (IM_ACMODE(im) == READ_ONLY) + pfd = open (IM_PIXFILE(im), READ_ONLY, BINARY_FILE) + else + pfd = open (IM_PIXFILE(im), READ_WRITE, BINARY_FILE) + STF_PFD(stf) = pfd + } then { + call eprintf ("Warning: Cannot open pixfile to read GPB (%s)\n") + call pargstr (IM_NAME(im)) + pfd = NULL + } + } + + # Allocate a buffer for the GPB. + sz_gpb = STF_PSIZE(stf) / NBITS_BYTE / SZB_CHAR + call salloc (gpb, sz_gpb, TY_CHAR) + + # Read the GPB into a buffer. The GPB is located at the very end of + # the data storage area for the group. If we are opening a new, + # uninitialized group (acmode = new_image or new_copy), do not + # physically read the GPB as it is will be uninitialized data. + + newgroup = (acmode == NEW_IMAGE || acmode == NEW_COPY || pfd == NULL) + if (newgroup) + call aclrc (Memc[gpb], sz_gpb) + else { + offset = (group * STF_SZGROUP(stf) + 1) - sz_gpb + call seek (pfd, offset) + if (read (pfd, Memc[gpb], sz_gpb) != sz_gpb) + call error (1, readerr) + } + + # Extract the binary value of each parameter in the GPB and encode it + # in FITS format in the IMIO user area. + + offset = 0 + for (pn=1; pn <= STF_PCOUNT(stf); pn=pn+1) { + pp = STF_PDES(stf,pn) + + # Fill in the unitialized fields of the GPB parameter descriptor. + P_OFFSET(pp) = offset + sz_param = P_PSIZE(pp) / NBITS_BYTE / SZB_CHAR + + switch (P_PDTYPE(pp)) { + # changed case for int to short and long--dlb 11/3/87 + case 'I': + if (sz_param == SZ_SHORT) + P_SPPTYPE(pp) = TY_SHORT + else + P_SPPTYPE(pp) = TY_LONG + P_LEN(pp) = 1 + case 'R': + if (sz_param == SZ_REAL) + P_SPPTYPE(pp) = TY_REAL + else + P_SPPTYPE(pp) = TY_DOUBLE + P_LEN(pp) = 1 + case 'C': + P_SPPTYPE(pp) = TY_CHAR + # calculate length directly from PSIZE to avoid truncation error + P_LEN(pp) = min (SZ_LINE, P_PSIZE(pp) / NBITS_BYTE) + case 'L': + P_SPPTYPE(pp) = TY_BOOL + P_LEN(pp) = 1 + default: + call error (1, badtype) + } + + # Extract the binary parameter value and add a FITS encoded card + # to the IMIO user area. In the case of a new copy image, the + # GPB values will already be in the image header, do not modify + # the parameter value, but add the parameter if it was not + # inherited from the old image. + + if (acmode != NEW_COPY || imaccf (im, P_PTYPE(pp)) == NO) { + switch (P_SPPTYPE(pp)) { + case TY_BOOL: + if (SZ_INT != SZ_INT32) + call amovc (Memc[gpb+offset], bval, SZ_INT32) + else + call amovc (Memc[gpb+offset], bval, SZ_BOOL) + call imaddb (im, P_PTYPE(pp), bval) + case TY_SHORT: + call amovc (Memc[gpb+offset], sval, SZ_SHORT) + call imadds (im, P_PTYPE(pp), sval) + case TY_LONG: + if (SZ_INT != SZ_INT32) + call amovc (Memc[gpb+offset], lval, SZ_INT32) + else + call amovc (Memc[gpb+offset], lval, SZ_LONG) + call imaddl (im, P_PTYPE(pp), lval) + case TY_REAL: + call amovc (Memc[gpb+offset], rval, SZ_REAL) + call imaddr (im, P_PTYPE(pp), rval) + case TY_DOUBLE: + call amovc (Memc[gpb+offset], dval, SZ_DOUBLE) + call imaddd (im, P_PTYPE(pp), dval) + case TY_CHAR: + call chrupk (Memc[gpb+offset], 1, Memc[lbuf], 1, P_LEN(pp)) + Memc[lbuf+P_LEN(pp)] = EOS + call imastr (im, P_PTYPE(pp), Memc[lbuf]) + default: + call error (1, badtype) + } + } + + offset = offset + sz_param + } + +minmax_ + # Return DATAMIN, DATAMAX. This is done by searching the user area so + # that ordinary keywords may be used to set datamin and datamax if the + # GPB is not used. + + datamin = 0.0; datamax = 0.0 + if (imaccf (im, "DATAMIN") == YES) + datamin = imgetr (im, "DATAMIN") + if (imaccf (im, "DATAMAX") == YES) + datamax = imgetr (im, "DATAMAX") + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfupdhdr.x b/sys/imio/iki/stf/stfupdhdr.x new file mode 100644 index 00000000..a4519c24 --- /dev/null +++ b/sys/imio/iki/stf/stfupdhdr.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include "stf.h" + +# STF_UPDHDR -- Update the STF/GEIS format image header. + +procedure stf_updhdr (im, status) + +pointer im # image descriptor +int status # return status + +pointer stf +int acmode +real datamin, datamax +errchk imerr, imputr, stf_wgpb + +begin + acmode = IM_ACMODE(im) + status = OK + stf = IM_KDES(im) + + if (acmode == READ_ONLY) + call imerr (IM_NAME(im), SYS_IMUPIMHDR) + + # Compute the values of DATAMIN and DATAMAX. + if (IM_LIMTIME(im) == 0 || IM_LIMTIME(im) < IM_MTIME(im)) { + datamin = 0. + datamax = 0. + } else { + datamin = IM_MIN(im) + datamax = IM_MAX(im) + } + + # Update the group parameter block. + call stf_wgpb (im, STF_GROUP(stf), datamin, datamax) + +# # Update the FITS header file, unless we are writing to a new group +# # in an existing group format image, in which case only the GPB is +# # updated. +# +# if (acmode != NEW_IMAGE && acmode != NEW_COPY) +# call stf_wfitshdr (im) +# else if (STF_NEWIMAGE(stf) == YES) +# call stf_wfitshdr (im) + + # The new strategy for FITS header updates is to always update, unless + # we are explicitly updating an existing group of a multigroup image. + # Hence, the FITS header is always updated for an STF image with only + # one group, or when writing the first group of a new STF imagefile. + # The FITS header of an existing STF multigroup image can still be + # updated, but only if the image is not opened to any particular group, + # e.g., as "pix" rather than "pix[n]", N > 0. NEW_[IMAGE|COPY] or + # READ_WRITE access to "pix[n]" will update only the GPB header. + + if (STF_NEWIMAGE(stf)==YES || STF_GCOUNT(stf)<=1 || STF_GRARG(stf)==0) + call stf_wfitshdr (im) +end diff --git a/sys/imio/iki/stf/stfwfits.x b/sys/imio/iki/stf/stfwfits.x new file mode 100644 index 00000000..c444a235 --- /dev/null +++ b/sys/imio/iki/stf/stfwfits.x @@ -0,0 +1,147 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include <imio.h> +include <fio.h> +include "stf.h" + +# STF_WFITSHDR -- Update the FITS header file. This is done by writing an +# entire new header file and then replacing the old header file with the +# new one. This is necessary since the header file is a text file and text +# files cannot be randomly updated. + +procedure stf_wfitshdr (im) + +pointer im # image descriptor + +pointer sp, fname, lbuf, stf, pp +int in, out, pn, junk, i, width + +bool fnullfile() +int stropen(), open(), protect(), strlen() #ditto-dlb +errchk fmkcopy, open, stropen, fcopyo, fprintf + +begin + if (fnullfile (IM_HDRFILE(im))) + return + + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + stf = IM_KDES(im) + + # Open a new header file with a unique, temporary name. Make a copy + # of the template file rather than of the old header file. Since + # we also block header lines out to 80 chars automatically, this + # means that we can read any old text file but will always generate + # a new header file of the standard type when the header is updated. + + call mktemp (IM_HDRFILE(im), Memc[fname], SZ_FNAME) + call fmkcopy (HDR_TEMPLATE, Memc[fname]) + out = open (Memc[fname], APPEND, TEXT_FILE) + + # Write out the standard, reserved header parameters. + + call fprintf (out, "SIMPLE =%21s /%81t\n") + call pargstr ("F") + call fprintf (out, "BITPIX =%21d /%81t\n") + call pargi (STF_BITPIX(stf)) + + # We want to get the full string length or 8 characters, + # whichever is greater--6/25/87, dlb + + call fprintf (out, "DATATYPE= '%*.*s'%32t/%81t\n") + width = max(8, strlen(STF_DATATYPE(STF))) + call pargi (-width) # force left-justified field + call pargi (width) + call pargstr (STF_DATATYPE(stf)) + + call fprintf (out, "NAXIS =%21d /%81t\n") + call pargi (STF_NAXIS(stf)) + do i = 1, STF_NAXIS(stf) { + call fprintf (out, "NAXIS%d%9t=%21d /%81t\n") + call pargi (i) + call pargi (STF_LENAXIS(stf,i)) + } + + call fprintf (out, "GROUPS =%21s /%81t\n") + if (STF_GROUPS(stf) == YES) + call pargstr ("T") + else + call pargstr ("F") + + # Changed order of the following three cards to conform + # to SOGS expectations--dlb, 7/14/87 + # Only write group keywords if STF_GROUPS is YES (BPS 12.06.91) + + if (STF_GROUPS(stf) == YES) { + call fprintf (out, "GCOUNT =%21d /%81t\n") + call pargi (STF_GCOUNT(stf)) + call fprintf (out, "PCOUNT =%21d /%81t\n") + call pargi (STF_PCOUNT(stf)) + call fprintf (out, "PSIZE =%21d /%81t\n") + call pargi (STF_PSIZE(stf)) + } + + # Add cards defining the fields of the group parameter block. Each + # field requires three cards. + + for (pn=1; pn <= STF_PCOUNT(stf); pn=pn+1) { + pp = STF_PDES(stf,pn) + + # PTYPE MUST be 8 characters or less. + call fprintf (out, "PTYPE%d%9t= '%-8.8s'%32t/%s%81t\n") + call pargi (pn) + call pargstr (P_PTYPE(pp)) + call pargstr (P_COMMENT(pp)) + + # Need width for string--6/26/87, dlb + call fprintf (out, "PDTYPE%d%9t= '%-*.*s'%32t/%81t\n") + call pargi (pn) + width = max (8, strlen(P_PDTYPE(pp))) + call pargi (-width) # force left-justified field + call pargi (width) + call pargstr (P_PDTYPE(pp)) + + call fprintf (out, "PSIZE%d%9t=%21d /%81t\n") + call pargi (pn) + call pargi (P_PSIZE(pp)) + } + + # Add the contents of the IMIO user area, excluding the cards used + # to represent GPB parameters. + + in = stropen (Memc[IM_USERAREA(im)], ARB, READ_ONLY) + call stf_copyfits (stf, in, NULL, out) + call close (in) + + # End of FITS header. + call fprintf (out, "END%81t\n") + call close (out) + + # Replace the original header file with the new one, even if the + # original header is a protected file. Transfer any file protection + # to the new file. + + if (IM_HFD(im) != NULL) + call close (IM_HFD(im)) + + if (protect (IM_HDRFILE(im), QUERY_PROTECTION) == YES) { + iferr (junk = protect (IM_HDRFILE(im), REMOVE_PROTECTION)) + call erract (EA_ERROR) + iferr (junk = protect (Memc[fname], SET_PROTECTION)) + call erract (EA_ERROR) + } + + iferr (call delete (IM_HDRFILE(im))) + call erract (EA_ERROR) + iferr (call rename (Memc[fname], IM_HDRFILE(im))) + call erract (EA_ERROR) + + if (IM_HFD(im) != NULL) + IM_HFD(im) = open (IM_HDRFILE(im), READ_ONLY, TEXT_FILE) + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfwgpb.x b/sys/imio/iki/stf/stfwgpb.x new file mode 100644 index 00000000..3a9e8fe8 --- /dev/null +++ b/sys/imio/iki/stf/stfwgpb.x @@ -0,0 +1,174 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include <imio.h> +include <mach.h> +include "stf.h" + +# STF_WGPB -- Write the group parameter block data back into the pixel file. +# The GPB is described by a structure member list in the STF descriptor. +# The values of the GPB parameters are encoded as FITS cards in the user +# area of the IMIO descriptor. +# +# DLB--11/3/87: Made changes to allow i*2 and i*4 integer parameters in gpb. + +procedure stf_wgpb (im, group, datamin, datamax) + +pointer im # IMIO image descriptor +int group # group to be accessed +real datamin, datamax # new min, max pixel values + +long offset +pointer sp, stf, gpb, lbuf, pp, op +int pfd, pn, sz_param, sz_gpb, i + +int open(), strlen() +bool bval, imgetb() +# changed to short and long for short integers in gpb +short sval, imgets() +long lval, imgetl() +# +real rval, imgetr() +double dval, imgetd() +errchk open, seek +int imaccf() + +string writerr "cannot update group parameter block" +string badtype "illegal group data parameter datatype" + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + stf = IM_KDES(im) + pfd = STF_PFD(stf) + + # Not all images have group parameter blocks. + if (STF_PSIZE(stf) == 0) { + call sfree (sp) + return + } + + # Open the pixel file if not already open. + if (pfd == NULL) { + pfd = open (IM_PIXFILE(im), READ_WRITE, BINARY_FILE) + STF_PFD(stf) = pfd + } + + # Update the values of DATAMIN, DATAMAX. + if (imaccf (im, "DATAMIN") == YES && + imaccf (im, "DATAMAX") == YES) { + + iferr { + call imputr (im, "DATAMIN", datamin) + call imputr (im, "DATAMAX", datamax) + } then + call erract (EA_WARN) + } + + # Allocate a buffer for the GPB. + sz_gpb = STF_PSIZE(stf) / NBITS_BYTE / SZB_CHAR + call salloc (gpb, sz_gpb, TY_CHAR) + + # Extract the binary value of each parameter in the GPB and encode it + # in FITS format in the IMIO user area. + + offset = 0 + for (pn=1; pn <= STF_PCOUNT(stf); pn=pn+1) { + pp = STF_PDES(stf,pn) + op = gpb + offset + + # Fetch the value of the parameter from IMIO and write it into + # the GPB binary data structure. + + switch (P_SPPTYPE(pp)) { + case TY_BOOL: + iferr (bval = imgetb (im, P_PTYPE(pp))) { + call erract (EA_WARN) + bval = false + } + # Memb[(op-1)/SZ_BOOL+1] = bval + if (SZ_INT != SZ_INT32) { + call i64to32 (bval, bval, 1) + call amovc (bval, Memc[op], SZ_INT32) + } else + call amovc (bval, Memc[op], SZ_BOOL) + + # changed case for int to short and long + # to allow i*2 in gpb--dlb 11/3/87 + case TY_SHORT: + iferr (sval = imgets (im, P_PTYPE(pp))) { + call erract (EA_WARN) + sval = 0 + } + call amovc (sval, Memc[op], SZ_SHORT) + + case TY_LONG: + iferr (lval = imgetl (im, P_PTYPE(pp))) { + call erract (EA_WARN) + lval = 0 + } + if (SZ_INT != SZ_INT32) { + call i64to32 (lval, lval, 1) + call amovc (lval, Memc[op], SZ_INT32) + } else + call amovc (lval, Memc[op], SZ_LONG) + + case TY_REAL: + iferr (rval = imgetr (im, P_PTYPE(pp))) { + # Currently with MWCS, WCS cards such as CRVAL, CDi_j, + # etc. (always type real or double) are omitted from the + # header if their value is zero. Hence if the card is + # missing assume a value of zero rather than issue a + # warning. + + # call erract (EA_WARN) + rval = 0.0 + } + # Memr[(op-1)/SZ_REAL+1] = rval + call amovc (rval, Memc[op], SZ_REAL) + + case TY_DOUBLE: + iferr (dval = imgetd (im, P_PTYPE(pp))) { + # Skip warning as assume zero, as above or TY_REAL. + # call erract (EA_WARN) + dval = 0.0D0 + } + # Memd[(op-1)/SZ_DOUBLE+1] = dval + call amovc (dval, Memc[op], SZ_DOUBLE) + + case TY_CHAR: + # Blank fill the string buffer. + do i = 1, P_LEN(pp) + Memc[lbuf+i-1] = ' ' + + # Fetch the string value of the parameter. + iferr (call imgstr (im, P_PTYPE(pp), Memc[lbuf], SZ_LINE)) + call erract (EA_WARN) + + # Replace the EOS delimiter by a blank. + i = strlen (Memc[lbuf]) + Memc[lbuf+i] = ' ' + + # Pack the blank filled array into the GPB. + call chrpak (Memc[lbuf], 1, Memc[gpb+offset], 1, P_LEN(pp)) + + default: + call error (1, badtype) + } + + sz_param = P_PSIZE(pp) / NBITS_BYTE / SZB_CHAR + offset = offset + sz_param + } + + # Write the GPB into the pixfile. The GPB is located at the very end + # of the data storage area for the group. + + offset = (group * STF_SZGROUP(stf) + 1) - sz_gpb + call seek (pfd, offset) + iferr (call write (pfd, Memc[gpb], sz_gpb)) + call error (5, writerr) + + call sfree (sp) +end |