Initial commit

1 files changed, 179 insertions, 0 deletions

diff --git a/sys/imio/iki/stf/stfrgpb.x b/sys/imio/iki/stf/stfrgpb.x
new file mode 100644
index 00000000..15c4da0a
--- /dev/null
+++ b/sys/imio/iki/stf/stfrgpb.x
@@ -0,0 +1,179 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<imhdr.h>
+include	<imio.h>
+include	<mach.h>
+include	"stf.h"
+
+# STF_RGPB -- Read the group data block into the first few cards of the user
+# area of the IMIO image header.  The GPB is stored as a binary data structure
+# in the STF pixfile.  The values of the standard GPB parameters DATAMIN and
+# DATAMAX are returned as output arguments.
+#
+# DLB--11/03/87: Made changes to allow i*2 and i*4 integer parameters in GPB.
+# DLB--11/11/87: Changed calculation of character string length in GPB to
+# avoid integer truncation error by using P_PSIZE directly.
+
+procedure stf_rgpb (im, group, acmode, datamin, datamax)
+
+pointer	im			# IMIO image descriptor
+int	group			# group to be accessed
+int	acmode			# image access mode
+real	datamin, datamax	# min,max pixel values from GPB
+
+real	rval
+double	dval
+short	sval
+long	lval, offset
+bool	bval, newgroup
+pointer	sp, stf, gpb, lbuf, pp
+int	pfd, pn, sz_param, sz_gpb
+errchk	imaddb, imadds, imaddl, imaddr, imaddd, imastr
+errchk	imputd, impstr, open, read
+int	open(), read(), imaccf()
+real	imgetr()
+
+string	readerr "cannot read group data block - no such group?"
+string	badtype "illegal group data parameter datatype"
+string	nogroup "group index out of range"
+define	minmax_ 91
+
+begin
+	call smark (sp)
+	call salloc (lbuf, SZ_LINE, TY_CHAR)
+
+	stf = IM_KDES(im)
+	pfd = STF_PFD(stf)
+
+	# Verify that the given group exists.
+	if (group < 1 || group > STF_GCOUNT(stf))
+	    call error (1, nogroup)
+
+	# Skip ahead if there is no group parameter block.
+	if (STF_PSIZE(stf) == 0)
+	    goto minmax_
+
+	# Open the pixel file if not already open.
+	if (pfd == NULL) {
+	    iferr {
+		if (IM_ACMODE(im) == READ_ONLY)
+		    pfd = open (IM_PIXFILE(im), READ_ONLY, BINARY_FILE)
+		else
+		    pfd = open (IM_PIXFILE(im), READ_WRITE, BINARY_FILE)
+		STF_PFD(stf) = pfd
+	    } then {
+		call eprintf ("Warning: Cannot open pixfile to read GPB (%s)\n")
+		    call pargstr (IM_NAME(im))
+		pfd = NULL
+	    }
+	}
+
+	# Allocate a buffer for the GPB.
+	sz_gpb = STF_PSIZE(stf) / NBITS_BYTE / SZB_CHAR
+	call salloc (gpb, sz_gpb, TY_CHAR)
+
+	# Read the GPB into a buffer.  The GPB is located at the very end of
+	# the data storage area for the group.  If we are opening a new,
+	# uninitialized group (acmode = new_image or new_copy), do not
+	# physically read the GPB as it is will be uninitialized data.
+
+	newgroup = (acmode == NEW_IMAGE || acmode == NEW_COPY || pfd == NULL)
+	if (newgroup)
+	    call aclrc (Memc[gpb], sz_gpb)
+	else {
+	    offset = (group * STF_SZGROUP(stf) + 1) - sz_gpb
+	    call seek (pfd, offset)
+	    if (read (pfd, Memc[gpb], sz_gpb) != sz_gpb)
+		call error (1, readerr)
+	}
+
+	# Extract the binary value of each parameter in the GPB and encode it
+	# in FITS format in the IMIO user area.
+
+	offset = 0
+	for (pn=1;  pn <= STF_PCOUNT(stf);  pn=pn+1) {
+	    pp = STF_PDES(stf,pn)
+		
+	    # Fill in the unitialized fields of the GPB parameter descriptor.
+	    P_OFFSET(pp) = offset
+	    sz_param = P_PSIZE(pp) / NBITS_BYTE / SZB_CHAR
+
+	    switch (P_PDTYPE(pp)) {
+	    # changed case for int to short and long--dlb 11/3/87
+	    case 'I':
+		if (sz_param == SZ_SHORT)
+		    P_SPPTYPE(pp) = TY_SHORT
+		else
+		    P_SPPTYPE(pp) = TY_LONG
+		P_LEN(pp) = 1
+	    case 'R':
+		if (sz_param == SZ_REAL)
+		    P_SPPTYPE(pp) = TY_REAL
+		else
+		    P_SPPTYPE(pp) = TY_DOUBLE
+		P_LEN(pp) = 1
+	    case 'C':
+		P_SPPTYPE(pp) = TY_CHAR
+		# calculate length directly from PSIZE to avoid truncation error
+		P_LEN(pp) = min (SZ_LINE, P_PSIZE(pp) / NBITS_BYTE)
+	    case 'L':
+		P_SPPTYPE(pp) = TY_BOOL
+		P_LEN(pp) = 1
+	    default:
+		call error (1, badtype)
+	    }
+
+	    # Extract the binary parameter value and add a FITS encoded card
+	    # to the IMIO user area.  In the case of a new copy image, the
+	    # GPB values will already be in the image header, do not modify
+	    # the parameter value, but add the parameter if it was not
+	    # inherited from the old image.
+
+	    if (acmode != NEW_COPY || imaccf (im, P_PTYPE(pp)) == NO) {
+		switch (P_SPPTYPE(pp)) {
+		case TY_BOOL:
+                    if (SZ_INT != SZ_INT32)
+		        call amovc (Memc[gpb+offset], bval, SZ_INT32)
+                    else
+		        call amovc (Memc[gpb+offset], bval, SZ_BOOL)
+		    call imaddb (im, P_PTYPE(pp), bval)
+		case TY_SHORT:
+		    call amovc (Memc[gpb+offset], sval, SZ_SHORT)
+		    call imadds (im, P_PTYPE(pp), sval)
+		case TY_LONG:
+                    if (SZ_INT != SZ_INT32)
+		        call amovc (Memc[gpb+offset], lval, SZ_INT32)
+                    else
+		        call amovc (Memc[gpb+offset], lval, SZ_LONG)
+		    call imaddl (im, P_PTYPE(pp), lval)
+		case TY_REAL:
+		    call amovc (Memc[gpb+offset], rval, SZ_REAL)
+		    call imaddr (im, P_PTYPE(pp), rval)
+		case TY_DOUBLE:
+		    call amovc (Memc[gpb+offset], dval, SZ_DOUBLE)
+		    call imaddd (im, P_PTYPE(pp), dval)
+		case TY_CHAR:
+		    call chrupk (Memc[gpb+offset], 1, Memc[lbuf], 1, P_LEN(pp))
+		    Memc[lbuf+P_LEN(pp)] = EOS
+		    call imastr (im, P_PTYPE(pp), Memc[lbuf])
+		default:
+		    call error (1, badtype)
+		}
+	    }
+
+	    offset = offset + sz_param
+	}
+
+minmax_
+	# Return DATAMIN, DATAMAX.  This is done by searching the user area so
+	# that ordinary keywords may be used to set datamin and datamax if the
+	# GPB is not used.
+
+	datamin = 0.0; datamax = 0.0
+	if (imaccf (im, "DATAMIN") == YES)
+	    datamin = imgetr (im, "DATAMIN")
+	if (imaccf (im, "DATAMAX") == YES)
+	    datamax = imgetr (im, "DATAMAX")
+
+	call sfree (sp)
+end