Repatch (from linux) of OSX IRAF

36 files changed, 1695 insertions, 0 deletions

diff --git a/sys/imfort/db/README b/sys/imfort/db/README
new file mode 100644
index 00000000..1503a949
--- /dev/null
+++ b/sys/imfort/db/README
@@ -0,0 +1,120 @@
+IMFORT/DB -- Image header keyword access for IMFORT (20Apr86)
+
+    This directory contains a version of the imio/db package, modified for
+IMFORT.  The modifications consisted of [1] elimination of calls to the
+various printf routines, so that only pure code (no external dependencies
+or use of VOS i/o) is linked into the Fortran program, [2] deleted imgnfn
+template stuff, [3] added provision for comments when adding new keywords,
+[4] changed datatype code to integer uniformly.  Error checking is still
+used but should be iferr-ed and turned into an IER code in the Fortran
+binding.
+
+
+Old IDBI readme docs:
+----------------------------------------
+
+			Image Header Database Interface
+				dct 16-Apr-85
+
+1. Overview
+
+    This directory contains the first version of the image header database
+interface.  In this implementation the image header is a variable length fixed
+format binary structure.  The first, fixed format, part of the image header
+contains the standard fields in binary and is fixed in size.  This is followed
+by the so called "user area", a string buffer containing a sequence of
+variable length, newline delimited FITS format keyword=value header cards.
+When an image is open a large user area is allocated to permit the addition
+of new parameters without filling up the buffer.  When the header is
+subsequently updated on disk only as much disk space is used as is needed to
+store the actual header.
+
+This format header is upwards compatible with the old image header format,
+hence old images and programs do not have to be modified to use the IMIO
+release supporting database accesss.  In the future image headers will be
+maintained under DBIO, but the routines in the image header database interface
+are not exected to change.  The actual disk format of images will of course
+change when we switch over to the  DBIO headers.
+
+
+
+2. Functions
+
+	get,g - get the value of a field
+	put,p - set the value of a field
+	add,a - add a new field to a database
+	  acc - determine if the named field exists
+
+
+3. Procedures
+
+       value = imget[bcsilrdx] (im, "field")
+		        imgstr (im, "field", outstr, maxch)
+	       imput[bcsilrdx] (im, "field", value)
+		        impstr (im, "field", value)
+       	       imadd[bcsilrdx] (im, "field", def_value)
+		        imastr (im, "field", def_value)
+		        imaddf (im, "field", "datatype")
+	          y/n = imaccf (im, "field")
+
+             list = imofnl[su] (im, template)
+                  nch = imgnfn (im, outstr, maxch)
+                        imcfnl (im)
+
+
+
+4. Description
+
+    New parameters will typically be added to the image header with either
+one of the typed procedures IMADD_ or with the lower level procedure IMADDF.
+The former procedures permit the parameter to be created and the value
+initialized all in one call, while the latter only creates the parameter.
+In addition, the typed IMADD_ procedures may be used to update the values
+of existing parameters (it is not considered an error if the parameter
+already exists).  The principal limitation of the typed procedures is that
+they may only be used to add or set parameters of a standard datatype.
+The IMADDF procedure will permit creation of parameters with more descriptive
+datatypes (domains) when the interface is recut upon DBIO.
+
+The value of any parameter may be fetched with one of the IMGET functions.
+The IMACCF function may be used (like ACCESS for a file) to determine
+whether a parameter exists.
+
+The database interface may be used to access any field of the image header,
+including the following standard fields.  Note that the nomenclature has
+been changed slightly to make it more consistent with FITS.  Additional
+standard fields will be defined in the future.
+
+
+	  keyword     type                 description
+
+	i_naxis		i	number of axes (dimensionality)
+	i_naxis[1-7]	l	length of an axis ("i_naxis1", etc.)
+	i_pixtype	i	pixel datatype (SPP integer code)
+	i_minpixval	r	minimum pixel value
+	i_maxpixval	r	maximum pixel value
+	i_ctime		l	time of image creation
+	i_mtime		l	time of last modify
+	i_limtime	l	time when limits (minmax) were last updated
+	i_title		s	title string
+
+
+The names of the standard fields share an "i_" prefix to reduce the possibility
+of collisions with data dependent keywords, to identify the standard fields in
+sorted listings, to allow use of pattern matching to discriminate between the
+standard fields and user fields, and so on.  For the convenience of the user,
+the "i_" prefix may be omitted provided the resultant name does not match the
+name of a user parameter.  It is however recommended that the full name be
+used in all applications software.
+
+
+5. Restrictions
+
+    The use of FITS format as the internal format for storing fields in this
+version of the interface places restrictions on the size of field names and
+of the string value of string valued parameters.  Field names are currently
+limited to eight characters or less and case is ignored (since FITS requires
+upper case).  The eight character limit does not apply to the standard fields.
+String values are limited to at most 68 characters.  If put string is passed
+a longer string it will be silently truncated.  Trailing whitespace and
+newlines are chopped when a string value is read.
diff --git a/sys/imfort/db/idb.h b/sys/imfort/db/idb.h
new file mode 100644
index 00000000..a430f01f
--- /dev/null
+++ b/sys/imfort/db/idb.h
@@ -0,0 +1,22 @@
+# IDB.H -- Image header database interface.  In this version of the interface
+# the standard image header fields are maintained in binary in a fixed
+# structure and the user fields are maintained in FITS format (text) in the
+# a string buffer following the binary image header.
+
+define	IDB_RECLEN		80		# length of a FITS record (card)
+define	IDB_STARTVALUE		10		# first column of value field
+define	IDB_ENDVALUE		30		# last  column of value field
+define	IDB_LENNUMERICRECORD	80		# length of new numeric records
+define	IDB_LENSTRINGRECORD	80		# length of new string records
+
+# Standard header keywords accessible via the database interface.
+
+define	I_CTIME			1
+define	I_MTIME			2
+define	I_LIMTIME		3
+define	I_MINPIXVAL		4
+define	I_MAXPIXVAL		5
+define	I_NAXIS			6
+define	I_PIXFILE		7
+define	I_PIXTYPE		8
+define	I_TITLE			9
diff --git a/sys/imfort/db/idbfind.x b/sys/imfort/db/idbfind.x
new file mode 100644
index 00000000..cc9000ec
--- /dev/null
+++ b/sys/imfort/db/idbfind.x
@@ -0,0 +1,124 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<imhdr.h>
+include	"../imfort.h"
+include	"idb.h"
+
+# IDB_FINDRECORD -- Search the image database for a particular record given
+# the key.  The record number (a positive nonzero integer) is returned if
+# the record is found, else 0.  
+
+int procedure idb_findrecord (im, key, rp)
+
+pointer	im			# image descriptor
+char	key[ARB]		# record key
+pointer	rp			# char record pointer (output)
+
+pointer	sp, pat, patbuf, ukey, lkey, ip, ua
+int	recno, nchars, lch, uch, ch, junk, i
+int	patmake(), patmatch(), gstrcpy()
+
+begin
+	call smark (sp)
+	call salloc (pat, SZ_FNAME, TY_CHAR)
+	call salloc (ukey, SZ_FNAME, TY_CHAR)
+	call salloc (lkey, SZ_FNAME, TY_CHAR)
+	call salloc (patbuf, SZ_LINE, TY_CHAR)
+
+	# Search for the FIRST occurrence of a record with the given key.
+	# If the key is abbreviated and multiple keys are matched, the first
+	# record matched is used.
+
+	ua = IM_USERAREA(im)
+	rp = NULL
+	recno = 1
+
+	if (IM_UABLOCKED(im) < 0) {
+	    # At image open time this flag is set by IMMAP to -1 to indicate
+	    # that the user area record type is not known.  An IKI kernel may
+	    # subsequently set the flag to yes/no, else we determine the
+	    # record type by inspection the first time we are called.  If the
+	    # user area is empty the record type is set to blocked; IDB always
+	    # writes blocked records.
+
+	    IM_UABLOCKED(im) = YES
+	    for (ip=ua;  Memc[ip] != EOS;  ip=ip+1) {
+		for (nchars=0;  Memc[ip] != EOS;  nchars=nchars+1) {
+		    if (Memc[ip] == '\n')
+			break
+		    ip = ip + 1
+		}
+		if (nchars != IDB_RECLEN) {
+		    IM_UABLOCKED(im) = NO
+		    break
+		}
+	    }
+	}
+
+	if (IM_UABLOCKED(im) == NO) {
+	    # Variable length, newline terminated records, EOS terminated
+	    # record group.
+
+	    call strcpy ("^{", Memc[pat], SZ_FNAME)
+	    call strcat (key,  Memc[pat], SZ_FNAME)
+	    call strcat ("}[ =]",  Memc[pat], SZ_FNAME)
+	    junk = patmake (Memc[pat], Memc[patbuf], SZ_LINE)
+
+	    for (ip=ua;  Memc[ip] != EOS;  ip=ip+1) {
+		if (patmatch (Memc[ip], Memc[patbuf]) > 0) {
+		    rp = ip
+		    break
+		}
+		while (Memc[ip] != '\n' && Memc[ip] != EOS)
+		    ip = ip + 1
+		recno = recno + 1
+	    }
+
+	} else {
+	    # Fixed length (80 character), newline terminated records, EOS
+	    # terminated record group.  Simple fast search, fixed length
+	    # records.  Case insensitive keyword match.
+
+	    nchars = gstrcpy (key, Memc[lkey], SZ_FNAME)
+	    call strlwr (Memc[lkey])
+	    lch = Memc[lkey]
+
+	    nchars = gstrcpy (key, Memc[ukey], SZ_FNAME)
+	    call strupr (Memc[ukey])
+	    uch = Memc[ukey]
+
+	    for (ip=ua;  Memc[ip] != EOS;  ip=ip+IDB_RECLEN+1) {
+		ch = Memc[ip]
+		if (ch == EOS)
+		    break
+		else if (ch != lch && ch != uch)
+		    next
+		else {
+		    ch = Memc[ip+nchars]
+		    if (ch != ' ' && ch != '=')
+			next
+		}
+
+		# First char matches; check rest of string.
+		do i = 1, nchars-1 {
+		    ch = Memc[ip+i]
+		    if (ch != Memc[lkey+i] && ch != Memc[ukey+i]) {
+			ch = 0
+			break
+		    }
+		}
+		if (ch != 0) {
+		    rp = ip		# match
+		    break
+		}
+
+		recno = recno + 1
+	    }
+	}
+
+	call sfree (sp)
+	if (rp == NULL)
+	    return (0)
+	else
+	    return (recno)
+end
diff --git a/sys/imfort/db/idbgstr.x b/sys/imfort/db/idbgstr.x
new file mode 100644
index 00000000..0b997884
--- /dev/null
+++ b/sys/imfort/db/idbgstr.x
@@ -0,0 +1,78 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+include	<imhdr.h>
+include	"idb.h"
+
+define	TY_STRING	(-1)
+
+# IDB_GETSTRING -- Get the string value of a standard header parameter.  If the
+# actual type of the parameter is not string the value is encoded as a string.
+# The length of the string is returned as the function value.  ERR is returned
+# if the string cannot be found.
+
+int procedure idb_getstring (im, key, outstr, maxch)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be returned
+char	outstr[ARB]		# output string to receive parameter value
+int	maxch
+
+long	lval
+double	dval
+int	dtype, axis
+int	gstrcpy(), idb_kwlookup(), idb_naxis(), ltoc(), dtoc()
+define	encode_ 91
+
+begin
+	# The keywords "naxis1", "naxis2", etc. are treated as a special case.
+	if (idb_naxis (key, axis) == YES)
+	    if (axis > 0) {
+		dtype = TY_LONG
+		lval  = IM_LEN(im,axis)
+		goto encode_
+	    }
+	    
+	switch (idb_kwlookup (key)) {
+	case I_CTIME:
+	    dtype = TY_LONG
+	    lval = IM_CTIME(im)
+	case I_LIMTIME:
+	    dtype = TY_LONG
+	    lval = IM_LIMTIME(im)
+	case I_MAXPIXVAL:
+	    dtype = TY_REAL
+	    if (IS_INDEFR (IM_MAX(im)))
+		dval = INDEFD
+	    else
+		dval = IM_MAX(im)
+	case I_MINPIXVAL:
+	    dtype = TY_REAL
+	    if (IS_INDEFR (IM_MIN(im)))
+		dval = INDEFD
+	    else
+		dval = IM_MIN(im)
+	case I_MTIME:
+	    dtype = TY_LONG
+	    lval = IM_MTIME(im)
+	case I_NAXIS:
+	    dtype = TY_LONG
+	    lval = IM_NDIM(im)
+	case I_PIXFILE:
+	    return (gstrcpy (IM_PIXFILE(im), outstr, maxch))
+	case I_PIXTYPE:
+	    dtype = TY_LONG
+	    lval = IM_PIXTYPE(im)
+	case I_TITLE:
+	    return (gstrcpy (IM_TITLE(im), outstr, maxch))
+	default:
+	    outstr[1] = EOS
+	    return (ERR)
+	}
+
+encode_
+	if (dtype == TY_LONG)
+	    return (ltoc (lval, outstr, maxch))
+	else
+	    return (dtoc (dval, outstr, maxch, 15, 'g', maxch))
+end
diff --git a/sys/imfort/db/idbkwlu.x b/sys/imfort/db/idbkwlu.x
new file mode 100644
index 00000000..4f56e033
--- /dev/null
+++ b/sys/imfort/db/idbkwlu.x
@@ -0,0 +1,52 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+include	<imhdr.h>
+include	"idb.h"
+
+# IDB_KWLOOKUP -- Look up a keyword in the dictionary of standard header
+# keywords, returning the magic integer code of the keyword or zero.
+
+int procedure idb_kwlookup (key)
+
+char	key[ARB]		# keyword to be looked up
+int	index, ip, ch
+pointer	sp, kwname
+int	strdic(), strncmp(), strlen()
+string	keywords "|ctime|mtime|limtime|datamin|datamax|naxis\
+|pixfile|pixtype|title|"
+
+begin
+	call smark (sp)
+	call salloc (kwname, SZ_FNAME, TY_CHAR)
+
+	# Look the string up in the dictionary of standard keywords.  Note that
+	# the "i_" prefix is omitted in the dictionary.  Minimum match abbrev.
+	# are permitted.  The order of the keywords in the dictionary must
+	# agree with the defined codes in the header file.  A standard keyword
+	# is recognized with or without the "i_" prefix.
+
+	if (key[1] == 'i' && key[2] == '_')
+	    ip = 3
+	else
+	    ip = 1
+
+	# Check for a reference to one of the NAXIS keywords.
+	if (key[ip] == 'n')
+	    if (strncmp (key[ip], "naxis", 5) == 0) {
+		ch = key[ip+5]
+		if (ch == EOS || IS_DIGIT(ch)) {
+		    call sfree (sp)
+		    return (I_NAXIS)
+		}
+	    }
+
+	# Look up keyword in dictionary.  Abbreviations are not permitted.
+	index = strdic (key[ip], Memc[kwname], SZ_FNAME, keywords)
+	if (index != 0)
+	    if (strlen(key[ip]) != strlen(Memc[kwname]))
+		index = 0
+
+	call sfree (sp)
+	return (index)
+end
diff --git a/sys/imfort/db/idbnaxis.x b/sys/imfort/db/idbnaxis.x
new file mode 100644
index 00000000..3b898403
--- /dev/null
+++ b/sys/imfort/db/idbnaxis.x
@@ -0,0 +1,32 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<ctype.h>
+
+# IDB_NAXIS -- Determine if the named keyword is one of the NAXIS* keywords,
+# and if so return the value of the numeric suffix.
+
+int procedure idb_naxis (keyw, axnum)
+
+char	keyw[ARB]		# keyword name
+int	axnum			# receives numeric axis code (0=no suffix)
+
+int	ch, ip
+int	strncmp(), ctoi()
+
+begin
+	if (strncmp (keyw, "i_naxis", 7) == 0)
+	    ip = 8
+	else if (strncmp (keyw, "naxis", 5) == 0)
+	    ip = 6
+	else
+	    return (NO)
+
+	ch = keyw[ip]
+	if (!IS_DIGIT(ch) && ch != ' ' && ch != EOS)
+	    return (NO)
+
+	if (ctoi (keyw, ip, axnum) <= 0)
+	    axnum = 0
+
+	return (YES)
+end
diff --git a/sys/imfort/db/idbpstr.x b/sys/imfort/db/idbpstr.x
new file mode 100644
index 00000000..35835730
--- /dev/null
+++ b/sys/imfort/db/idbpstr.x
@@ -0,0 +1,96 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<syserr.h>
+include	<ctype.h>
+include	<imhdr.h>
+include	<mach.h>
+include	"idb.h"
+
+# IDB_PUTSTRING -- Set the value of a standard header parameter given the new
+# value of the parameter encoded as a string.  If actual type of the parameter
+# is non string the value must be decoded.  ERR is returned if the key is not
+# a standard header parameter or if the key is known but the value cannot be
+# decoded.
+
+int procedure idb_putstring (im, key, strval)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be returned
+char	strval[ARB]		# string value of parameter
+
+long	lval
+double	dval
+bool	numeric
+int	ip, axis
+int	idb_kwlookup(), idb_naxis(), ctod()
+long	clktime()
+
+begin
+	ip = 1
+	numeric = (ctod (strval, ip, dval) > 0)
+	if (numeric) {
+	    if (IS_INDEFD (dval))
+		lval = INDEFL
+	    else if (real(MAX_LONG) < abs(dval))
+		lval = INDEFL
+	    else
+		lval = nint (dval)
+	}
+
+	# The keywords "naxis1", "naxis2", etc. are treated as a special case.
+	if (idb_naxis (key, axis) == YES)
+	    if (axis > 0) {
+		if (numeric)
+		    IM_LEN(im,axis) = lval
+		else
+		    return (ERR)
+	    }
+	    
+	# Lookup the keyword in the dictionary and set the value of the
+	# header parameter.  If the parameter is string valued copy the
+	# string value and return immediately.
+
+	switch (idb_kwlookup (key)) {
+	case I_CTIME:
+	    if (numeric)
+		IM_CTIME(im) = lval
+	case I_LIMTIME:
+	    if (numeric)
+		IM_LIMTIME(im) = lval
+	case I_MAXPIXVAL:
+	    if (numeric) {
+		IM_MAX(im) = dval
+		IM_LIMTIME(im) = clktime (long(0))
+	    }
+	case I_MINPIXVAL:
+	    if (numeric) {
+		IM_MIN(im) = dval
+		IM_LIMTIME(im) = clktime (long(0))
+	    }
+	case I_MTIME:
+	    if (numeric)
+		IM_MTIME(im) = lval
+	case I_NAXIS:
+	    if (numeric)
+		IM_NDIM(im) = lval
+	case I_PIXFILE:
+	    call strcpy (strval, IM_PIXFILE(im), SZ_IMPIXFILE)
+	    return (OK)
+	case I_PIXTYPE:
+	    if (numeric)
+		IM_PIXTYPE(im) = lval
+	case I_TITLE:
+	    call strcpy (strval, IM_TITLE(im), SZ_IMTITLE)
+	    return (OK)
+	default:
+	    return (ERR)
+	}
+
+	# We make it here only if the actual keyword is numeric, so return
+	# ERR if the keyword value was nonnumeric.
+
+	if (numeric)
+	    return (OK)
+	else
+	    return (ERR)
+end
diff --git a/sys/imfort/db/imaccf.x b/sys/imfort/db/imaccf.x
new file mode 100644
index 00000000..60e4e9f3
--- /dev/null
+++ b/sys/imfort/db/imaccf.x
@@ -0,0 +1,18 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMACCF -- Test if the named field exists.  NO is returned if the key is not
+# found, YES otherwise.
+
+int procedure imaccf (im, key)
+
+pointer	im			# image descriptor
+char	key[ARB]		# name of the new parameter
+int	idb_kwlookup(), idb_findrecord()
+pointer	rp
+
+begin
+	if ((idb_kwlookup (key) > 0) || (idb_findrecord (im, key, rp) > 0))
+	    return (YES)
+	else
+	    return (NO)
+end
diff --git a/sys/imfort/db/imaddb.x b/sys/imfort/db/imaddb.x
new file mode 100644
index 00000000..a3161377
--- /dev/null
+++ b/sys/imfort/db/imaddb.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMADDB -- Add a new field to the image header and initialize to the value
+# given.  It is not an error if the parameter already exists.
+
+procedure imaddb (im, key, value, comment)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter or field value
+bool	value			# new or initial value of parameter
+char	comment[ARB]		# comment describing new parameter
+
+int	imaccf()
+errchk	imaccf, imaddf
+
+begin
+	if (imaccf (im, key) == NO)
+	    call imaddf (im, key, TY_BOOL, comment)
+	call imputb (im, key, value)
+end
diff --git a/sys/imfort/db/imaddd.x b/sys/imfort/db/imaddd.x
new file mode 100644
index 00000000..55a6f591
--- /dev/null
+++ b/sys/imfort/db/imaddd.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMADDD -- Add a new field to the image header and initialize to the value
+# given.  It is not an error if the parameter already exists.
+
+procedure imaddd (im, key, value, comment)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter or field value
+double	value			# new or initial value of parameter
+char	comment[ARB]		# comment describing new parameter
+
+int	imaccf()
+errchk	imaccf, imaddf
+
+begin
+	if (imaccf (im, key) == NO)
+	    call imaddf (im, key, TY_DOUBLE, comment)
+	call imputd (im, key, value)
+end
diff --git a/sys/imfort/db/imaddf.x b/sys/imfort/db/imaddf.x
new file mode 100644
index 00000000..e6bda15e
--- /dev/null
+++ b/sys/imfort/db/imaddf.x
@@ -0,0 +1,76 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<syserr.h>
+include	<imhdr.h>
+include	"../imfort.h"
+include	"idb.h"
+
+# IMADDF -- Add a user field to the image header.  It is an error if the named
+# field already exists.
+
+procedure imaddf (im, key, datatype, comment)
+
+pointer	im			# image descriptor
+char	key[ARB]		# name of the new parameter
+int	datatype		# datatype of parameter
+char	comment[ARB]		# comment describing new parameter
+
+int	max_lenuserarea
+pointer	sp, keyname, rp, ua, op
+int	idb_kwlookup(), idb_findrecord(), strlen()
+errchk	syserrs
+
+begin
+	call smark (sp)
+	call salloc (keyname, SZ_FNAME, TY_CHAR)
+
+	# FITS format requires that the keyword name be upper case.
+	call strcpy (key, Memc[keyname], SZ_FNAME)
+	call strupr (Memc[keyname])
+
+	# Check for a redefinition.
+	if ((idb_kwlookup (key) > 0) || (idb_findrecord (im, key, rp) > 0))
+	    call syserrs (SYS_IDBREDEF, key)
+	
+	# Open the user area string for appending.  If the user area is not
+	# empty the last character must be the newline record delimiter,
+	# else the new record we add will be invalid.
+
+	max_lenuserarea = (LEN_IMDES + IM_LENHDRMEM(im) - IMU + 1) * SZ_STRUCT
+	ua = IM_USERAREA(im)
+
+	for (rp=ua;  Memc[rp] != EOS;  rp=rp+1)
+	    ;
+	if (rp - ua + IDB_RECLEN + 1 >= max_lenuserarea)
+	    call syserrs (SYS_IDBOVFL, key)
+
+	if (rp > ua && Memc[rp-1] != '\n') {
+	    Memc[rp] = '\n'
+	    rp = rp + 1
+	}
+
+	# Append the new record with an uninitialized value field.  Keyword
+	# value pairs are encoded in FITS format.
+
+	do op = rp, rp + IDB_RECLEN		# blank fill card
+	    Memc[op] = ' '
+
+	# Add the "= 'value' / comment".
+	call amovc (Memc[keyname], Memc[rp], strlen(Memc[keyname]))
+	Memc[rp+9-1] = '='
+	if (datatype == TY_CHAR) {
+	    Memc[rp+11-1] = '\''
+	    Memc[rp+20-1] = '\''
+	}
+
+	# Add the comment field.
+	Memc[rp+32-1] = '/'
+	call amovc (comment, Memc[rp+34-1],
+	    min (IDB_RECLEN-34+1, strlen(comment)))
+
+	# Terminate the card.
+	Memc[rp+IDB_RECLEN] = '\n'
+	Memc[rp+IDB_RECLEN+1] = EOS
+
+	call sfree (sp)
+end
diff --git a/sys/imfort/db/imaddi.x b/sys/imfort/db/imaddi.x
new file mode 100644
index 00000000..527baaf0
--- /dev/null
+++ b/sys/imfort/db/imaddi.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMADDI -- Add a new field to the image header and initialize to the value
+# given.  It is not an error if the parameter already exists.
+
+procedure imaddi (im, key, value, comment)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter or field value
+int	value			# new or initial value of parameter
+char	comment[ARB]		# comment describing new parameter
+
+int	imaccf()
+errchk	imaccf, imaddf
+
+begin
+	if (imaccf (im, key) == NO)
+	    call imaddf (im, key, TY_INT, comment)
+	call imputi (im, key, value)
+end
diff --git a/sys/imfort/db/imaddl.x b/sys/imfort/db/imaddl.x
new file mode 100644
index 00000000..a707eab3
--- /dev/null
+++ b/sys/imfort/db/imaddl.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMADDL -- Add a new field to the image header and initialize to the value
+# given.  It is not an error if the parameter already exists.
+
+procedure imaddl (im, key, value, comment)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter or field value
+long	value			# new or initial value of parameter
+char	comment[ARB]		# comment describing new parameter
+
+int	imaccf()
+errchk	imaccf, imaddf
+
+begin
+	if (imaccf (im, key) == NO)
+	    call imaddf (im, key, TY_LONG, comment)
+	call imputl (im, key, value)
+end
diff --git a/sys/imfort/db/imaddr.x b/sys/imfort/db/imaddr.x
new file mode 100644
index 00000000..ad4eee81
--- /dev/null
+++ b/sys/imfort/db/imaddr.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMADDR -- Add a new field to the image header and initialize to the value
+# given.  It is not an error if the parameter already exists.
+
+procedure imaddr (im, key, value, comment)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter or field value
+real	value			# new or initial value of parameter
+char	comment[ARB]		# comment describing new parameter
+
+int	imaccf()
+errchk	imaccf, imaddf
+
+begin
+	if (imaccf (im, key) == NO)
+	    call imaddf (im, key, TY_REAL, comment)
+	call imputr (im, key, value)
+end
diff --git a/sys/imfort/db/imadds.x b/sys/imfort/db/imadds.x
new file mode 100644
index 00000000..b4a01595
--- /dev/null
+++ b/sys/imfort/db/imadds.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMADDS -- Add a new field to the image header and initialize to the value
+# given.  It is not an error if the parameter already exists.
+
+procedure imadds (im, key, value, comment)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter or field value
+short	value			# new or initial value of parameter
+char	comment[ARB]		# comment describing new parameter
+
+int	imaccf()
+errchk	imaccf, imaddf
+
+begin
+	if (imaccf (im, key) == NO)
+	    call imaddf (im, key, TY_SHORT, comment)
+	call imputs (im, key, value)
+end
diff --git a/sys/imfort/db/imastr.x b/sys/imfort/db/imastr.x
new file mode 100644
index 00000000..03736f38
--- /dev/null
+++ b/sys/imfort/db/imastr.x
@@ -0,0 +1,18 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMASTR -- Add a new field to the image header and initialize to the value
+# given.  It is not an error if the parameter already exists.
+
+procedure imastr (im, key, value, comment)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter or field value
+char	value[ARB]		# new or initial value of parameter
+char	comment[ARB]		# comment string
+int	imaccf()
+
+begin
+	if (imaccf (im, key) == NO)
+	    call imaddf (im, key, TY_CHAR, comment)
+	call impstr (im, key, value)
+end
diff --git a/sys/imfort/db/imdelf.x b/sys/imfort/db/imdelf.x
new file mode 100644
index 00000000..78be8a88
--- /dev/null
+++ b/sys/imfort/db/imdelf.x
@@ -0,0 +1,44 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<syserr.h>
+include	<imhdr.h>
+include	"idb.h"
+
+# IMDELF -- Delete a user field from the image header.  It is an error if the
+# named field does not exist.
+
+procedure imdelf (im, key)
+
+pointer	im			# image descriptor
+char	key[ARB]		# name of the new parameter
+
+int	off
+pointer	rp, sp, keyname
+int	idb_kwlookup(), idb_findrecord(), stridxs()
+errchk	syserrs
+
+begin
+	call smark (sp)
+	call salloc (keyname, SZ_FNAME, TY_CHAR)
+
+	# FITS format requires that the keyword name be upper case.
+	call strcpy (key, Memc[keyname], SZ_FNAME)
+	call strupr (Memc[keyname])
+
+	# Cannot delete standard header keywords.
+	if (idb_kwlookup (key) > 0)
+	    call syserrs (SYS_IDBNODEL, key)
+
+	# Verify that the named user field exists.
+	if (idb_findrecord (im, key, rp) <= 0)
+	    call syserrs (SYS_IDBDELNXKW, key)
+	
+	# Delete the field.
+	off = stridxs ("\n", Memc[rp])
+	if (off > 0)
+	    call strcpy (Memc[rp+off], Memc[rp], ARB)
+	else
+	    Memc[rp] = EOS
+
+	call sfree (sp)
+end
diff --git a/sys/imfort/db/imgatr.x b/sys/imfort/db/imgatr.x
new file mode 100644
index 00000000..5d600cfa
--- /dev/null
+++ b/sys/imfort/db/imgatr.x
@@ -0,0 +1,51 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<syserr.h>
+include	<ctype.h>
+include	"idb.h"
+
+# IMGATR -- Get the attribute fields (type code and comment) of a header
+# keyword.  A separate, normally typed, call is required to get the keyword
+# value.
+
+procedure imgatr (im, key, dtype, comm, maxch)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be returned
+int	dtype			# receives datatype code
+char	comm[ARB]		# output string to comment field
+int	maxch
+
+int	op
+pointer	rp, ip
+int	idb_getstring(), idb_findrecord(), imgftype()
+errchk	syserrs, imgftype
+
+begin
+	# Get the field datatype.
+	dtype = imgftype (im, key)
+
+	# Check for a standard header parameter first.
+	if (idb_getstring (im, key, comm, maxch) != ERR) {
+	    comm[1] = EOS
+	    return
+	}
+
+	# Find the record.
+	if (idb_findrecord (im, key, rp) == 0)
+	    call syserrs (SYS_IDBKEYNF, key)
+
+	# Extract the comment field.
+	for (ip=rp+IDB_ENDVALUE;  Memc[ip] != '/' && Memc[ip] != '\n';  ip=ip+1)
+	    ;
+	if (Memc[ip] == '/') {
+	    for (ip=ip+1;  IS_WHITE(Memc[ip]);  ip=ip+1)
+		;
+	    for (op=1;  Memc[ip] != '\n';  ip=ip+1) {
+		comm[op] = Memc[ip]
+		op = op + 1
+	    }
+	    comm[op] = EOS
+	} else
+	    comm[1] = EOS
+end
diff --git a/sys/imfort/db/imgetb.x b/sys/imfort/db/imgetb.x
new file mode 100644
index 00000000..aba16f97
--- /dev/null
+++ b/sys/imfort/db/imgetb.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	"idb.h"
+
+# IMGETB -- Get an image header parameter of type boolean.  False is returned
+# if the parameter cannot be found or if the value is not true.
+
+bool procedure imgetb (im, key)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be returned
+pointer	rp
+pointer	idb_findrecord()
+
+begin
+	if (idb_findrecord (im, key, rp) == 0)
+	    return (false)
+	else
+	    return (Memc[rp+IDB_ENDVALUE-1] == 'T')
+end
diff --git a/sys/imfort/db/imgetc.x b/sys/imfort/db/imgetc.x
new file mode 100644
index 00000000..f56ecb9d
--- /dev/null
+++ b/sys/imfort/db/imgetc.x
@@ -0,0 +1,13 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMGETC -- Get an image header parameter of type char.
+
+char procedure imgetc (im, key)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be returned
+long	imgetl()
+
+begin
+	return (imgetl (im, key))
+end
diff --git a/sys/imfort/db/imgetd.x b/sys/imfort/db/imgetd.x
new file mode 100644
index 00000000..01a71cb1
--- /dev/null
+++ b/sys/imfort/db/imgetd.x
@@ -0,0 +1,32 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<syserr.h>
+include	"idb.h"
+
+# IMGETD -- Get an image header parameter of type double floating.  If the
+# named parameter is a standard parameter return the value directly,
+# else scan the user area for the named parameter and decode the value.
+
+double procedure imgetd (im, key)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be returned
+
+int	ip
+double	dval
+pointer	sp, sval
+int	ctod()
+errchk	syserrs, imgstr
+
+begin
+	call smark (sp)
+	call salloc (sval, SZ_LINE, TY_CHAR)
+
+	ip = 1
+	call imgstr (im, key, Memc[sval], SZ_LINE)
+	if (ctod (Memc[sval], ip, dval) == 0)
+	    call syserrs (SYS_IDBTYPE, key)
+
+	call sfree (sp)
+	return (dval)
+end
diff --git a/sys/imfort/db/imgeti.x b/sys/imfort/db/imgeti.x
new file mode 100644
index 00000000..8da2878e
--- /dev/null
+++ b/sys/imfort/db/imgeti.x
@@ -0,0 +1,19 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMGETI -- Get an image header parameter of type integer.
+
+int procedure imgeti (im, key)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be returned
+
+long	lval, imgetl()
+errchk	imgetl
+
+begin
+	lval = imgetl (im, key)
+	if (IS_INDEFL(lval))
+	    return (INDEFI)
+	else
+	    return (lval)
+end
diff --git a/sys/imfort/db/imgetl.x b/sys/imfort/db/imgetl.x
new file mode 100644
index 00000000..817715c0
--- /dev/null
+++ b/sys/imfort/db/imgetl.x
@@ -0,0 +1,19 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMGETL -- Get an image header parameter of type long integer.
+
+long procedure imgetl (im, key)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be returned
+
+double	dval, imgetd()
+errchk	imgetd
+
+begin
+	dval = imgetd (im, key)
+	if (IS_INDEFD(dval))
+	    return (INDEFL)
+	else
+	    return (nint (dval))
+end
diff --git a/sys/imfort/db/imgetr.x b/sys/imfort/db/imgetr.x
new file mode 100644
index 00000000..b1c6c67a
--- /dev/null
+++ b/sys/imfort/db/imgetr.x
@@ -0,0 +1,19 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMGETR -- Get an image header parameter of type real.
+
+real procedure imgetr (im, key)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be returned
+
+double	dval, imgetd()
+errchk	imgetd
+
+begin
+	dval = imgetd (im, key)
+	if (IS_INDEFD(dval))
+	    return (INDEFR)
+	else
+	    return (dval)
+end
diff --git a/sys/imfort/db/imgets.x b/sys/imfort/db/imgets.x
new file mode 100644
index 00000000..39f2fcfd
--- /dev/null
+++ b/sys/imfort/db/imgets.x
@@ -0,0 +1,19 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMGETS -- Get an image header parameter of type short integer.
+
+short procedure imgets (im, key)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be returned
+
+long	lval, imgetl()
+errchk	imgetl
+
+begin
+	lval = imgetl (im, key)
+	if (IS_INDEFL(lval))
+	    return (INDEFS)
+	else
+	    return (lval)
+end
diff --git a/sys/imfort/db/imgftype.x b/sys/imfort/db/imgftype.x
new file mode 100644
index 00000000..246219d5
--- /dev/null
+++ b/sys/imfort/db/imgftype.x
@@ -0,0 +1,76 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<syserr.h>
+include	<ctype.h>
+include	"idb.h"
+
+# IMGFTYPE -- Get the datatype of a particular field of an image header.  Since
+# the internal format is FITS, there are four primary datatypes, boolean (T|F),
+# string (quoted), integer and real.
+
+int procedure imgftype (im, key)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be set
+
+pointer	rp
+int	axis, ch, ip
+int	idb_findrecord(), idb_kwlookup(), idb_naxis()
+errchk	syserrs
+
+begin
+	# The standard header keywords "naxis1", "naxis2", etc. are treated
+	# as a special case.
+
+	if (idb_naxis (key, axis) == YES)
+	    return (TY_LONG)
+
+	# Handle the standard header keywords.
+
+	switch (idb_kwlookup (key)) {
+	case I_CTIME:
+	    return (TY_LONG)
+	case I_LIMTIME:
+	    return (TY_LONG)
+	case I_MAXPIXVAL:
+	    return (TY_REAL)
+	case I_MINPIXVAL:
+	    return (TY_REAL)
+	case I_MTIME:
+	    return (TY_LONG)
+	case I_NAXIS:
+	    return (TY_LONG)
+	case I_PIXFILE:
+	    return (TY_CHAR)
+	case I_PIXTYPE:
+	    return (TY_LONG)
+	case I_TITLE:
+	    return (TY_CHAR)
+	}
+
+	# If we get here then the named parameter is not a standard header
+	# keyword.
+
+	if (idb_findrecord (im, key, rp) > 0) {
+	    # Check for quoted string.
+	    ch = Memc[rp+IDB_STARTVALUE]
+	    if (ch == '\'')
+		return (TY_CHAR)
+
+	    # Check for boolean field.
+	    ch = Memc[rp+IDB_ENDVALUE-1]
+	    if (ch == 'T' || ch == 'F')
+		return (TY_BOOL)
+
+	    # If field contains only digits it must be an integer.
+	    for (ip=IDB_STARTVALUE;  ip <= IDB_ENDVALUE;  ip=ip+1) {
+		ch = Memc[rp+ip-1]
+		if (! (IS_DIGIT(ch) || IS_WHITE(ch)))
+		    return (TY_REAL)
+	    }
+	    
+	    return (TY_INT)
+	}
+
+	call syserrs (SYS_IDBKEYNF, key)
+end
diff --git a/sys/imfort/db/imgnfn.x b/sys/imfort/db/imgnfn.x
new file mode 100644
index 00000000..88969645
--- /dev/null
+++ b/sys/imfort/db/imgnfn.x
@@ -0,0 +1,338 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<syserr.h>
+include	<ctype.h>
+include	<imhdr.h>
+include	"../imfort.h"
+include	"idb.h"
+
+.help imgnfn
+.nf --------------------------------------------------------------------------
+IMGNFN -- Template expansion for header keywords.
+
+	list =	imofnl[su] (im, template)	# open list
+	nch =	    imgnfn (im, outstr, maxch)	# get next field name
+		    imcfnl (im)			# close list
+
+IMOFNLS opens the list sorted, whereas IMOFNLU opens it unsorted.  Both std.
+and user header keywords are included in the list.
+.endhelp ---------------------------------------------------------------------
+
+define	MAX_FIELDS	128
+define	SZ_SBUF		1024
+define	LEN_FNSTRUCT	(10+MAX_FIELDS)
+
+define	FN_NENTRIES	Memi[$1]	# number of field names in list
+define	FN_NEXT		Memi[$1+1]	# next string to be returned
+define	FN_SBUF		Memi[$1+2]	# pointer to string buffer
+			# open
+define	FN_STRP		Memi[$1+10+$2-1]	# array of str ptrs
+define	FN_FIELDNAME	Memc[FN_STRP($1,$2)]	# reference a string
+
+
+# IMGNFN -- Get the next header field name matching the given template from an
+# image header database.  Sorting of the field list is optional.  A prior call
+# to IMOFNL[SU] is necessary to open the sorted or unsorted list.
+
+int procedure imgnfn (fn, outstr, maxch)
+
+pointer	fn			# field name list descriptor
+char	outstr[ARB]		# output string
+int	maxch
+
+int	strnum
+int	gstrcpy()
+
+begin
+	strnum = FN_NEXT(fn)
+	if (strnum > FN_NENTRIES(fn))
+	    return (EOF)
+	FN_NEXT(fn) = strnum + 1
+
+	return (gstrcpy (FN_FIELDNAME(fn,strnum), outstr, maxch))
+end
+
+
+# IMOFNLS -- Open a sorted field name list.
+
+pointer procedure imofnls (im, template)
+
+pointer	im			# image descriptor
+char	template[ARB]		# field name template
+pointer	imofnl()
+
+begin
+	return (imofnl (im, template, YES))
+end
+
+
+# IMOFNLU -- Open an unsorted field name list.
+
+pointer procedure imofnlu (im, template)
+
+pointer	im			# image descriptor
+char	template[ARB]		# field name template
+pointer	imofnl()
+
+begin
+	return (imofnl (im, template, NO))
+end
+
+
+# IMCFNL -- Close the image header field name list and return all associated
+# storage.
+
+procedure imcfnl (fn)
+
+pointer	fn			# field name list descriptor
+
+begin
+	call mfree (FN_SBUF(fn), TY_CHAR)
+	call mfree (fn, TY_STRUCT)
+end
+
+
+# IMOFNL -- Open an image header field name list, either sorted or unsorted.
+# A template is a list of patterns delimited by commas.
+
+pointer procedure imofnl (im, template, sort)
+
+pointer	im			# image descriptor
+char	template[ARB]		# field name template
+int	sort			# sort flag
+
+bool	escape
+int	tp, nstr, ch, junk, first_string, nstrings, nmatch, i
+pointer	sp, ip, op, fn, kwname, sbuf, pattern, patcode, nextch
+int	patmake(), patmatch(), strlen()
+errchk	syserr
+
+begin
+	call smark (sp)
+	call salloc (kwname, SZ_FNAME, TY_CHAR)
+	call salloc (pattern, SZ_FNAME, TY_CHAR)
+	call salloc (patcode, SZ_LINE,  TY_CHAR)
+
+	# Allocate field list descriptor.
+	call calloc (fn, LEN_FNSTRUCT, TY_STRUCT)
+	call malloc (sbuf, SZ_SBUF, TY_CHAR)
+
+	FN_SBUF(fn) = sbuf
+	nextch = sbuf
+	nstr = 0
+	tp = 1
+
+	# Extract each comma delimited template, expand upon image header
+	# field list, sort if desired, and add strings to list.
+
+	while (template[tp] != EOS && template[tp] != '\n') {
+	    # Advance to next field.
+	    while (IS_WHITE(template[tp]) || template[tp] == ',')
+		tp = tp + 1
+
+	    # Extract pattern.  Enclose pattern in ^{} so that the match will
+	    # occur only at the beginning of each line and will be case
+	    # insensitive (req'd for FITS format).
+
+	    op = pattern
+	    Memc[op] = '^'
+	    op = op + 1
+	    Memc[op] = '{'
+	    op = op + 1
+
+	    # A field name of the form "$", "$x", etc. is not matched against
+	    # the actual image field list, but is included in the output field
+	    # list as a literal.
+
+	    ch = template[tp]
+	    escape = (ch == '$')
+
+	    while (! (IS_WHITE(ch) || ch == '\n' || ch == ',' || ch == EOS)) {
+		# Map "*" into "?*".
+		if (ch == '*') {
+		    Memc[op] = '?'
+		    op = op + 1
+		}
+
+		Memc[op] = ch
+		op = op + 1
+		tp = tp + 1
+		ch = template[tp]
+	    }
+
+	    Memc[op] = '}'
+	    op = op + 1
+	    Memc[op] = EOS
+
+	    # If the pattern is a literal, put it in the output list without
+	    # matching it against the image field list.
+
+	    if (escape) {
+		# Omit the leading "^{" and the trailing "}".
+		ip = pattern + 2
+		op = op - 1
+		Memc[op] = EOS
+		call imfn_putkey (Memc[ip], FN_STRP(fn,1), nstr, nextch, sbuf)
+
+	    } else {
+		# Encode pattern.
+		junk = patmake (Memc[pattern], Memc[patcode], SZ_LINE)
+
+		# Scan database and extract all field names matching the
+		# pattern.  Mark number of first string for the sort.
+
+		first_string = nstr + 1
+
+		# First find any standard header keywords matching the pattern.
+		call imfn_stdkeys (im, Memc[patcode], FN_STRP(fn,1), nstr,
+		    nextch, sbuf)
+
+		# Now scan the user area.
+		for (ip=IM_USERAREA(im);  Memc[ip] != EOS;  ip=ip+1) {
+		    # Skip entries that are not keywords.
+		    if (Memc[ip+8] != '=')
+			next
+
+		    # Extract keyword name.
+		    Memc[kwname+8] = EOS
+		    do i = 1, 8 {
+			ch = Memc[ip+i-1]
+			if (ch == ' ') {
+			    Memc[kwname+i-1] = EOS
+			    break
+			} else
+			    Memc[kwname+i-1] = ch
+		    }
+
+		    # Check for a match.
+		    if (Memc[kwname] != EOS) {
+			# Put key in list if it matches.
+			nmatch = patmatch (Memc[kwname], Memc[patcode]) - 1
+			if (nmatch > 0 && nmatch == strlen(Memc[kwname]))
+			    call imfn_putkey (Memc[ip],
+				FN_STRP(fn,1), nstr, nextch, sbuf)
+		    }
+
+		    # Advance to the next record.
+		    if (IM_UABLOCKED(im) == YES)
+			ip = ip + IDB_RECLEN
+		    else {
+			while (Memc[ip] != '\n' && Memc[ip] != EOS)
+			    ip = ip + 1
+		    }
+
+		    if (Memc[ip] == EOS)
+			break
+		}
+
+		# Sort the newly added keywords.
+		nstrings = nstr - first_string + 1
+		if (sort == YES && nstrings > 1)
+		    call strsrt (FN_STRP(fn,first_string), Memc, nstrings)
+	    }
+	}
+
+	FN_NENTRIES(fn) = nstr
+	FN_NEXT(fn)     = 1
+
+	call sfree (sp)
+	return (fn)
+end
+
+
+# IMFN_STDKEYS -- Match a pattern (encoded) against the list of standard header
+# keywords, both with and without the "i_" prefix.  Add the full name (with i_
+# prefix) of each name matched to the keyword list.  Note that by default,
+# only the "user" keywords are matched in this way, although any keyword can
+# be accessed if its name is known (i.e., not all keywords are visible).
+
+procedure imfn_stdkeys (im, patcode, strp, nstr, nextch, sbuf)
+
+pointer	im			# image descriptor
+char	patcode[ARB]		# encoded pattern
+pointer	strp[ARB]		# array of string pointers
+int	nstr			# current number of strings
+pointer	nextch			# next available char in string buffer
+pointer	sbuf			# string buffer
+
+bool	validfield
+int	ip, index
+pointer	sp, op, key
+int	patmatch()
+errchk	imfn_putkey
+
+# NOTE index values below depend upon position in this string.
+string	keywords "|naxis|naxis1|naxis2|naxis3|pixtype|datamin|datamax|\
+ctime|mtime|limtime|title|"
+
+begin
+	call smark (sp)
+	call salloc (key, SZ_FNAME, TY_CHAR)
+
+	call strcpy ("i_", Memc[key], SZ_FNAME)
+	index = 1
+
+	for (ip=2;  keywords[ip] != EOS;  ip=ip+1) {
+	    # Do not put dimensions NAXIS1, NAXIS2, etc. higher than the
+	    # actual image dimension into the matched list.
+
+	    validfield = true
+	    if (index >= 2 && index <= 4)
+		validfield = (index - 1 <= IM_NDIM(im))
+
+	    # Extract keyword into buffer, after the "i_".
+	    for (op=key+2;  keywords[ip] != '|';  op=op+1) {
+		Memc[op] = keywords[ip]
+		ip = ip + 1
+	    }
+	    Memc[op] = EOS
+
+	    if (validfield)
+		if (patmatch (Memc[key],   patcode) > 0 ||
+		    patmatch (Memc[key+2], patcode) > 0) {
+
+		    call imfn_putkey (Memc[key], strp, nstr, nextch, sbuf)
+		}
+
+	    index = index + 1
+	}
+
+	call sfree (sp)
+end
+
+
+# IMFN_PUTKEY -- Put a keyword into the keyword list.
+
+procedure imfn_putkey (key, strp, nstr, nextch, sbuf)
+
+char	key[ARB]		# keyword name (etc.)
+pointer	strp[ARB]		# array of string pointers
+int	nstr			# current number of strings
+pointer	nextch			# next available char in string buffer
+pointer	sbuf			# string buffer
+
+int	ch, ip
+errchk	syserr
+
+begin
+	# Append keyword to the string buffer.
+	nstr = nstr + 1
+	if (nstr > MAX_FIELDS)
+	    call syserr (SYS_IMFNOVFL)
+	strp[nstr] = nextch
+
+	ip = 1
+	ch = key[ip]
+
+	while (ch != '=' && ch != ' ' && ch != EOS) {
+	    Memc[nextch] = ch
+	    nextch = nextch + 1
+	    if (nextch >= sbuf + SZ_SBUF)
+		call syserr (SYS_IMFNOVFL)
+	    ip = ip + 1
+	    ch = key[ip]
+	}
+
+	Memc[nextch] = EOS
+	nextch = nextch + 1
+end
diff --git a/sys/imfort/db/imgstr.x b/sys/imfort/db/imgstr.x
new file mode 100644
index 00000000..bf3272a5
--- /dev/null
+++ b/sys/imfort/db/imgstr.x
@@ -0,0 +1,41 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<syserr.h>
+include	<ctype.h>
+include	"idb.h"
+
+# IMGSTR -- Get an image header parameter of type string.  If the named
+# parameter is a standard parameter return the value directly, else scan
+# the user area for the named parameter and decode the value.
+
+procedure imgstr (im, key, outstr, maxch)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be returned
+char	outstr[ARB]		# output string to receive parameter value
+int	maxch
+
+pointer	rp
+int	ip, op
+int	idb_getstring(), idb_findrecord(), ctowrd(), strlen()
+errchk	syserrs
+
+begin
+	# Check for a standard header parameter first.
+	if (idb_getstring (im, key, outstr, maxch) != ERR)
+	    return
+
+	# Find the record.
+	if (idb_findrecord (im, key, rp) == 0)
+	    call syserrs (SYS_IDBKEYNF, key)
+
+	ip = IDB_STARTVALUE
+	if (ctowrd (Memc[rp], ip, outstr, maxch) > 0) {
+	    # Strip trailing whitespace.
+	    op = strlen (outstr)
+	    while (op > 0 && (IS_WHITE(outstr[op]) || outstr[op] == '\n'))
+		op = op - 1
+	    outstr[op+1] = EOS
+	} else
+	    outstr[1] = EOS
+end
diff --git a/sys/imfort/db/impstr.x b/sys/imfort/db/impstr.x
new file mode 100644
index 00000000..fba9f8af
--- /dev/null
+++ b/sys/imfort/db/impstr.x
@@ -0,0 +1,72 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<syserr.h>
+include	"idb.h"
+
+# IMPSTR -- Put an image header parameter of type string.  If the named
+# parameter is a standard parameter of type other than string, decode the
+# string and set the binary value of the parameter.  If the parameter is
+# a nonstandard one we can do a simple string edit, since user parameters
+# are stored in the user area in string form.  The datatype of the parameter
+# must be preserved by the edit, i.e., parameters of actual datatype string
+# must be quoted and left justified and other parameters must be unquoted
+# and right justified in the value field.
+
+procedure impstr (im, key, value)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be set
+char	value[ARB]		# new parameter value
+
+pointer	rp, ip, vp
+int	ncols, n, i
+bool	string_valued
+int	idb_putstring(), idb_findrecord(), strlen()
+errchk	syserrs
+
+begin
+	# Check for a standard header parameter first.
+	if (idb_putstring (im, key, value) != ERR)
+	    return
+
+	# Find the record.
+	if (idb_findrecord (im, key, rp) == 0)
+	    call syserrs (SYS_IDBKEYNF, key)
+
+	# Determine the actual datatype of the parameter.  String valued
+	# parameters will have an apostrophe in the first nonblank column
+	# of the value field.
+
+	string_valued = false
+	for (ip=IDB_STARTVALUE;  ip <= IDB_ENDVALUE;  ip=ip+1)
+	    if (Memc[rp+ip-1] == '\'') {
+		string_valued = true
+		break
+	    }
+
+	vp = rp + IDB_STARTVALUE - 1
+	n  = strlen (value)
+
+	# If we have a long string value, give it the whole card.
+	ncols = IDB_ENDVALUE - IDB_STARTVALUE + 1
+	if (string_valued && n > 21 - 3)
+	    ncols = IDB_RECLEN - IDB_STARTVALUE + 1
+
+	# Blank fill the value field.
+	do i = 1, ncols
+	    Memc[vp+i-1] = ' '
+
+	# Encode the new value of the parameter in a field of width 21
+	# (or larger in the case of long string values) including a leading
+	# blank and the quotes if string valued.
+
+	if (string_valued) {
+	    n = min (ncols - 3, n)
+	    Memc[vp+2-1] = '\''
+	    call amovc (value, Memc[vp+3-1], n)
+	    Memc[vp+ncols-1] = '\''
+	} else {
+	    n = min (ncols - 1, n)
+	    call amovc (value, Memc[vp+ncols-1-n+1], n)
+	}
+end
diff --git a/sys/imfort/db/imputb.x b/sys/imfort/db/imputb.x
new file mode 100644
index 00000000..a211f464
--- /dev/null
+++ b/sys/imfort/db/imputb.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMPUTB -- Put an image header parameter of type boolean.
+
+procedure imputb (im, key, bval)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be set
+bool	bval			# parameter value
+char	sval[2]
+
+begin
+	if (bval)
+	    sval[1] = 'T'
+	else
+	    sval[1] = 'F'
+	sval[2] = EOS
+
+	call impstr (im, key, sval)
+end
diff --git a/sys/imfort/db/imputd.x b/sys/imfort/db/imputd.x
new file mode 100644
index 00000000..fc633c23
--- /dev/null
+++ b/sys/imfort/db/imputd.x
@@ -0,0 +1,37 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<mach.h>
+
+# IMPUTD -- Put an image header parameter of type double.
+
+procedure imputd (im, key, dval)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be set
+double	dval			# double precision value
+
+int	junk, i
+pointer	sp, sval
+int	dtoc(), strlen()
+
+begin
+	call smark (sp)
+	call salloc (sval, SZ_FNAME, TY_CHAR)
+
+        # Reduce the precision of the encoded value if necessary to fit in
+        # the FITS value field.  Start with NDIGITS_DP-1 as the precision
+        # estimate NDIGITS_DP is only approximate, and if we make up half a
+        # digit of precision the result can be 1.00000000000000001 instead
+        # of 1.0.
+
+        for (i=NDIGITS_DP-1;  i >= NDIGITS_RP;  i=i-1) {
+	    junk = dtoc (dval, Memc[sval], SZ_FNAME, i, 'g', SZ_FNAME)
+            if (strlen (Memc[sval]) < 20)
+                break
+        }
+
+	# Write the new value to the header.
+	call impstr (im, key, Memc[sval])
+
+	call sfree (sp)
+end
diff --git a/sys/imfort/db/imputi.x b/sys/imfort/db/imputi.x
new file mode 100644
index 00000000..a4ccdd31
--- /dev/null
+++ b/sys/imfort/db/imputi.x
@@ -0,0 +1,18 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMPUTI -- Put an image header parameter of type integer.
+
+procedure imputi (im, key, ival)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be set
+int	ival			# parameter value
+long	lval
+
+begin
+	if (IS_INDEFI (ival))
+	    lval = INDEFL
+	else
+	    lval = ival
+	call imputl (im, key, lval)
+end
diff --git a/sys/imfort/db/imputl.x b/sys/imfort/db/imputl.x
new file mode 100644
index 00000000..3af988a9
--- /dev/null
+++ b/sys/imfort/db/imputl.x
@@ -0,0 +1,23 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMPUTL -- Put an image header parameter of type long integer.
+
+procedure imputl (im, key, lval)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be set
+long	lval			# parameter value
+
+int	junk
+pointer	sp, sval
+int	ltoc()
+
+begin
+	call smark (sp)
+	call salloc (sval, SZ_FNAME, TY_CHAR)
+
+	junk = ltoc (lval, Memc[sval], SZ_FNAME)
+	call impstr (im, key, Memc[sval])
+
+	call sfree (sp)
+end
diff --git a/sys/imfort/db/imputr.x b/sys/imfort/db/imputr.x
new file mode 100644
index 00000000..27668a62
--- /dev/null
+++ b/sys/imfort/db/imputr.x
@@ -0,0 +1,18 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMPUTR -- Put an image header parameter of type real.
+
+procedure imputr (im, key, rval)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be set
+real	rval			# parameter value
+double	dval
+
+begin
+	if (IS_INDEFR (rval))
+	    dval = INDEFD
+	else
+	    dval = rval
+	call imputd (im, key, dval)
+end
diff --git a/sys/imfort/db/imputs.x b/sys/imfort/db/imputs.x
new file mode 100644
index 00000000..6b0f763f
--- /dev/null
+++ b/sys/imfort/db/imputs.x
@@ -0,0 +1,18 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# IMPUTS -- Put an image header parameter of type short integer.
+
+procedure imputs (im, key, sval)
+
+pointer	im			# image descriptor
+char	key[ARB]		# parameter to be set
+short	sval			# parameter value
+long	lval
+
+begin
+	if (IS_INDEFS (sval))
+	    lval = INDEFL
+	else
+	    lval = sval
+	call imputl (im, key, lval)
+end
diff --git a/sys/imfort/db/mkpkg b/sys/imfort/db/mkpkg
new file mode 100644
index 00000000..4ce6acd4
--- /dev/null
+++ b/sys/imfort/db/mkpkg
@@ -0,0 +1,42 @@
+# Update the IMFORT image header database interface.
+
+$checkout libimfort.a lib$
+$update   libimfort.a
+$checkin  libimfort.a lib$
+$exit
+
+libimfort.a:
+	idbfind.x	../imfort.h idb.h <imhdr.h>
+	idbgstr.x	idb.h <ctype.h> <imhdr.h>
+	idbkwlu.x	idb.h <ctype.h> <imhdr.h>
+	idbnaxis.x	<ctype.h>
+	idbpstr.x	idb.h <ctype.h> <imhdr.h> <mach.h>
+	imaccf.x	
+	imaddb.x	
+	imaddd.x	
+	imaddf.x	../imfort.h idb.h <imhdr.h>
+	imaddi.x	
+	imaddl.x	
+	imaddr.x	
+	imadds.x	
+	imastr.x	
+	imdelf.x	idb.h <imhdr.h>
+	imgatr.x	idb.h <ctype.h>
+	imgetb.x	idb.h
+	imgetc.x	
+	imgetd.x	idb.h
+	imgeti.x	
+	imgetl.x	
+	imgetr.x	
+	imgets.x	
+	imgftype.x	idb.h <ctype.h>
+	imgnfn.x	../imfort.h idb.h <ctype.h> <imhdr.h>
+	imgstr.x	idb.h <ctype.h>
+	impstr.x	idb.h
+	imputb.x	
+	imputd.x	<mach.h>
+	imputi.x	
+	imputl.x	
+	imputr.x	
+	imputs.x	
+	;