From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001 From: Joseph Hunkeler Date: Wed, 8 Jul 2015 20:46:52 -0400 Subject: Initial commit --- sys/imio/iki/fxf/fxfopix.x | 746 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 746 insertions(+) create mode 100644 sys/imio/iki/fxf/fxfopix.x (limited to 'sys/imio/iki/fxf/fxfopix.x') 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 +include +include +include +include +include "fxf.h" +include + +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 + +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 + +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 + -- cgit