Initial commit

1 files changed, 1322 insertions, 0 deletions

diff --git a/sys/imio/iki/fxf/fxfrfits.x b/sys/imio/iki/fxf/fxfrfits.x
new file mode 100644
index 00000000..30a8d5f7
--- /dev/null
+++ b/sys/imio/iki/fxf/fxfrfits.x
@@ -0,0 +1,1322 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+ 
+include <syserr.h>
+include <time.h>
+include <ctype.h>
+include <imhdr.h>
+include <imio.h>
+include <finfo.h>
+include <fset.h>
+include <mach.h>
+include <imset.h>
+include <error.h>
+include "fxf.h"
+
+# FXFRFITS.X -- Routines to load FITS header in memory and set up the cache
+# mechanism.
+
+define	LEN_UACARD_100	 8100
+define	LEN_UACARD_5	 405
+
+
+# FXF_RFITSHDR -- Procedure to read one or more FITS header while caching
+# the primary header, set the FITS memory structure for each
+# filename, the header and pixel offset from the beginning
+# and the EXTNAME and EXTVER value for each extension.
+
+procedure fxf_rfitshdr (im, group, poff)
+
+pointer im		#I image descriptor
+int	group		#I Group number to read
+int	poff		#O char offset the the pixel area in the FITS image
+
+long	fi[LEN_FINFO]
+pointer hoff,totpix, extn, extv
+pointer sp, fit, o_fit, lbuf, hdrfile, hdr
+int	cindx, cfit, user, fitslen, offs_count
+int	in, spool, slot, i, nrec1440, acmode
+
+bool	initialized, reload, extname_or_ver, ext_append
+data	initialized /false/
+int	rf_refcount
+
+bool	streq()
+long	cputime(), fstatl()
+
+int	finfo(), open(), stropen(), getline()
+
+errchk	putline, syserrs, seek, calloc, realloc, syserr
+errchk	fpathname, calloc, fxf_load_header, fxf_skip_xtn, fxf_read_xtn
+
+include "fxfcache.com"
+
+begin
+	call smark (sp)
+	call salloc (lbuf, SZ_LINE, TY_CHAR)
+	call salloc (hdrfile, SZ_PATHNAME, TY_CHAR)
+
+	# Initialize the header file cache on the first call.  The kernel
+	# doesn't appear to work with the cache completely deactivated, so
+	# the minimum cachesize is 1.
+
+	if (!initialized) {
+	    rf_refcount = 0
+	    do i = 1, MAX_CACHE
+		rf_fit[i] = 0
+	    rf_cachesize = max(1, min(MAX_CACHE, FKS_CACHESIZE(IM_KDES(im))))
+	    initialized = true
+	} else
+	    rf_refcount = rf_refcount + 1
+
+	o_fit = IM_KDES(im)
+	reload = false
+	slot = 1
+	# Get file system info on the desired header file.
+	call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME)
+
+	if (finfo (Memc[hdrfile], fi) == ERR) 
+	    call syserrs (SYS_FOPEN, IM_HDRFILE(im))
+
+        acmode = FIT_ACMODE(o_fit)
+	ext_append = (acmode == NEW_IMAGE || acmode == NEW_COPY)
+	repeat {
+	    # Search the header file cache for the named image.
+	    do cindx = 1, rf_cachesize {
+		if (rf_fit[cindx] == NULL) {
+		   slot = cindx
+		   next
+		}
+		if (streq (Memc[hdrfile], rf_fname[1,cindx])) {
+		    # File is in cache; is cached entry still valid?
+		    # If we are appending extension, do not reload from
+		    # disk.
+
+		    if (FI_MTIME(fi) != rf_mtime[cindx] && !ext_append) {
+			# File modify date has changed, reuse slot.
+			slot = cindx
+			break
+		    } 
+		    
+		    # For every non-empty file the fxf_open() call
+		    # pre reads every PHU, so that when the fxf_rdhdr()
+		    # comes, the cache entry is already here.
+
+		    # Return the cached header.
+		    rf_lru[cindx] = rf_refcount
+		    cfit = rf_fit[cindx]
+		    FIT_XTENSION(cfit) = FIT_XTENSION(o_fit)
+		    FIT_ACMODE(cfit) = FIT_ACMODE(o_fit)
+		    FIT_EXPAND(cfit) = FIT_EXPAND(o_fit)
+
+		    # Load Extend value from cache header entry to
+		    # the current fit struct entry.
+
+		    FIT_EXTEND(o_fit) = FIT_EXTEND(cfit)
+
+		    call amovi (FIT_ACMODE(cfit), FIT_ACMODE(o_fit),
+			LEN_FITBASE)
+		    hoff = rf_hdrp[cindx]
+		    poff = rf_pixp[cindx]
+		    extn = rf_pextn[cindx]
+		    extv = rf_pextv[cindx]
+		    FIT_GROUP(o_fit) = group
+		    FIT_HDRPTR(o_fit) = hoff
+		    FIT_PIXPTR(o_fit) = poff
+
+		    extname_or_ver = (FKS_EXTNAME(o_fit) != EOS ||
+			!IS_INDEFL (FKS_EXTVER(o_fit)))
+
+		    # If the group number or extname_or_ver has not been
+		    # specified we need to load the group number where there
+		    # is data i.e., FIT_NAXIS != 0. The 'cfit' structure would
+		    # have this group number.
+
+		    if (group == -1 && !extname_or_ver) {
+			if (FIT_GROUP(cfit) != -1) {
+			    group = FIT_GROUP(cfit)
+			    FIT_GROUP(o_fit) = group
+
+			} else if (FIT_NAXIS(cfit) != 0) {
+			    # See if the main FITS unit has data when
+			    # group = -1 is specified.
+
+			    group = 0
+			    FIT_GROUP(cfit) = 0
+			    FIT_GROUP(o_fit) = 0
+			}	
+		    }
+
+		    # The main header has already been read at this point,
+		    # now merge with UA.
+
+		    if (group == 0) {
+			hdr = rf_hdr[cindx]
+			fitslen = rf_fitslen[cindx]
+			FIT_EXTEND(o_fit) = FIT_EXTEND(cfit)
+			call fxf_merge_w_ua (im, hdr, fitslen)
+
+		    } else {
+			# Read intermediate xtension headers if not in
+			# hoff and poff yet.
+			offs_count = FIT_NUMOFFS(cfit)
+			call fxf_read_xtn (im,
+			    cfit, group, hoff, poff, extn, extv)
+		    } 
+
+		    # IM_CTIME takes the value of the DATE keyword
+		    if (IM_CTIME(im)==0) {
+			IM_CTIME(im) = FI_CTIME(fi)
+		    }
+
+		    # FIT_MTIME takes the value of keyword IRAF-TLM.
+		    # If not present use the mtime from the finfo value.
+
+		    if (FIT_MTIME(cfit) == 0) {
+			FIT_MTIME(cfit) = FI_MTIME(fi)
+		    }
+
+		    # Invalidate entry if cache is disabled.
+		    if (rf_cachesize <= 0)
+			rf_time[cindx] = 0
+
+		    call sfree (sp)
+		    return				# IN CACHE
+
+		} else {
+		    # Keep track of least recently used slot.
+		    if (rf_lru[cindx] < rf_lru[slot])
+			slot = cindx
+		}
+	    }
+
+	    # Either the image header is not in the cache, or the cached
+	    # entry is invalid.	 Prepare the given cache slot and read the
+	    # header into it.
+
+	    # Free old save buffer and descriptor.
+	    if (rf_fit[slot] != NULL) {
+		call mfree (rf_pextv[slot], TY_INT)
+		call mfree (rf_pextn[slot], TY_CHAR)
+		call mfree (rf_pixp[slot], TY_INT)
+		call mfree (rf_hdrp[slot], TY_INT)
+		call mfree (rf_fit[slot], TY_STRUCT)
+		call mfree (rf_hdr[slot], TY_CHAR)
+		rf_fit[slot] = NULL
+		rf_lru[slot] = 0
+		rf_fname[1,slot] = EOS
+	    }
+
+	    # Allocate a spool file for the FITS data.
+	    spool = open ("spool", NEW_FILE, SPOOL_FILE)
+
+	    # Allocate cache version of FITS descriptor.
+	    call calloc (fit, LEN_FITBASE, TY_STRUCT)
+	    call calloc (hoff, MAX_OFFSETS, TY_INT) 
+	    call calloc (poff, MAX_OFFSETS, TY_INT) 
+	    call calloc (extn, MAX_OFFSETS*LEN_CARD, TY_CHAR) 
+	    call calloc (extv, MAX_OFFSETS, TY_INT) 
+
+	    # Initialize the entries.
+	    call amovki (INDEFL, Memi[extv], MAX_OFFSETS)
+	    call aclrc (Memc[extn], MAX_OFFSETS)
+	    call amovki (-1, Memi[poff], MAX_OFFSETS)
+
+	    FIT_GROUP(fit) = -1
+	    FIT_HDRPTR(fit) = hoff
+	    FIT_PIXPTR(fit) = poff
+	    FIT_NUMOFFS(fit) = MAX_OFFSETS
+	    FIT_ACMODE(fit) = FIT_ACMODE(o_fit)
+	    FIT_BSCALE(fit) = 1.0d0
+	    FIT_BZERO(fit) = 0.0d0
+	    FIT_XTENSION(fit) = NO
+	    FIT_EXTNAME(fit) = EOS
+	    FIT_EXTVER(fit) = INDEFL
+	    FIT_EXTEND(fit) = -3
+
+	    # Initialize the cache entry.
+	    call strcpy (Memc[hdrfile], rf_fname[1,slot], SZ_PATHNAME)
+	    rf_fit[slot] = fit
+	    rf_hdrp[slot] = hoff
+	    rf_pixp[slot] = poff
+	    rf_pextn[slot] = extn
+	    rf_pextv[slot] = extv
+	    rf_lru[slot] = rf_refcount
+	    rf_mtime[slot] = FI_MTIME(fi)
+
+	    if (!reload)
+		rf_time[slot] = cputime (0)
+
+	    reload = true
+
+	    in = IM_HFD(im)
+	    call seek (in, BOFL)
+	    
+	    # Read main FITS header and copy to spool fd.
+	    FIT_IM(fit) = im
+	    call amovki (1, FIT_LENAXIS(fit,1), IM_MAXDIM)
+
+	    call fxf_load_header (in, fit, spool, nrec1440, totpix)
+
+
+	    # Record group 0 (PHU) as having just been read.
+	    FIT_GROUP(fit) = 0
+
+	    call seek (spool, BOFL)
+	    fitslen = fstatl (spool, F_FILESIZE)
+
+	    # Prepare cache area to store the FITS header.
+	    call calloc (hdr, fitslen, TY_CHAR)
+	    user = stropen (Memc[hdr], fitslen, NEW_FILE)
+	    rf_hdr[slot] = hdr
+	    rf_fitslen[slot] = fitslen
+	    FIT_CACHEHDR(fit) = hdr
+	    FIT_CACHEHLEN(fit) = fitslen
+
+	    # Append the saved FITS cards to saved cache.
+	    while (getline (spool, Memc[lbuf]) != EOF) 
+		call putline (user, Memc[lbuf])
+
+	    call close (user)
+	    call close (spool)
+	    
+	    # Group 0 (i.e. Main Fits unit)
+	    Memi[hoff] = 1	       # beginning of primary h.u.
+	    Memi[poff] = nrec1440 + 1  # first pixel data of main u.
+
+	    # Set group 1 offsets.
+	    Memi[hoff+1] = Memi[poff] + totpix
+	    Memi[poff+1] = -1
+	}
+
+        call sfree (sp)
+end
+
+
+# FXF_READ_XTN -- Procedure to read a FITS extension header and at the same
+# time make sure that the EXTNAME and EXTVER values are not repeated 
+# with those in the cache.
+
+procedure fxf_read_xtn (im, cfit, igroup, hoff, poff, extn, extv)
+
+pointer im			#I Image descriptor
+pointer cfit			#I Cached FITS descriptor
+int	igroup			#I Group number to process
+pointer hoff			#I Pointer to header offsets array
+pointer poff			#I Pointer to pixel offsets array
+pointer extn			#I Pointer to extname's array
+pointer extv			#I Pointer to extver's array
+
+char	messg[SZ_LINE]
+pointer lfit, sp, po, ln
+int	spool, ig, acmode, i
+int	fitslen, xtn_hd, nrec1440, totpix, in, group
+int	strcmp(), getline()
+long	offset, fstatl()
+int	open(), fxf_extnv_error()
+bool	ext_append, get_group
+
+errchk	fxf_load_header, fxf_skip_xtn, syserr, syserrs
+define	rxtn_ 91
+
+begin
+	# Allocate a spool file for the FITS header.
+	spool = open ("FITSHDRX", READ_WRITE, SPOOL_FILE)
+
+	lfit = IM_KDES(im)
+	group = FIT_GROUP(lfit)
+	acmode = FIT_ACMODE(lfit)
+	ext_append = (acmode == NEW_IMAGE || acmode == NEW_COPY)
+
+	# If we have 'overwrite' in the ksection then look for the
+	# existent extname/extver we want to overwrite since we don't
+	# want to append.
+
+	if (FKS_OVERWRITE(lfit) == YES)
+	    ext_append = false
+
+	# See if we want to look at an extension given the EXT(NAME,VER)
+	# field in the ksection.
+
+	if (FKS_EXTNAME(lfit) != EOS || !IS_INDEFL (FKS_EXTVER(lfit))) {
+	    ig = 1
+	    repeat {
+		call fseti (spool, F_CANCEL, YES)
+		xtn_hd = NO
+
+		# Has last extension header been read?
+		if (Memi[poff+ig] <= 0) { 
+		    iferr {
+			call fxf_skip_xtn (im,
+			    ig, cfit, hoff, poff, extn, extv, spool)
+			xtn_hd = YES
+		    } then {
+			if (ext_append) {
+			    # We have reach the end of extensions.
+			    FIT_GROUP(lfit) = -1    # message for fxf_updhdr
+			    return
+			} else {
+			    call fxf_form_messg (lfit, messg)
+			    call syserrs (SYS_FXFRFNEXTNV, messg)
+			}
+		    } else {	
+			# If we want to append an extension then.
+			if (ext_append && FKS_DUPNAME(lfit) == NO)
+			    if (fxf_extnv_error (lfit, ig, extn, extv) == YES) {
+				call fxf_form_messg (lfit, messg)
+				call syserrs (SYS_FXFOPEXTNV, messg)
+			    } 
+		    }
+		}
+
+		if (fxf_extnv_error (lfit, ig, extn, extv) == YES) {
+		    # We have matched either or both FKS_EXTNAME and FKS_EXTVER
+		    # with the values in the cache.
+
+		    if (ext_append && FKS_DUPNAME(lfit) == NO)	{
+			call fxf_form_messg (lfit, messg)
+			call syserrs (SYS_FXFOPEXTNV, messg)
+		    } 
+		    group = ig
+		    FIT_GROUP(lfit) = ig
+		    goto rxtn_
+
+		} else {
+		    ig = ig + 1
+		    next
+		}
+	    }
+
+	} else {
+	    # No extname or extver specified.
+	    # Read through the Extensions until group number is reached;
+	    # if no number is supplied, read until EOF to load header and
+	    # pixel offsets necessary to append and extension.
+	    
+	    if (igroup == -1 && FIT_GROUP(cfit) == -1)
+		group = MAX_INT
+
+	    # We are trying to get the first group that meets these condition.
+	    get_group = (FIT_GROUP(cfit) == -1 && igroup == -1) 
+
+	    do ig = 0, group  {
+		xtn_hd = NO
+
+		# Has last extension header been read?
+		if (Memi[poff+ig] <= 0 ) {
+		    call fseti (spool, F_CANCEL, YES)
+		    iferr {
+			call fxf_skip_xtn (im,
+			    ig, cfit, hoff, poff, extn, extv, spool)
+			xtn_hd = YES
+		    } then {
+			if (ext_append) {
+			    # We have reach the end of extensions.
+			    FIT_GROUP(lfit) = -1    # message for fxf_updhdr
+			    return
+			} else {
+			    call syserrs (SYS_FXFRFEOF, IM_NAME(im))
+			    return
+			}
+		    }
+
+		    # Mark the first group that contains an image
+		    # i.e. naxis != 0. 
+
+		    if (FIT_NAXIS(lfit) != 0 && 
+			    strcmp ("IMAGE", FIT_EXTTYPE(lfit)) == 0) {
+			if (get_group) {
+			    FIT_GROUP(cfit) = ig   # save on cache fits struct
+			    FIT_GROUP(lfit) = ig   # also on current
+			    break
+			} else if (FIT_GROUP(cfit) <= 0)
+			    FIT_GROUP(cfit) = ig 
+		    }
+	       }
+	    }
+	}
+rxtn_
+	if (xtn_hd == NO) {
+	    in = IM_HFD(im)
+	    offset = Memi[hoff+group]
+	    call seek (in, offset)
+	    FIT_IM(lfit) = im
+	    call fseti (spool, F_CANCEL, YES)
+	    call fxf_load_header (in, lfit, spool, nrec1440, totpix)
+	}
+
+	# If requested a non supported BINTABLE format, post an error
+	# message and return to the caller.
+
+	if (strcmp(FIT_EXTTYPE(lfit), "BINTABLE") == 0) {
+	    if (strcmp(FIT_EXTSTYPE(lfit), "PLIO_1") != 0) {
+	        call close (spool)
+		call syserrs (SYS_IKIEXTN, IM_NAME(im))
+            }
+	}
+	
+	# Merge Image Extension header to the user area.
+	fitslen = fstatl (spool, F_FILESIZE)
+
+	# Copy the spool array into a static array. We cannot reliable
+	# get the pointer from the spool file.
+	call smark (sp)
+	call salloc (ln, LEN_UACARD, TY_CHAR)
+
+	if (po != NULL)
+	    call mfree(po, TY_CHAR)
+	call calloc (po, fitslen+1, TY_CHAR)
+
+	i = po
+	call seek (spool, BOFL)
+	while (getline (spool, Memc[ln]) != EOF) {
+
+	    call amovc (Memc[ln], Memc[i], LEN_UACARD)
+	    i = i + LEN_UACARD
+	}
+	Memc[i] = EOS
+
+	# Make the user aware that they cannot use inheritance
+	# if the PDU contains a data array.
+
+	if (Memi[poff] != Memi[hoff+1]) {
+	    if (FKS_INHERIT(lfit) == YES) {
+		call syserr (SYS_FXFBADINH)
+	    }
+	} else {
+	    # Disable inheritance if PHDU has a DU.
+	    if (Memi[poff+0] != Memi[hoff+1])
+		FIT_INHERIT(lfit) = NO
+	}
+
+	# Reset the value of FIT_INHERIT if FKS_INHERIT is set
+	if (FKS_INHERIT(lfit) != NO_KEYW)
+	    FIT_INHERIT(lfit) = FKS_INHERIT(lfit)
+
+	if (FIT_TFIELDS(lfit) > 0) {
+	    fitslen = fitslen + FIT_TFIELDS(lfit)*LEN_UACARD
+	    call realloc (po, fitslen, TY_CHAR)
+        }
+
+	call fxf_merge_w_ua (im, po, fitslen)
+
+	call mfree (po, TY_CHAR)
+
+	call sfree (sp)
+	call close (spool)
+end
+
+
+# FXF_EXTNV_ERROR -- Integer boolean function (YES,NO) to find out if the
+# value of kernel section parameter FKS_EXTNAME and FKS_EXTVER are not
+# repeated in the cache pointed by extn and extv.
+
+int procedure fxf_extnv_error (fit, ig, extn, extv)
+
+pointer fit			#I fit descriptor
+int	ig			#I extension number
+pointer extn, extv		#I pointers to arrays for extname and extver 
+
+bool	bxtn, bxtv, bval, bxtn_eq, bxtv_eq
+int	fxf_strcmp_lwr()
+
+begin
+	bxtn = (FKS_EXTNAME(fit) != EOS)
+	bxtv = (!IS_INDEFL (FKS_EXTVER(fit)))
+
+	if (bxtn)
+	    bxtn_eq =
+		(fxf_strcmp_lwr(FKS_EXTNAME(fit), Memc[extn+LEN_CARD*ig]) == 0)
+	if (bxtv)
+	    bxtv_eq = (FKS_EXTVER(fit) == Memi[extv+ig])
+	
+	if (bxtn && bxtv) {
+	    # Since both FKS_EXTNAME and FKS_EXTVER are defined, see if they
+	    # repeated in the cache.
+
+	    bval = (bxtn_eq && bxtv_eq)
+
+	} else if (bxtn && !bxtv) {
+	    # We have a duplicated in this case when extver in the image
+	    # header is INDEFL.
+
+	    bval = bxtn_eq
+
+	} else if (!bxtn && bxtv) {
+	    # If the FKS_EXTNAME is not defined (i.e. EOS) and the FKS_EXTVER
+	    # value is the same as the cached, then we have a match.
+
+	    bval = bxtv_eq 
+
+	} else
+	    bval = false
+	
+	if (bval)
+	    return (YES)
+	else
+	    return (NO)
+end
+
+
+# FXF_SKIP_XTN -- Skip over a FITS extension.  The procedure will read the
+# current extension header and calculates the respectives offset for later
+# usage.
+
+procedure fxf_skip_xtn (im, group, cfit, hoff, poff, extn, extv, spool)
+
+pointer im			#I image descriptor
+int	group			#I groupheader number to read
+pointer cfit			#I cached fits descriptor
+pointer hoff			#I extension header offset
+pointer poff			#I extension data offset
+pointer extn			#I points to the array of extname
+pointer extv			#I points to the arrays of extver
+
+pointer sp, lfit, fit, hdrfile
+bool    streq()
+int	spool, in, nrec1440, totpix, i, k, cindx
+long	offset
+errchk	fxf_load_header
+int	strcmp()
+
+include "fxfcache.com"
+
+begin
+	call smark (sp)
+	call salloc (lfit, LEN_FITBASE, TY_STRUCT)
+        call salloc (hdrfile, SZ_PATHNAME, TY_CHAR)
+
+	call seek (spool, BOFL)
+	fit = IM_KDES(im)
+
+	# Allocate more memory for offsets in case we are pass MAX_OFFSETS.
+	if (group >= FIT_NUMOFFS(cfit)) {
+	    FIT_NUMOFFS(cfit) = FIT_NUMOFFS(cfit) + MAX_OFFSETS 
+	    call realloc (hoff, FIT_NUMOFFS(cfit), TY_INT)
+	    call realloc (poff, FIT_NUMOFFS(cfit), TY_INT)
+	    call realloc (extn, FIT_NUMOFFS(cfit)*LEN_CARD, TY_CHAR)
+	    call realloc (extv, FIT_NUMOFFS(cfit), TY_INT)
+
+	    offset = FIT_NUMOFFS(cfit) - MAX_OFFSETS
+	    call amovki (INDEFL, Memi[extv+offset], MAX_OFFSETS)
+	    call amovki (-1, Memi[poff+offset], MAX_OFFSETS)
+
+	    do i = 0,  MAX_OFFSETS-1  {
+		k = (offset+i)*LEN_CARD
+		Memc[extn+k] = EOS
+	    }
+	 
+	    # Update the fits structure with the new pointer values
+	    call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME)
+	    fit = IM_KDES(im)
+	    do cindx = 1, rf_cachesize {
+	        if (rf_fit[cindx] == NULL)
+	            next
+	        if (streq (Memc[hdrfile], rf_fname[1,cindx])) {
+	            rf_pextn[cindx] = extn
+		    rf_pextv[cindx] = extv
+		    rf_hdrp[cindx] = hoff
+		    rf_pixp[cindx] = poff
+		    FIT_HDRPTR(fit) = hoff
+		    FIT_PIXPTR(fit) = poff
+	        }
+	    }
+	}
+		
+	in = IM_HFD(im)
+	offset = Memi[hoff+group]
+
+	call seek (in, offset)
+	lfit = IM_KDES(im)
+	FIT_IM(lfit) = im
+	call fxf_load_header (in, lfit, spool, nrec1440, totpix)
+
+	# Record the first group that has NAXIS !=0 and is an IMAGE.
+	if (FIT_GROUP(cfit) == -1) {
+	    if (FIT_NAXIS(lfit) != 0 &&
+		    strcmp ("IMAGE", FIT_EXTTYPE(lfit)) == 0)
+		FIT_GROUP(cfit) = group
+	}
+
+	Memi[poff+group] = Memi[hoff+group] + nrec1440
+	# The offset for the beginning of next group.
+	Memi[hoff+group+1] = Memi[poff+group] + totpix
+
+	# Mark next group pixel offset in case we are at EOF.
+	Memi[poff+group+1] = -1
+	call strcpy (FIT_EXTNAME(lfit), Memc[extn+LEN_CARD*group], LEN_CARD) 
+	Memi[extv+group] = FIT_EXTVER(lfit)
+
+	call sfree (sp)
+end
+
+
+# FXF_LOAD_HEADER -- Load a FITS header from a file descriptor into a
+# spool file.
+
+procedure fxf_load_header (in, fit, spool, nrec1440, datalen)
+
+int	in			#I input FITS header file descriptor
+pointer fit			#I FITS descriptor
+int	spool			#I spool output file descriptor
+int	nrec1440		#O number of 1440 char records output
+int	datalen			#O length of data area in chars
+
+int	ncols
+pointer lbuf, sp, im, stime, fb, ttp
+int	totpix, nchars, nbytes, index, ncards, simple, i, pcount, junk
+int	fxf_read_card(), fxf_ctype(), ctoi(), strsearch()
+bool	fxf_fpl_equald()
+errchk	syserr, syserrs
+
+begin
+	call smark (sp)
+	call salloc (lbuf, SZ_LINE, TY_CHAR)
+	call salloc (stime, LEN_CARD, TY_CHAR)
+	call salloc (fb, FITS_BLOCK_BYTES, TY_CHAR)
+
+	FIT_BSCALE(fit) = 1.0d0
+	FIT_BZERO(fit) = 0.0d0
+	FIT_EXTNAME(fit) = EOS
+	FIT_EXTVER(fit) = INDEFL
+	im = FIT_IM(fit)
+
+	# Read successive lines of the FITS header. 
+	nrec1440 = 0
+	pcount = 0
+	ncards = 0
+
+	repeat {
+	    # Get the next input line.
+	    nchars = fxf_read_card (in, Memc[fb], Memc[lbuf], ncards)
+	    if (nchars == EOF) {
+		call close (spool)
+		call syserrs (SYS_FXFRFEOF, IM_NAME(im))
+            }
+	    ncards = ncards + 1
+
+	    # A FITS header card already has 80 chars, just add the newline.
+	    Memc[lbuf+LEN_CARD] = '\n'
+	    Memc[lbuf+LEN_CARD+1] = EOS
+
+	    # Process the header card.
+	    switch (fxf_ctype (Memc[lbuf], index)) {
+	    case KW_END:
+		nrec1440 = FITS_LEN_CHAR(ncards*40)
+		break
+	    case KW_SIMPLE:
+		call strcpy ("SIMPLE", FIT_EXTTYPE(fit), SZ_EXTTYPE)
+		call fxf_getb (Memc[lbuf], simple)
+		FIT_EXTEND(fit) = NO_KEYW
+		if (simple == NO)
+		    call syserr (SYS_FXFRFSIMPLE)
+	    case KW_EXTEND:
+		call putline (spool, Memc[lbuf])
+		call fxf_getb (Memc[lbuf], FIT_EXTEND(fit)) 
+	    case KW_XTENSION:
+		FIT_XTENSION(fit) = YES 
+		call fxf_gstr (Memc[lbuf], FIT_EXTTYPE(fit), SZ_EXTTYPE)
+	    case KW_EXTNAME:
+		call fxf_gstr (Memc[lbuf], FIT_EXTNAME(fit), LEN_CARD)
+		call putline (spool, Memc[lbuf])
+	    case KW_EXTVER:
+		call fxf_geti (Memc[lbuf], FIT_EXTVER(fit))
+		call putline (spool, Memc[lbuf])
+	    case KW_ZCMPTYPE:
+		call fxf_gstr (Memc[lbuf], FIT_EXTSTYPE(fit), SZ_EXTTYPE)
+	    case KW_PCOUNT:
+		call fxf_geti (Memc[lbuf], pcount)
+		call putline (spool, Memc[lbuf])
+		FIT_PCOUNT(fit) = pcount
+	    case KW_INHERIT:
+		call fxf_getb (Memc[lbuf], FIT_INHERIT(fit))
+		call putline (spool, Memc[lbuf])
+	    case KW_BITPIX:
+		call fxf_geti (Memc[lbuf], FIT_BITPIX(fit))
+	    case KW_DATATYPE:
+		call fxf_gstr (Memc[lbuf], FIT_DATATYPE(fit), SZ_DATATYPE)
+	    case KW_NAXIS:
+		if (index == 0) {
+		    call fxf_geti (Memc[lbuf], FIT_NAXIS(fit))
+		    if (FIT_NAXIS(fit) < 0 )
+			call syserr (SYS_FXFRFBNAXIS)
+	  	} else
+		    call fxf_geti (Memc[lbuf], FIT_LENAXIS(fit,index))
+	    case KW_BSCALE:
+		call fxf_getd (Memc[lbuf], FIT_BSCALE(fit))
+		# If BSCALE is like 1.00000011 reset to 1.0.
+		if (fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 4))
+		    FIT_BSCALE(fit) = 1.0d0
+		call putline (spool, Memc[lbuf])
+	    case KW_BZERO:
+		call fxf_getd (Memc[lbuf], FIT_BZERO(fit))
+		# If BZERO is like 0.00000011 reset to 0.0.
+		if (fxf_fpl_equald (0.0d0, FIT_BZERO(fit), 4))
+		    FIT_BZERO(fit) = 0.0d0
+		call putline (spool, Memc[lbuf])
+	    case KW_DATAMAX:
+		call fxf_getr (Memc[lbuf], FIT_MAX(fit))
+		call putline (spool, Memc[lbuf])
+	    case KW_DATAMIN:
+		call fxf_getr (Memc[lbuf], FIT_MIN(fit))
+		call putline (spool, Memc[lbuf])
+	    case KW_TFIELDS:
+		# Allocate space for TFORM and TTYPE keyword values
+		call fxf_geti (Memc[lbuf], ncols)
+		FIT_TFIELDS(fit) = ncols
+		if (FIT_TFORMP(fit) != NULL) {
+		    call mfree (FIT_TFORMP(fit), TY_CHAR)
+		    call mfree (FIT_TTYPEP(fit), TY_CHAR)
+	        }
+		call calloc (FIT_TFORMP(fit), ncols*LEN_FORMAT, TY_CHAR)
+		call calloc (FIT_TTYPEP(fit), ncols*LEN_OBJECT, TY_CHAR)
+	    case KW_TFORM:
+		call fxf_gstr (Memc[lbuf], Memc[stime], LEN_CARD)
+		if (index == 1) {
+		    # PLMAXLEN is used to indicate the maximum line list
+		    # length for PLIO masks in bintables.  The syntax
+		    # "PI(maxlen)" is used in bintables to pass the max
+		    # vararray length for a column.
+
+		    i = strsearch (Memc[stime], "PI(") 
+		    if (i > 0)
+			junk = ctoi (Memc[stime], i, FIT_PLMAXLEN(fit))
+		}
+	    case KW_TTYPE:
+		ttp = FIT_TTYPEP(fit) + (index-1)*LEN_OBJECT
+		call fxf_gstr (Memc[lbuf], Memc[ttp], LEN_CARD)
+	    case KW_OBJECT:
+		# Since only OBJECT can go into the header and IM_TITLE has its
+		# values as well, we need to save both to see which one has
+		# changed at closing time.
+
+		call fxf_gstr (Memc[lbuf], FIT_OBJECT(fit), LEN_CARD)
+		if (FIT_OBJECT(fit) == EOS)
+		    call strcpy ("        ", FIT_OBJECT(fit), SZ_KEYWORD)
+		call strcpy (FIT_OBJECT(fit), FIT_TITLE(fit), LEN_CARD)
+		call strcpy (FIT_OBJECT(fit), IM_TITLE(im), LEN_CARD)
+		call putline (spool, Memc[lbuf])
+	    case KW_IRAFTLM:
+		call fxf_gstr (Memc[lbuf], Memc[stime], LEN_CARD)
+		call fxf_date2limtime (Memc[stime], FIT_MTIME(fit))
+		call putline (spool, Memc[lbuf])
+	    case KW_DATE:
+		call fxf_gstr (Memc[lbuf], Memc[stime], LEN_CARD)
+		call fxf_date2limtime (Memc[stime], IM_CTIME(im))
+		call putline (spool, Memc[lbuf])
+	    default:
+		call putline (spool, Memc[lbuf])
+	    }
+	}
+
+	# Calculate the length of the data area of the current extension,
+	# measured in SPP chars and rounded up to an integral number of FITS
+	# logical blocks.
+
+	if (FIT_NAXIS(fit) != 0) {
+	    totpix =  FIT_LENAXIS(fit,1)
+	    do i = 2, FIT_NAXIS(fit)
+		totpix = totpix * FIT_LENAXIS(fit,i)
+
+	    # Compute the size of the data area (pixel matrix plus PCOUNT)
+	    # in bytes.  Be careful not to overflow a 32 bit integer.
+
+	    nbytes = (totpix + pcount) * (abs(FIT_BITPIX(fit)) / NBITS_BYTE)
+
+	    # Round up to fill the final 2880 byte FITS logical block.
+	    nbytes = ((nbytes + 2880-1) / 2880) * 2880
+
+	    datalen = nbytes / SZB_CHAR
+
+	} else
+	    datalen = 0
+
+	call sfree (sp)
+end
+
+
+# FXF_MERGE_W_UA --  Merge a spool user area with the im_userarea.
+
+procedure fxf_merge_w_ua (im, userh, fitslen) 
+
+pointer im		#I image descriptor
+int	userh		#I pointer to user area spool
+int	fitslen		#I length in chars of the user area
+
+bool	inherit
+pointer sp, lbuf, ua, ln
+int	elen, elines, nbl, i, k
+int	sz_userarea, merge, len_hdrmem, fit, clines, ulines
+bool	fxf_is_blank()
+int	strlen()
+
+begin
+	call smark (sp)
+	call salloc (lbuf, SZ_LINE, TY_CHAR)
+	call salloc (ln, LEN_UACARD, TY_CHAR)
+
+	fit = IM_KDES(im)
+
+	# FIT_INHERIT has the logically combined value of the fkinit inherit's
+	# value, if any; the ksection value, if any and the INHERIT value in
+	# the extension header.
+
+	inherit = (FIT_INHERIT(fit) == YES)
+	inherit = (inherit && (FIT_GROUP(fit) != 0))
+
+	# Reallocate the image descriptor to allow space for the spooled user
+	# FITS cards plus a little extra for new parameters.
+
+	sz_userarea = fitslen + SZ_EXTRASPACE
+	# Add size of main header if necessary.
+	if (inherit)
+	    sz_userarea = sz_userarea + FIT_CACHEHLEN(fit)
+
+	IM_HDRLEN(im) = LEN_IMHDR +
+	    (sz_userarea - SZ_EXTRASPACE + SZ_MII_INT-1) / SZ_MII_INT
+	len_hdrmem = LEN_IMHDR +
+	    (sz_userarea+1 + SZ_MII_INT-1) / SZ_MII_INT
+
+	if (IM_LENHDRMEM(im) < len_hdrmem) {
+	    IM_LENHDRMEM(im) = len_hdrmem
+	    call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT)
+	}
+
+
+	# Copy the extension header to the USERAREA if not inherit or copy
+	# the global header plus the extension header if inherit is set.
+
+	if (fitslen > 0) {
+	    ua = IM_USERAREA(im)
+	    elen = fitslen
+
+	    if (inherit) {
+		# First, copy those cards in the global header that 
+		# are not in the current extension header.
+
+		clines = strlen (Memc[FIT_CACHEHDR(fit)])
+		ulines = strlen (Memc[userh])
+		clines = clines / LEN_UACARD
+		ulines = ulines / LEN_UACARD
+		merge = YES
+		call fxf_match_str (FIT_CACHEHDR(fit),
+		    clines, userh, ulines, merge, ua)
+		elen = LEN_UACARD * ulines
+	    }
+
+	    # Append the extension header to the UA.
+	    elines = elen / LEN_UACARD
+	    k = userh
+	    nbl = 0
+
+	    do i = 1, elines {
+		call strcpy (Memc[k], Memc[ln], LEN_UACARD)
+		if (fxf_is_blank (Memc[ln]))
+		    nbl = nbl + 1
+		else {
+		    # If there are blank cards, add them.
+		    if (nbl > 0)
+			call fxf_blank_lines (nbl, ua)
+		    call amovc (Memc[ln], Memc[ua], LEN_UACARD)
+		    ua = ua + LEN_UACARD
+		}
+		k = k + LEN_UACARD
+	    }
+
+	    Memc[ua] = EOS
+	}	
+	call sfree (sp)
+end
+
+
+# FXF_STRCMP_LWR -- Compare 2 strings in lower case mode.
+
+int procedure fxf_strcmp_lwr (s1, s2)
+
+char s1[ARB], s2[ARB]		#I strings to be compare for equality
+
+int	istat
+pointer sp, l1, l2
+int	strcmp()
+
+begin
+	call smark (sp)
+	call salloc (l1, LEN_CARD, TY_CHAR)
+	call salloc (l2, LEN_CARD, TY_CHAR)
+
+	call strcpy (s1, Memc[l1], LEN_CARD)
+	call strcpy (s2, Memc[l2], LEN_CARD)
+	call strlwr(Memc[l1])
+	call strlwr(Memc[l2])
+	istat = strcmp (Memc[l1], Memc[l2])
+
+	call sfree (sp)
+	return (istat)
+end
+
+
+# FXF_DATE2LIMTIME -- Convert the IRAF_TLM string (used to record the IMIO
+# time of last modification of the image) into a long integer limtime
+# compatible with routine cnvtime().  The year must be 1980 or later.
+# The input date string has one of the following forms:
+#
+# Old format:			"hh:mm:ss (dd/mm/yyyy)"
+# New (Y2K/ISO) format:		"YYYY-MM-DDThh:mm:ss
+
+procedure fxf_date2limtime (datestr, limtime)
+
+char	datestr[ARB]	#I fixed format date string
+long	limtime		#O output limtime (LST seconds from 1980.0)
+
+double	dsec
+int	hours,minutes,seconds,day,month,year
+int     status, iso, flags, ip, m, d, y
+int	dtm_decode_hms(), btoi(), ctoi()
+long    gmttolst()
+double  jd
+
+begin
+	iso = btoi (datestr[3] != ':')
+	status = OK
+
+	if (iso == YES) {
+	    status = dtm_decode_hms (datestr,
+		year,month,day, hours,minutes,dsec, flags)
+
+	    # If the decoded date string is old style FITS then the HMS
+	    # values are indefinite, and we need to set them to zero.
+
+	    if (and(flags,TF_OLDFITS) != 0) {
+		hours = 0
+		minutes = 0
+		seconds = 0
+	    } else {
+ 		if (IS_INDEFD(dsec)) {
+                    hours   = 0
+                    minutes = 0
+                    seconds = 0
+		} else
+                    seconds = nint(dsec)
+            }
+	} else {
+	    ip = 1;  ip = ctoi (datestr,     ip, hours)
+	    ip = 1;  ip = ctoi (datestr[4],  ip, minutes)
+	    ip = 1;  ip = ctoi (datestr[7],  ip, seconds)
+	    ip = 1;  ip = ctoi (datestr[11], ip, day)
+	    ip = 1;  ip = ctoi (datestr[14], ip, month)
+	    ip = 1;  ip = ctoi (datestr[17], ip, year)
+	}
+
+	if (status == ERR || year < 1980) {
+	    limtime = 0
+	    return
+	}
+
+	seconds = seconds + minutes * 60 + hours * 3600
+
+        # Calculate the Julian day from jan 1, 1980. Algorithm taken
+	# from astutil/asttools/asttimes.x.
+
+        y = year
+	if (month > 2)
+	    m = month + 1
+	else {
+	    m = month + 13
+	    y = y - 1
+	}
+
+	# Original: jd = int (JYEAR * y) + int (30.6001 * m) + day + 1720995
+        # -723244.5 is the number of days to add to get 'jd' from jan 1, 1980.
+
+	jd = int (365.25 * y) + int (30.6001 * m) + day - 723244.5
+	if (day + 31 * (m + 12 * y) >= 588829) {
+	    d = int (y / 100)
+	    m = int (y / 400)
+	    jd = jd + 2 - d + m
+	}
+	jd = jd - 0.5 
+        day = jd
+
+	limtime = seconds + day * 86400
+	if (iso == YES)
+	    limtime = gmttolst (limtime)
+end
+
+
+# FIT_MATCH_STR -- FITS header pattern matching algorithm.  Match mostly one
+# line of lenght LEN_UACARD with the buffer pointed by str; if pattern is not
+# in str, put it in the 'out' buffer.
+
+procedure fxf_match_str (pat, plines, str, slines, merge, po)
+
+pointer pat		#I buffer with pattern
+int	plines		#I number of pattern
+pointer str		#I string to compare the pattern with
+int	slines		#I number of lines in str
+int	merge		#I flag to indicate merging or unmerge
+pointer po		#I matching pattern accumulation pointer
+
+char	line[LEN_UACARD]
+pointer sp, pt, tpt, tst, ps, pkp
+int	nbl, l, k, j, i, strncmp(), nbkw, nsb, cmplen
+int	stridxs()
+
+begin
+	call smark (sp)
+	call salloc (tpt, LEN_UACARD_100+1, TY_CHAR)
+	call salloc (tst, LEN_UACARD_5+1, TY_CHAR)
+
+	Memc[tpt] = EOS
+	Memc[tst] = EOS
+
+	# The temporary buffer is non blank only when it has a blank
+	# keyword following by a comentary:
+
+	#1) '	       '		   / Comment to the block of keyw
+	#2) KEYWORD = Value
+
+	nbl = 0
+	nbkw = 0
+	pt = pat - LEN_UACARD
+
+	for (k=1;  k <= plines;  k=k+1) {
+	    pt = pt + LEN_UACARD
+	    call strcpy (Memc[pt], line, LEN_UACARD)
+
+	    # Do not pass these keywords if merging.
+	    if (merge == YES) {
+		if (strncmp (line, "COMMENT ", 8) == 0 ||
+		    strncmp (line, "HISTORY ", 8) == 0 ||
+		    strncmp (line, "OBJECT  ", 8) == 0 ||
+		    strncmp (line, "EXTEND  ", 8) == 0 ||
+		    strncmp (line, "ORIGIN  ", 8) == 0 ||
+		    strncmp (line, "IRAF-TLM", 8) == 0 ||
+		    strncmp (line, "DATE    ", 8) == 0 ) {
+
+		    next 
+	        }
+	    }	
+	    if (line[1] == ' ') {
+	        call fxf_accum_bufp (line, tpt, nbkw, nbl)
+	        next
+	    }
+
+	    if (Memc[tpt] != EOS) {  
+		nbkw = nbkw + 1
+	        call strcat (line, Memc[tpt], LEN_UACARD_100)
+	        Memc[tst] = EOS
+
+	        # Now that we have a buffer with upto 100 lines, we take its 
+	        # last 5 card and we are going to compare it with upto 5 
+	        # lines (that can contain blank lines in between).
+
+	        pkp = tpt + LEN_UACARD*(nbkw-1)
+	        ps = str - LEN_UACARD
+	        nsb = 0
+
+		do j = 1, slines {
+		    ps = ps + LEN_UACARD
+		    call strcpy (Memc[ps], line, LEN_UACARD)
+
+		    if (line[1] == ' ') {
+			call fxf_accum_buft (line, tst, nsb)
+			next
+
+		    } else if (Memc[tst] != EOS) {
+			nsb = nsb + 1
+			call strcat (line, Memc[tst], LEN_UACARD_5)
+
+			# To begin compare the first character in the
+			# keyword line.
+
+			if (Memc[pkp] == line[1]) {
+			    if (strncmp (Memc[pkp-LEN_UACARD*(nsb-1)],
+				    Memc[tst], LEN_UACARD*nsb) == 0) {
+				nsb = 0
+				break
+			    }
+			}	  
+
+			nsb = 0
+			Memc[tst] = EOS
+		    }
+		}
+
+	        if (j == slines+1) {
+		    if (nbl > 0)
+		        call fxf_blank_lines (nbl, po)
+		    i = tpt
+		    do l = 1, min(100, nbkw) {
+		        call amovc (Memc[i], Memc[po], LEN_UACARD)
+		        i = i + LEN_UACARD
+		        po = po + LEN_UACARD
+		    }
+	        } else {
+		    pt = pt - LEN_UACARD	# push back last line
+		    k = k - 1
+	        }
+
+	        Memc[tpt] = EOS	
+	        nbkw = 0
+	        nbl = 0	
+
+	    } else {
+		# One line to compare.
+		ps = str - LEN_UACARD
+		cmplen = min (stridxs("=", Memc[pt]), LEN_UACARD)
+		if (cmplen == 0)
+		    cmplen = LEN_UACARD
+
+#	        if (merge == YES)
+#		    cmplen = SZ_KEYWORD
+
+	        do j = 1, slines {
+		    ps = ps + LEN_UACARD
+		    if (Memc[ps] == Memc[pt]) {
+			if (merge == NO)
+			    cmplen = LEN_CARD 
+		        if (strncmp (Memc[ps], Memc[pt], cmplen) == 0) {
+			    nbl = 0
+			    break
+			}
+		    }   
+	        }
+
+	        if (j == slines+1) {
+		    if (nbl > 0)
+		        call fxf_blank_lines (nbl, po)
+
+		    call amovc (line, Memc[po], LEN_UACARD)
+		    po = po + LEN_UACARD
+		    nbl = 0
+	        } 
+	    }
+	}
+
+	call sfree (sp)
+end
+
+
+# FXF_ACCUM_BUFP -- Accumulate blank keyword cards (No keyword and a / card
+# only) and the blank lines in between.
+
+procedure fxf_accum_bufp (line, tpt, nbkw, nbl)
+
+char	line[LEN_UACARD]	#I input card from the pattern buffer
+pointer tpt			#I pointer to the buffer
+int	nbkw			#U number of blank keyword card
+int	nbl			#U number of blank card before the 1st bkw
+
+char	keyw[SZ_KEYWORD]		
+bool	fxf_is_blank()	
+
+begin
+	call strcpy (line, keyw, SZ_KEYWORD)
+
+	if (fxf_is_blank (line)) {
+	    # Accumulate blank cards in between bkw cards.
+	    if (nbkw > 0 && nbkw < 100) {
+		call strcat (line, Memc[tpt], LEN_UACARD_100)
+		nbkw = nbkw + 1
+	    } else if (nbkw >= 100) {
+		nbkw = nbkw - 1
+	    } else
+		nbl = nbl + 1
+
+	} else if (fxf_is_blank (keyw)) {
+	    nbkw = nbkw + 1
+
+	    # We have a blank keyword, but the card is not blank, maybe it is
+	    # a '/ comment' card.  Start accumulating upto 100 blank kwy lines.
+
+	    if (nbkw < 100)
+		call strcat (line, Memc[tpt], LEN_UACARD_100)
+	    else
+		nbkw = nbkw - 1
+	}
+end
+
+
+# FXF_ACCUM_BUFT -- Accumulate blank keyword keeping track of the blank cards.
+
+procedure fxf_accum_buft (line, tst, nsb)
+
+char	line[LEN_UACARD]	#I input card from the target buffer
+pointer tst			#I pointer to output buffer
+int	nsb			#U number of consecutives blank cards
+
+char	keyw[SZ_KEYWORD]
+bool	fxf_is_blank()	
+
+begin
+	call strcpy (line, keyw, SZ_KEYWORD)
+
+	if (fxf_is_blank (line)) {
+	    if (nsb > 0 && nsb < 5) {
+		call strcat (line, Memc[tst], LEN_UACARD_5)
+		nsb = nsb + 1
+	    } else if (nsb > 4)
+		nsb = nsb - 1 
+	} else if (fxf_is_blank (keyw)) {
+	    # We want to pick the last blank kwy only.
+	    call strcpy (line, Memc[tst], LEN_UACARD_5)
+	    nsb = 1
+	}
+end
+
+
+# FXF_BLANK_LINES -- Write a number of blank lines into output buffer.
+
+procedure fxf_blank_lines (nbl, po)
+
+int	nbl			#U number of blank lines to write
+pointer po			#I output buffer pointer
+
+char	blk[1]
+int	i
+
+begin
+	blk[1] = ' '
+	do i = 1, nbl {
+	    call amovkc (blk[1], Memc[po], LEN_UACARD)
+	    po = po +  LEN_UACARD
+	    Memc[po-1] = '\n'
+	}
+	nbl = 0
+end
+
+
+# FXF_IS_BLANK -- Determine is the string is blank.
+
+bool procedure fxf_is_blank (line)
+
+char line[ARB]			#I input string
+int  i
+
+begin
+	for (i=1; IS_WHITE(line[i]); i=i+1)
+	   ;
+
+	if (line[i] == NULL || line[i] == '\n')
+	    return (true)
+	else
+	    return (false)
+end
+
+
+# FXF_FORM_MESSG -- Form string from extname, extver.
+
+procedure fxf_form_messg (fit, messg)
+
+pointer fit			#I fits descriptor
+char	messg[ARB]		#O string
+
+begin
+	if (!IS_INDEFL (FKS_EXTVER(fit))) {
+	    call sprintf (messg, LEN_CARD, "'%s,%d'")
+		call pargstr (FKS_EXTNAME(fit))
+		call pargi (FKS_EXTVER(fit)) 
+	} else {
+	    call sprintf (messg, LEN_CARD, "'%s'")
+		call pargstr (FKS_EXTNAME(fit))
+	}			
+end