1 files changed, 72 insertions, 0 deletions
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