# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include include include include include include 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