diff options
| author | Joe Hunkeler <jhunkeler@gmail.com> | 2015-08-11 16:51:37 -0400 |
|---|---|---|
| committer | Joe Hunkeler <jhunkeler@gmail.com> | 2015-08-11 16:51:37 -0400 |
| commit | 40e5a5811c6ffce9b0974e93cdd927cbcf60c157 (patch) | |
| tree | 4464880c571602d54f6ae114729bf62a89518057 /sys/imio/iki/fxf | |
| download | iraf-osx-40e5a5811c6ffce9b0974e93cdd927cbcf60c157.tar.gz | |
Repatch (from linux) of OSX IRAF
Diffstat (limited to 'sys/imio/iki/fxf')
30 files changed, 8285 insertions, 0 deletions
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 |