diff options
Diffstat (limited to 'sys/imio/iki/fxf/fxfupdhdr.x')
| -rw-r--r-- | sys/imio/iki/fxf/fxfupdhdr.x | 1478 |
1 files changed, 1478 insertions, 0 deletions
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 |