1 files changed, 117 insertions, 0 deletions
diff --git a/sys/imio/iki/qpf/qpfcopypar.x b/sys/imio/iki/qpf/qpfcopypar.x
new file mode 100644
index 00000000..cfa94c62
--- /dev/null
+++ b/sys/imio/iki/qpf/qpfcopypar.x
@@ -0,0 +1,117 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<error.h>
+include	<imhdr.h>
+include	<imio.h>
+include	<qpset.h>
+include	"qpf.h"
+
+# QPF_COPYPARAMS -- Copy parameters from the QPOE datafile header into the
+# image header.  Only scalar parameters are copied.
+
+procedure qpf_copyparams (im, qp)
+
+pointer	im			#I image descriptor
+pointer	qp			#I QPOE descriptor
+
+int	nelem, dtype, maxelem, flags
+pointer	sp, param, text, comment, datatype, fl, qpf, mw, io
+
+pointer	qp_ofnlu(), qpio_loadwcs()
+int	qp_gnfn(), qp_queryf(), stridx(), strdic()
+errchk	qp_ofnlu, qp_gnfn, qp_queryf, imaddi, qp_geti, mw_saveim
+
+bool	qp_getb()
+short	qp_gets()
+int	qp_geti(), qp_gstr()
+real	qp_getr()
+double	qp_getd()
+
+begin
+	call smark (sp)
+	call salloc (text, SZ_LINE, TY_CHAR)
+	call salloc (param, SZ_FNAME, TY_CHAR)
+	call salloc (comment, SZ_COMMENT, TY_CHAR)
+	call salloc (datatype, SZ_DATATYPE, TY_CHAR)
+
+	qpf = IM_KDES(im)
+
+	# Copy QPOE special keywords.
+	call imaddi (im, "NAXES",  qp_geti(qp,"naxes"))
+	call imaddi (im, "AXLEN1", qp_geti(qp,"axlen[1]"))
+	call imaddi (im, "AXLEN2", qp_geti(qp,"axlen[2]"))
+	call imaddr (im, "XBLOCK", QPF_XBLOCK(qpf))
+	call imaddr (im, "YBLOCK", QPF_YBLOCK(qpf))
+
+	# Output the QPOE filter.
+	iferr (call qpf_wfilter (qpf, im))
+	    call erract (EA_WARN)
+
+	# Compute and output any filter attributes.
+	iferr (call qpf_wattr (qpf, im))
+	    call erract (EA_WARN)
+
+	# Copy the WCS, if any.
+	io = QPF_IO(qpf)
+	if (io != NULL)
+	    ifnoerr (mw = qpio_loadwcs (io)) {
+		call mw_saveim (mw, im)
+		call mw_close (mw)
+	    }
+
+	# Copy general keywords.
+	fl = qp_ofnlu (qp, "*")
+
+	while (qp_gnfn (fl, Memc[param], SZ_FNAME) != EOF) {
+	    # Get the next scalar parameter which has a nonnull value.
+	    nelem = qp_queryf (qp, Memc[param], Memc[datatype], maxelem,
+		Memc[comment], flags)
+	    if (strdic (Memc[param], Memc[text], SZ_LINE, OMIT) > 0)
+		next
+
+	    dtype = stridx (Memc[datatype], "bcsilrdx")
+
+	    # Make entry for a parameter which has no value, or an unprintable
+	    # value.
+
+	    if (nelem == 0 || (nelem > 1 && dtype != TY_CHAR) ||
+		dtype < TY_BOOL || dtype > TY_COMPLEX) {
+
+		call sprintf (Memc[text], SZ_LINE, "%14s[%03d] %s")
+		    call pargstr (Memc[datatype])
+		    call pargi (nelem)
+		    call pargstr (Memc[comment])
+
+		iferr (call imastr (im, Memc[param], Memc[text]))
+		    call erract (EA_WARN)
+		next
+	    }
+
+	    # Copy parameter to image header.
+	    iferr {
+		switch (dtype) {
+		case TY_BOOL:
+		    call imaddb (im, Memc[param], qp_getb(qp,Memc[param]))
+		case TY_CHAR:
+		    if (qp_gstr (qp, Memc[param], Memc[text], SZ_LINE) > 0)
+			call imastr (im, Memc[param], Memc[text])
+		case TY_SHORT:
+		    call imadds (im, Memc[param], qp_gets(qp,Memc[param]))
+		case TY_INT, TY_LONG:
+		    call imaddi (im, Memc[param], qp_geti(qp,Memc[param]))
+		case TY_REAL:
+		    call imaddr (im, Memc[param], qp_getr(qp,Memc[param]))
+		case TY_DOUBLE:
+		    call imaddd (im, Memc[param], qp_getd(qp,Memc[param]))
+		case TY_COMPLEX:
+		    ; # not supported.
+		}
+	    } then {
+		call erract (EA_WARN)
+		break
+	    }
+	}
+
+	call qp_cfnl (fl)
+	call sfree (sp)
+end