Initial commit

10 files changed, 1041 insertions, 0 deletions

diff --git a/noao/mtlocal/idsmtn/README b/noao/mtlocal/idsmtn/README
new file mode 100644
index 00000000..7680e2d2
--- /dev/null
+++ b/noao/mtlocal/idsmtn/README
@@ -0,0 +1,3 @@
+This directory (dataio$idsmtn) contains code for the mountain format
+IIDS/IRS tapes.  Either raw or mountain reduced data tapes are read
+with task ridsmtn.  This task was installed in dataio 11/84.  SEH
diff --git a/noao/mtlocal/idsmtn/idsmtn.h b/noao/mtlocal/idsmtn/idsmtn.h
new file mode 100644
index 00000000..2ea3c9eb
--- /dev/null
+++ b/noao/mtlocal/idsmtn/idsmtn.h
@@ -0,0 +1,82 @@
+# Definitions for the Mountain format IDS tape reader:
+
+define	MAX_RANGES	100
+define	DUMMY		3	# Value returned if DUMMY IDS record is read
+
+define	SZB_IDS_RECORD		4216
+define	NPIX_IDS_REC		1024
+define	DATA_BYTE		9			# First byte of data
+define	MAX_NCOEFF		25
+define	SZ_IDS_ID		64
+define	LEN_USER_AREA		2880
+
+# The control parameter structure is defined below:
+
+define	LEN_CP		(10 + SZ_FNAME + 1)
+
+define	IS_REDUCED	Memi[$1]
+define	LONG_HEADER	Memi[$1+1]
+define	PRINT_PIXELS	Memi[$1+2]
+define	MAKE_IMAGE	Memi[$1+3]
+define	OFFSET		Memi[$1+4]
+define	DATA_TYPE	Memi[$1+5]
+define	IRAF_FILE	Memc[P2C($1+10)]
+
+
+# The header structure is defined below:
+
+define	LEN_IDS			(40 + SZ_IDS_ID + 1)
+
+define	HA			Memd[P2D($1)]
+define	AIRMASS			Memd[P2D($1+2)]
+define	RA			Memd[P2D($1+4)]
+define	DEC			Memd[P2D($1+6)]
+define	W0			Memd[P2D($1+8)]
+define	WPC			Memd[P2D($1+10)]
+define	NREC			Memi[$1+12]
+define	NP1			Memi[$1+13]
+define	NP2			Memi[$1+14]
+define	ITM			Memi[$1+15]
+define	BEAM			Memi[$1+16]
+define	COMPANION_RECORD	Memi[$1+17]
+define	SMODE			Memi[$1+18]
+define	UT			Memi[$1+19]
+define	ST			Memi[$1+20]
+define	DF_FLAG			Memi[$1+21]
+define	SM_FLAG			Memi[$1+22]
+define	QF_FLAG			Memi[$1+23]
+define	DC_FLAG			Memi[$1+24]
+define	QD_FLAG			Memi[$1+25]
+define	EX_FLAG			Memi[$1+26]
+define	BS_FLAG			Memi[$1+27]
+define	CA_FLAG			Memi[$1+28]
+define	CO_FLAG			Memi[$1+29]
+define	OFLAG			Memi[$1+30]
+define	COEFF			Memi[$1+31]	
+define	DRA			Memi[$1+32]
+define	DDEC			Memi[$1+33]
+define	ALPHA_ID		Memc[P2C($1+35)]
+define	LABEL			Memc[P2C($1+40)]
+
+
+# BYTE offsets to various IDS header words are defined below.  These become
+# word offsets once each byte is unpacked per element of an integer array.
+
+define	NREC_OFFSET	((1 * 2) - 1)
+define	ITM_OFFSET	((3 * 2) - 1)
+define	DATA_OFFSET	((5 * 2) - 1)
+define	W0_OFFSET	((2053 * 2) - 1)
+define	WPC_OFFSET	((2056 * 2) - 1)
+define	NP1_OFFSET	((2059 * 2) - 1)
+define	NP2_OFFSET	((2060 * 2) - 1)
+define	OFLAG_OFFSET	((2061 * 2) - 1)
+define	SMODE_OFFSET	((2062 * 2) - 1)
+define	UT_OFFSET	((2063 * 2) - 1)
+define	ST_OFFSET	((2065 * 2) - 1)
+define	BEAM_OFFSET	((2067 * 2) - 1)
+define	HA_OFFSET	((2068 * 2) - 1)
+define	RA_OFFSET	((2071 * 2) - 1)
+define	DEC_OFFSET	((2074 * 2) - 1)
+define	DRA_OFFSET	((2077 * 2) - 1)
+define	DDEC_OFFSET	((2078 * 2) - 1)
+define	LABEL_OFFSET	((2079 * 2) - 1)
diff --git a/noao/mtlocal/idsmtn/lut.com b/noao/mtlocal/idsmtn/lut.com
new file mode 100644
index 00000000..0a67bbd8
--- /dev/null
+++ b/noao/mtlocal/idsmtn/lut.com
@@ -0,0 +1,6 @@
+# Common block for look up tables used by idsmtn format reader.  These tables
+# are used to evaluate each byte of both integer and floating point varian
+# numbers.  They are initialized in t_ridsmtn.x.
+
+int	neg_lut6[256], neg_lut7[256], neg_lut8[256]
+common	/lut/neg_lut6, neg_lut7, neg_lut8
diff --git a/noao/mtlocal/idsmtn/mkpkg b/noao/mtlocal/idsmtn/mkpkg
new file mode 100644
index 00000000..afef1186
--- /dev/null
+++ b/noao/mtlocal/idsmtn/mkpkg
@@ -0,0 +1,14 @@
+# Ridsmtn Library
+
+$checkout libpkg.a ../
+$update   libpkg.a
+$checkin  libpkg.a ../
+$exit
+
+libpkg.a:
+	wkeywords.x   idsmtn.h <mach.h> <imhdr.h>
+	rvarian.x     idsmtn.h <mach.h> <error.h> powersof2.com lut.com
+	redflags.x    idsmtn.h <mach.h>
+	t_ridsmtn.x   idsmtn.h <mach.h> <imhdr.h> <error.h> <fset.h> \
+		      powersof2.com lut.com
+	;
diff --git a/noao/mtlocal/idsmtn/powersof2.com b/noao/mtlocal/idsmtn/powersof2.com
new file mode 100644
index 00000000..1128f9e1
--- /dev/null
+++ b/noao/mtlocal/idsmtn/powersof2.com
@@ -0,0 +1,6 @@
+# Common block for look up tables used by idsmtn format reader.  This table
+# contains powers of 2 used to reassemble floating point numbers.  It is
+# initialized in t_ridsmtn.x.
+
+double	tbl[255]
+common	/po2/tbl
diff --git a/noao/mtlocal/idsmtn/redflags.x b/noao/mtlocal/idsmtn/redflags.x
new file mode 100644
index 00000000..90c91a39
--- /dev/null
+++ b/noao/mtlocal/idsmtn/redflags.x
@@ -0,0 +1,97 @@
+include	<mach.h>
+include	"idsmtn.h"
+
+define	RED_FLAG_OFFSET 3	# Byte offset (starts at bit 17)
+define	DF_ORD_OFFSET	9	# Byte offset to df order value (bit 65)
+define	DFB		4	# Number of bytes per DF coefficient
+define	FIRST_BYTE	13
+
+# REDUCTION_FLAGS -- Extract and interpret the reduction flags found in
+# the IDS header.  9 flags are used: DF, SM, QF, DC, QD, EX, BS, CA, CO.
+# Each flag is represented by a single bit in a varian 16-bit integer.
+# If a flag is set, it's value = 0; unset flags = -1.  If the QF flag is
+# set, the order of the fitting polynomial must be unpacked.  If the DF
+# flag is set, the order of the fitting polynomial as well as the 
+# coefficients must be unpacked from the header.  The location of the
+# coefficients depends on the order of the fit.  
+
+procedure reduction_flags (vn, ids)
+
+int	vn[ARB]		# Input buffer of IDS record - one byte per int
+pointer	ids		# Pointer to ids header structure
+
+int	flag_word, offset, byte_offset, op
+real	rtemp, tmp[MAX_NCOEFF]
+errchk	vn_rred
+
+begin
+	# Initialize flags to -1
+	DF_FLAG(ids) = -1
+	SM_FLAG(ids) = -1
+	QF_FLAG(ids) = -1
+	DC_FLAG(ids) = -1
+	QD_FLAG(ids) = -1
+	EX_FLAG(ids) = -1
+	BS_FLAG(ids) = -1
+	CA_FLAG(ids) = -1
+	CO_FLAG(ids) = -1
+
+	# Unpack the flag_word from the header and determine flags.  If a
+	# flag_bit is set, the corresponding flag is true and set = 0.
+
+	flag_word = vn[RED_FLAG_OFFSET] * (2 ** 8) + vn[RED_FLAG_OFFSET+1]
+
+	if (and (flag_word,    40B) != 0)
+	    CO_FLAG(ids) = 0
+
+	if (and (flag_word,   100B) != 0)
+	    CA_FLAG(ids) = 0
+
+	if (and (flag_word,   200B) != 0)
+	    BS_FLAG(ids) = 0
+
+	if (and (flag_word,   400B) != 0)
+	    EX_FLAG(ids) = 0
+
+	if (and (flag_word,  1000B) != 0)
+	    QD_FLAG(ids) = 0
+
+	if (and (flag_word,  2000B) != 0)
+	    DC_FLAG(ids) = 0
+
+	if (and (flag_word,  4000B) != 0) 
+	    # The qf_flag is set equal to the degree of the fitting polynomial.
+	    # This value is stored in the lowest 5-bits of the flag word.
+	    QF_FLAG(ids) = and (flag_word, 37B)
+
+	if (and (flag_word, 10000B) != 0)
+	    SM_FLAG(ids) = 0
+
+	# The df_flag is interpreted next:
+	if (and (flag_word, 20000B) != 0) {
+	    # The degree of the fitting polynomial is written in 2wrd_vn_fp at
+	    # the location of the first data pixel.  The df_flag is set equal
+	    # to the integer value of the polynomial degree.
+
+	    call vn_rred (vn, DF_ORD_OFFSET, rtemp, 1)
+	    DF_FLAG(ids) = int (rtemp)
+
+	    # Now to unpack the coefficients.  The coefficients have been 
+	    # written over pixels at the beginning and end of the IDS scan.
+	    # The number and location of the overwritten pixels depends on
+	    # the order of fit and values of NP1 and NP2.
+
+	    do op = 1, DF_FLAG(ids) {
+	        offset = op
+		if (offset >= NP1(ids))
+		    # This coefficient must be stored at the end of scan
+		    offset = offset + NP2(ids) - NP1(ids)
+
+		byte_offset = FIRST_BYTE + ((offset - 1) * DFB)
+		call vn_rred (vn, byte_offset, tmp[op], 1)
+	    }
+
+	    # Copy decoded coefficients into structure
+	    call amovr (tmp, Memr[COEFF(ids)], DF_FLAG(ids))
+	}
+end
diff --git a/noao/mtlocal/idsmtn/ridsmtn.semi b/noao/mtlocal/idsmtn/ridsmtn.semi
new file mode 100644
index 00000000..3131837b
--- /dev/null
+++ b/noao/mtlocal/idsmtn/ridsmtn.semi
@@ -0,0 +1,94 @@
+# T_RIDSMTN -- Semicode for the IDS mountain format tape reader.  IDS
+# records in raw or mountain reduced format can be read into a series of
+# one dimensional IRAF images.  The first record on each mtn tape is a
+# dummy record and is ignored.  Each IDS header is read and compared
+# against the "record_numbers" list.  Depending on the user's request,
+# the header can be printed in long or short form, an IRAF image can
+# be written and the pixel values listed.  All IDS records are in a 
+# single file; an EOF implies EOT.  Procedure terminates when EOF is
+# encountered or all requested records havs been read.
+
+procedure t_ridsmtn (ids_file, iraf_file)
+
+begin
+	get control parameters from cl
+	if (output image is to be made)
+	    get root output name
+	
+	fd = open input file
+
+	while (all requested records haven't been read) {
+
+	    # Code has been revised to accomodate the apparent fact that
+	    # the data matrix is imbedded in the header information.  The
+	    # entire record (header + data) is now read in at one time.
+
+	    if (read (fd, ids_record, length_of_record) == EOF) 
+	        quit
+	    else {
+		current_record = unpack current record from buffer
+	        if (current_record is to be read) 
+		    call idsm_read_record (ids_record, header_struct, cp_struct)
+	    }
+	}
+end
+
+
+# IDSM_READ_RECORD -- is called once for each IDS record that appears in
+# the "record_numbers" range.   The header is printed and the IDS pixels
+# converted, printed or skipped depending on user request.
+
+procedure idsm_read_record (ids_record, header_struct, control_param)
+
+begin
+	stat = idsm_read_header  (ids_record, header_struct)
+	if (stat == DUMMY) {
+	    report dummy record encountered
+	    return
+	}
+	call idsm_print_header (header_struct, long_header)
+
+	if (make_image or print_pixels == YES)  {
+	    # First unpack pixels into a pixel buffer
+	    if (reduced data)
+	        call red_ids_unpk (fd, pixels)
+	    else
+	        call raw_ids_unpk (fd, pixels)
+
+	    if (output image is to be written) {
+	        generate output filename
+	        call idsm_write_image (pixels, data_type, out_fname, 
+		    header_struct)
+	    }
+
+	    if (pixels values are to be listed)
+	        call isdm_print_pixels (pixels)
+
+end
+
+
+# IDSM_READ_HEADER -- Read an IDS header and fill the program data
+# structure with header values.  Returns DUMMY or OK.
+
+int procedure idsm_read_header (ids_buffer, header_structure)
+
+begin
+	unpack header words into header structure
+	if record is DUMMY record
+	    return (DUMMY)
+	else
+	    return (OK)
+end
+
+
+# IDSM_WRITE_IMAGE -- Write a one dimensional IRAF image of an IDS record.
+
+procedure idsm_write_image (pixels, data_type, out_fname, header_struct)
+
+begin
+	map output image
+
+	move pixel_buffer into row vector
+
+	store IDS header values in image user area
+end
diff --git a/noao/mtlocal/idsmtn/rvarian.x b/noao/mtlocal/idsmtn/rvarian.x
new file mode 100644
index 00000000..ebfd7c4b
--- /dev/null
+++ b/noao/mtlocal/idsmtn/rvarian.x
@@ -0,0 +1,126 @@
+include	<error.h>
+include	<mach.h>
+include	"idsmtn.h"
+
+# UNPK_VN_ID -- Unpack an ID string from an array of FORTH ascii characters,
+# one 7-bit character per byte.  The first byte contains the character
+# count for the string.  
+
+procedure unpk_vn_id (varian, offset, output_string)
+
+int	varian[ARB]		# Array with one byte per int
+int	offset			# Word offset to first character to be unpacked
+char	output_string[SZ_IDS_ID]     # Output array - one character per element
+
+pointer	sp, id
+int	nchars_id
+
+begin
+	call smark (sp)
+	nchars_id = min (varian[offset], SZ_IDS_ID-1)
+	call salloc (id, nchars_id, TY_CHAR)
+
+	call achtic (varian[offset+1], Memc[id], nchars_id)
+	call strcpy (Memc[id], output_string, nchars_id)
+
+	call sfree (sp)
+end
+
+
+# VN_RRAW -- Read Varian long (32-bit) integers from a packed bit array.
+# Raw pixels are written as Varian long integers.  Each  pixel is 
+# 32-bits with bit 1 least significant, bit 16 unused and bit 32 the
+# sign bit.  The bits are extracted and reassembled to form a real array of 
+# IDS pixels, one pixel per array element.
+
+procedure vn_rraw (varian, offset, pixels, nwords)
+
+int	varian[ARB]		# Pointer to array of packed IDS record
+int	offset			# Word offset to first word to unpack
+real	pixels[nwords]		# Output array of unpacked IDS pixels
+int	nwords			# Number of values to unpack
+
+int	ip, op, bytes[4], int_value
+
+include	"lut.com"
+
+begin
+	ip = offset
+	for (op = 1; op <= nwords; op = op + 1) {
+
+	    call amovi (varian[ip], bytes, 4)
+
+	    if (bytes[1] < 127)
+	        int_value = bytes[4] + (bytes[3] * (2 ** 8)) + (bytes[2] * 
+	            (2 ** 15)) + (bytes[1] * (2 ** 23))
+	    else {
+		bytes[1] = neg_lut8[bytes[1]] * (2 ** 23)
+		bytes[2] = neg_lut8[bytes[2]] * (2 ** 15)
+		bytes[3] = neg_lut7[bytes[3]] * (2 ** 8)
+		bytes[4] = neg_lut8[bytes[4]]
+		int_value = -1 * (bytes[1] + bytes[2] + bytes[3] + bytes[4] + 1)
+	    }
+
+	    pixels[op] = real (int_value)
+	    ip = ip + 4
+	}
+end
+
+
+# VN_RRED -- Read 32-bit floating point pixels from a packed bit array.  
+# The values are written in special (Jan Schwitters) 2 word Varian floating 
+# point.  Reduced pixels are written in this format.
+
+procedure vn_rred (varian, offset, pixels, nwords)
+
+int	varian[ARB]		# Array of packed varian values
+int	offset			# Word offset to first value to unpack
+real	pixels[nwords]		# Output array of unpacked values
+int	nwords			# Number of values to unpack
+
+int	ip, op, mantissa, exp, bytes[4]
+
+include	"lut.com"
+include	"powersof2.com"
+
+begin
+	ip = offset
+
+	do op = 1, nwords {
+
+	    call amovi (varian[ip], bytes, 4)
+
+	    if (mod (bytes[1], 2) == 0)
+	        mantissa = bytes[4] + (bytes[3] * (2**8)) + (bytes[2] * (2**15))
+	    else {
+		bytes[4] = neg_lut8[bytes[4]]
+		bytes[3] = neg_lut7[bytes[3]] * (2 ** 8)
+		bytes[2] = neg_lut8[bytes[2]] * (2 ** 15)
+		mantissa = -1 * (bytes[4] + bytes[3] + bytes[2] + 1)
+	    }
+
+	    # Divide out mantissa sign bit
+	    exp = bytes[1]/2
+	    if (bytes[1] > 127)
+		exp = -1 * (neg_lut6[exp] + 1)
+
+	    # Reconstruct the floating point number as a SPP real.  Powers of
+	    # two are stored in the tbl[] array where 2 ** n = tbl[n + 129].
+	    # The mantissa is divided by 2 ** 23 to move the binary point
+	    # above bit 23.
+
+	    exp = exp + 129 - 23
+
+    	    if (exp <= 0)
+	        pixels[op] = 0.0
+
+            else if (exp > 255) 
+	        pixels[op] = MAX_REAL
+
+            else if (exp > 0 && exp <= 255)
+	        pixels[op] = real (mantissa) * tbl [exp]
+
+	    # Increment the input pointer for the next word to be unpacked
+	    ip = ip + 4
+	}
+end
diff --git a/noao/mtlocal/idsmtn/t_ridsmtn.x b/noao/mtlocal/idsmtn/t_ridsmtn.x
new file mode 100644
index 00000000..2956ba84
--- /dev/null
+++ b/noao/mtlocal/idsmtn/t_ridsmtn.x
@@ -0,0 +1,523 @@
+include	<error.h>
+include	<fset.h>
+include	<mach.h>
+include	<imhdr.h>
+include	"idsmtn.h"
+
+# T_RIDSMTN -- Code for the IDS mountain format tape reader.  IDS
+# records in raw or mountain reduced format can be read into a series of
+# one dimensional IRAF images.  The first record on each mtn tape is a
+# dummy record and is ignored.  Each IDS header is read and compared
+# against the "record_numbers" list.  Depending on the user's request,
+# the header can be printed in long or short form, an IRAF image can created.
+#
+# Modified 6May85 to key off the IIDS header parameters NP1 and NP2
+# to copy to the output image only the pixels indicated.
+
+procedure t_ridsmtn ()
+
+pointer sp, cp, ids, vnb
+char	ids_file[SZ_PATHNAME], rec_numbers[SZ_LINE]
+int	file_number, records[3, MAX_RANGES], nrecs, nrecs_read, fd
+int	unp1, unp2, i, sz_buffer
+
+bool	clgetb(), is_in_range()
+char	clgetc()
+int	clgeti(), mtopen(), decode_ranges(), read()
+int	get_data_type(), btoi(), mtfile(), mtneedfileno()
+
+include	"lut.com"
+include	"powersof2.com"
+
+begin
+	# Allocate space for the control parameter descriptor structure
+	# and the program data structure
+
+	call smark (sp)
+	call salloc (cp, LEN_CP, TY_STRUCT)
+	call salloc (ids, LEN_IDS, TY_STRUCT)
+
+	# Initialize look up tables used to decode bytes of varian data.
+	do i = 0, 255 {
+	    neg_lut6[i] = and (not (i),  77B)
+	    neg_lut7[i] = and (not (i), 177B)
+	    neg_lut8[i] = and (not (i), 377B) 
+	}
+
+	# Initialize powers of 2 table used to assemble floating point numbers.
+	do i = 1, 255
+	    tbl[i] = 2.0D0 ** double (i - 129)
+
+	# Get parameters from the cl and generate the input file name.  If
+	# the input file is a general tape device, append the file_number suffix
+
+	call clgstr ("ids_file", ids_file, SZ_FNAME)
+	if (mtfile(ids_file) == YES) {
+	    if (mtneedfileno (ids_file) == YES) {
+	        file_number = clgeti ("file_number")
+		call mtfname (ids_file, file_number, ids_file, SZ_FNAME)
+	    }
+	}
+
+	IS_REDUCED(cp) = btoi (clgetb ("reduced_data"))
+	LONG_HEADER(cp) = btoi (clgetb ("long_header"))
+	PRINT_PIXELS(cp) = btoi (clgetb ("print_pixels"))
+	call clgstr ("record_numbers", rec_numbers, SZ_LINE)
+	if (decode_ranges (rec_numbers, records, MAX_RANGES, nrecs) == ERR)
+	    call error (1, "Error in record_numbers specifications")
+
+	# If an output image is to be written, get output data type and
+	# root output data type.
+
+	MAKE_IMAGE(cp) = btoi (clgetb ("make_image"))
+	if (MAKE_IMAGE(cp) == YES) {
+	    call clgstr ("iraf_file", IRAF_FILE(cp), SZ_FNAME)
+	    OFFSET(cp) = clgeti ("offset")
+	    DATA_TYPE(cp) = get_data_type (clgetc ("data_type"))
+	    if (DATA_TYPE(cp) == ERR)
+		DATA_TYPE(cp) = TY_REAL
+
+	    unp1 = clgeti ("np1")
+	    unp2 = clgeti ("np2")
+	}
+
+	fd = mtopen (ids_file, READ_ONLY, 0)
+	sz_buffer = SZB_IDS_RECORD / SZB_CHAR
+	if (mtfile (ids_file) == YES)
+	    sz_buffer = sz_buffer + 64
+
+	# Allocate input buffer in units of integers
+	call salloc (vnb, sz_buffer * SZ_INT, TY_INT)
+	
+	nrecs_read = 0
+	while (nrecs_read < nrecs) {
+
+	    # Read IDS record into buffer.  Unpack bytes into integer array.
+	    if (read (fd, Memi[vnb], sz_buffer) == EOF) {
+		call printf ("IDS tape at End of File\n")
+	        break
+	    } else {
+		call achtbi (Memi[vnb], Memi[vnb], SZB_IDS_RECORD)
+		call vn_int_to_int (Memi[vnb], 1, NREC(ids))
+
+		iferr {
+	            if (is_in_range (records, NREC(ids))) {
+		        nrecs_read = nrecs_read + 1
+		        call idsm_read_record (Memi[vnb], cp, ids, unp1,unp2)
+			call flush (STDOUT)
+		    }
+	        } then {
+		    call erract (EA_WARN)
+		    next
+		}
+	    }
+	}
+
+	call sfree (sp)
+	call close (fd)
+end
+
+
+# IDSM_READ_RECORD -- is called once for each IDS record that appears in
+# the "record_numbers" range.   The header is printed and the IDS pixels
+# converted or skipped, depending on user request.
+
+procedure idsm_read_record (vnb, cp, ids, unp1, unp2)
+
+int	vnb[ARB]		# Buffer of unpacked IDS record - one byte/int
+pointer	cp			# Pointer to control parameter data structure
+pointer	ids			# Pointer to program data structure
+int	unp1, unp2		# End points of the spectrum
+
+pointer	sp, pixels
+char	out_fname[SZ_FNAME]
+int	stat
+int	strlen(), idsm_read_header()
+errchk	idsm_read_header, idsm_write_image, bswap4, vn_rraw
+errchk	vn_rred, salloc, malloc
+
+begin
+	# Allocate space on stack for pixel buffers
+	call smark (sp)
+	call salloc (pixels, NPIX_IDS_REC, TY_REAL)
+	call malloc (COEFF(ids), MAX_NCOEFF, TY_REAL)
+
+	iferr (stat = idsm_read_header (vnb, ids)) {
+	    call mfree (COEFF(ids), TY_REAL)
+	    call sfree (sp)
+	    call erract (EA_WARN)
+	    return 
+	}
+
+	if (stat == DUMMY) {
+	    call printf ("Dummy IDS record encountered\n")
+	    call mfree (COEFF(ids), TY_REAL)
+	    call sfree (sp)
+	    return
+	} else 
+	    call idsm_print_header (ids, LONG_HEADER(cp))
+
+	if (MAKE_IMAGE(cp) == YES || PRINT_PIXELS(cp) == YES) {
+
+	    if (IS_REDUCED(cp) == YES)
+	        call vn_rred (vnb, DATA_BYTE, Memr[pixels], NPIX_IDS_REC)
+	    else
+	        call vn_rraw (vnb, DATA_BYTE, Memr[pixels], NPIX_IDS_REC)
+	    
+	    if (MAKE_IMAGE(cp) == YES) {
+	        call strcpy (IRAF_FILE(cp), out_fname, SZ_FNAME)
+	        call sprintf (out_fname[strlen(out_fname)+1], SZ_FNAME, ".%04d")
+	            call pargi (NREC(ids) + OFFSET(cp))
+	        iferr {
+		    call idsm_write_image (Memr[pixels], DATA_TYPE(cp), 
+			IS_REDUCED(cp), out_fname, ids, unp1, unp2)
+		} then {
+	            call mfree (COEFF(ids), TY_REAL)
+	            call sfree (sp)
+		    call erract (EA_WARN)
+		    return
+		}
+	    }
+    
+	    if (PRINT_PIXELS(cp) == YES)
+	        call idsm_print_pixels (Memr[pixels], NP2(ids))
+
+	}
+	call mfree (COEFF(ids), TY_REAL)
+	call sfree (sp)
+end
+
+
+# IDSM_READ_HEADER -- Read an IDS header and fill the program data
+# structure with header values.  Returns EOF or OK.
+
+int procedure idsm_read_header (varian, ids)
+
+int	varian[ARB]		# Buffer of unpack varian record - one byte/int
+pointer	ids			# Pointer to program data structure
+
+errchk	vn_int_to_int, vn_long_to_int, vn_gdouble, reduction_flags
+errchk	unpk_vn_id
+
+begin
+	# The following header words are written as Varian single word
+	# integers.
+
+	call vn_int_to_int (varian, NREC_OFFSET, NREC(ids))
+
+	if (NREC(ids) == 0) 
+	    # DUMMY IDS record encountered
+	    return (DUMMY)
+	 
+	call vn_int_to_int (varian,   NP1_OFFSET,   NP1(ids))
+	call vn_int_to_int (varian,   NP2_OFFSET,   NP2(ids))
+	call vn_int_to_int (varian, OFLAG_OFFSET, OFLAG(ids))
+	call vn_int_to_int (varian, SMODE_OFFSET, SMODE(ids))
+	call vn_int_to_int (varian,  BEAM_OFFSET,  BEAM(ids))
+	call vn_int_to_int (varian,   DRA_OFFSET,   DRA(ids))
+	call vn_int_to_int (varian,  DDEC_OFFSET,  DDEC(ids))
+
+	# Now unpack Varian double word integers into integers.
+	call vn_long_to_int (varian, ITM_OFFSET, ITM(ids))
+	call vn_long_to_int (varian,  UT_OFFSET,  UT(ids))
+	call vn_long_to_int (varian,  ST_OFFSET,  ST(ids))
+
+	# Now unpack those header words written in Varian 3 word floating point.
+	call vn_gdouble (varian,  W0_OFFSET,  W0(ids))
+	call vn_gdouble (varian, WPC_OFFSET, WPC(ids))
+	call vn_gdouble (varian,  HA_OFFSET,  HA(ids))
+	call vn_gdouble (varian,  RA_OFFSET,  RA(ids))
+	call vn_gdouble (varian, DEC_OFFSET, DEC(ids))
+
+	# Extract and interpret the 9 reduction flags
+	call reduction_flags (varian, ids)
+
+	# Unpack the IDS label
+	call unpk_vn_id (varian, LABEL_OFFSET, LABEL(ids))
+
+	return (OK)
+end
+
+
+# VN_INT_TO_INT -- Unpack a single integer value from a char buffer containing
+# packed varian short (16-bit) integers.  The number of the word containing
+# the value of interest is passed as an argument.
+
+procedure vn_int_to_int (inbuf, offset, int_value)
+
+int	inbuf[ARB]		# Unpacked IDS record
+int	offset			# WORD offset as read from tape
+int	int_value		# Integer value returned
+
+int	bytes[2]
+
+include	"lut.com"
+
+begin
+	call amovi (inbuf[offset], bytes, 2)
+	if (bytes[1] < 127)
+	    int_value = (bytes[1] * (2 ** 8)) + bytes[2]
+	else {
+	    bytes[1] = neg_lut8[bytes[1]] * (2 ** 8)
+	    bytes[2] = neg_lut8[bytes[2]] 
+	    int_value = -1 * (bytes[1] + bytes[2] + 1)
+	}
+end
+
+
+# VN_LONG_TO_INT -- Unpack a SPP integer from a buffer containing packed
+# varian long (32-bit) intgers.
+
+procedure vn_long_to_int (inbuf, offset, int_value)
+
+int	inbuf[ARB]	# Buffer containing unpacked varian longs one byte/int
+int	offset		# Byte offset to field to be unpacked
+int	int_value	# Integer value returned
+
+int	bytes[4]
+
+include	"lut.com"
+
+begin
+	call amovi (inbuf[offset], bytes, 4)
+
+	if (bytes[1] < 127)
+	    int_value = bytes[4] + (bytes[3] * (2 ** 8)) + (bytes[2] * 
+	        (2 ** 15)) + (bytes[1] * (2 ** 23))
+	 else {
+	    bytes[1] = neg_lut8[bytes[1]] + (2 ** 23)
+	    bytes[2] = neg_lut8[bytes[2]] + (2 ** 15)
+	    bytes[3] = neg_lut7[bytes[3]] + (2 ** 8)
+	    bytes[4] = neg_lut8[bytes[4]]
+	    int_value = -1 * (bytes[1] + bytes[2] + bytes[3] + bytes[4] + 1)
+	}
+end
+
+
+# VN_GDOUBLE -- Unpack a SPP double from a buffer containing packed
+# varian 3-word (48-bit) floating point numbers.
+
+procedure vn_gdouble (inbuf, offset, dbl_value)
+
+int	inbuf[ARB]	# Buffer of unpacked varian 3wrd reals 1 byte/int
+int	offset		# Word offset to value to be unpacked
+double	dbl_value	# Double value returned
+
+int	bytes[6], exp, mantissa
+
+include	"lut.com"
+include	"powersof2.com"
+
+begin
+	call amovi (inbuf[offset], bytes, 6)
+
+	if (bytes[3] > 127) {
+	    bytes[6] = neg_lut8[bytes[6]]
+	    bytes[5] = neg_lut7[bytes[5]] * (2 ** 8)
+	    bytes[4] = neg_lut8[bytes[4]] * (2 ** 15)
+	    bytes[3] = neg_lut6[bytes[3]] * (2 ** 23)
+	    mantissa = -1 * (bytes[6] + bytes[5] + bytes[4] + bytes[3] + 1)
+	} else
+	    mantissa = bytes[6] + (bytes[5] * (2 ** 8)) + (bytes[4] * 
+	        (2 ** 15)) + (bytes[3] * (2 ** 23))
+
+	if (bytes[1] > 127) {
+	    bytes[1] = neg_lut8[bytes[1]] * (2 ** 8)
+	    bytes[2] = neg_lut8[bytes[2]]
+	    exp = -1 * (bytes[1] + bytes[2] + 1)
+	} else
+	    exp = bytes[2] + (bytes[1] * (2 ** 8))
+
+	# Reconstruct the floating point number as a SPP real.  Powers of
+	# two are stored in the tbl[] array where 2 ** n = tbl[n+129].
+	# The mantissa is divided by 2 ** 29 to move the binary point
+	# above bit 29.
+
+	exp = exp + 129 - 29
+
+	if (exp <= 0)
+	    dbl_value = 0.0D0
+	else if (exp > 255)
+	    dbl_value = double (MAX_REAL)
+	else if (exp > 0 && exp <= 255)
+	    dbl_value = double (mantissa) * tbl[exp]
+end
+
+
+# IDSM_WRITE_IMAGE -- Write a one dimensional IRAF image of an IDS record.
+
+procedure idsm_write_image (pixels, data_type, is_reduced, out_fname, 
+	ids, unp1, unp2)
+
+real	pixels[ARB]		# Array of unpacked IDS pixels
+int	data_type		# Data type of output pixels
+int	is_reduced		# Is data in reduced format?
+char	out_fname[SZ_FNAME]	# Filename of output IRAF image
+pointer	ids			# Pointer to program data structure
+int	unp1, unp2		# Pixel endpoints of spectrum
+
+int	pix1, pix2, npts, temp
+pointer	im
+pointer	immap(), impl1r()
+errchk	immap, amovr, idsm_store_keywords, impl1r, imunmap
+
+begin
+	# Map new IRAF image and set up image header
+	im = immap (out_fname, NEW_IMAGE, LEN_USER_AREA)
+	IM_NDIM(im) = 1
+
+	# Select the pixels to be written out.
+	# When the data is in reduced format, write out the
+	# entire vector.
+	#
+	# If the user parameter is zero, use the header elements.
+	# On some IRS tapes, these parameters are backwards.
+
+	if (NP1(ids) > NP2(ids)) {
+	    temp = NP1(ids)
+	    NP1(ids) = NP2(ids)
+	    NP2(ids) = temp
+	}
+
+	if (is_reduced == YES) {
+	    pix1 = 1
+	    pix2 = NPIX_IDS_REC
+
+	} else {
+
+	    if (unp1 == 0)
+	        pix1 = NP1(ids) + 1
+	    else
+	        pix1 = unp1
+
+	    if (unp2 == 0)
+	        pix2 = NP2(ids)
+	    else
+	        pix2 = unp2
+	}
+
+	npts = pix2 - pix1 + 1
+
+	NP1(ids) = 0
+	NP2(ids) = npts
+
+	IM_LEN(im, 1) = npts
+	call strcpy (LABEL(ids), IM_TITLE(im), SZ_IMTITLE)
+	IM_PIXTYPE(im) = data_type
+
+	# Move pixel_buffer into image row vector
+	call amovr (pixels[pix1], Memr[impl1r(im)], npts)
+
+	# Write IDS specific header words to IRAF image header
+	# Update W0 for possible new starting pixel
+
+	W0(ids) = W0(ids) + double (pix1 - 1) * WPC(ids)
+
+	call idsm_store_keywords (ids, im)
+
+	call imunmap (im)
+end
+
+
+# IDSM_PRINT_HEADER -- print the ids header in either long or short mode.  This
+# procedure has been slightly modified from the version used in ridsfile or
+# RIDSOUT.
+
+procedure idsm_print_header (ids, long_header)
+
+pointer	ids		# Pointer to program data structure
+int	long_header	# Print header in long format (YES/NO)?
+int	i
+
+begin
+	if (long_header == YES) {
+	    call printf ("\nRECORD = %d, label = \"%s\",\n")
+	        call pargi (NREC(ids))
+	        call pargstr (LABEL(ids))
+
+	    if (OFLAG(ids) == 1) {
+		call printf ("oflag = OBJECT, beam_number = %d,")
+		    call pargi (BEAM(ids))
+	    } else {
+		call printf ("oflag = SKY,    beam_number = %d,")
+		    call pargi (BEAM(ids))
+	    }
+
+	    call printf ("   W0 = %0.3f,")
+	        call pargd (W0(ids))
+	    call printf ("    WPC = %0.3f,  ITM = %d,\n")
+	        call pargd (WPC(ids))
+		call pargi (ITM(ids))
+	    call printf ("NP1 = %d, NP2 = %d,")
+		call pargi (NP1(ids))
+		call pargi (NP2(ids))
+	    call printf ("    UT = %h,   ST = %h,")
+		call pargr (UT(ids) / 3600.)
+		call pargr (ST(ids) / 3600.)
+	    call printf ("   HA = %h,\n")
+		call pargd (HA(ids))
+	    call printf ("RA = %h,   DEC = %h,")
+		call pargd (RA(ids))
+		call pargd (DEC(ids))
+	    if (DRA(ids) != 0 || DDEC(ids) != 0) {
+		call printf ("   DRA = %g,   DDEC = %g,\n")
+		    call pargr (DRA(ids) / 100.)
+		    call pargr (DDEC(ids) / 100.)
+	    } else
+		call printf ("\n")
+	    call printf ("df = %d, sm = %d, qf = %d, dc = %d, qd = %d, ") 
+		call pargi (DF_FLAG(ids))
+		call pargi (SM_FLAG(ids))
+		call pargi (QF_FLAG(ids))
+		call pargi (DC_FLAG(ids))
+		call pargi (QD_FLAG(ids))
+	    call printf ("ex = %d, bs = %d, ca = %d, co = %d")
+		call pargi (EX_FLAG(ids))
+		call pargi (BS_FLAG(ids))
+		call pargi (CA_FLAG(ids))
+		call pargi (CO_FLAG(ids))
+
+	     # The df coeffecients are printed out in the case where the df
+	     # flag has been set.
+
+	    if (DF_FLAG(ids) != -1) {
+		call printf (",\n")
+		do i = 1, DF_FLAG(ids) {
+		    call printf ("df[%d] = %10.8g")
+			call pargi(i)
+			call pargr(Memr[COEFF(ids)+i-1])
+		    if (i != DF_FLAG(ids))
+		        call printf (", ")
+		    if (mod (i, 4) == 0)
+		        call printf ("\n")
+		}
+	    } else
+		call printf ("\n")
+	    call printf ("\n")
+	} else {
+	    call printf ("RECORD = %d, label = \"%.45s\", ITM = %d\n")
+	        call pargi (NREC(ids))
+	        call pargstr (LABEL(ids))
+		call pargi (ITM(ids))
+	}
+end
+
+
+# IDSM_PRINT_PIXELS -- Print the ids pixel values.  
+
+procedure idsm_print_pixels (pixel_buf, nvalues)
+
+real	pixel_buf[ARB]		# Buffer containing pixels to be listed
+int	nvalues			# Number of pixel values to print
+int	n_pix
+
+begin
+	for (n_pix = 1; n_pix < nvalues; n_pix = n_pix + 4) {
+	    call printf ("%10.4e %10.4e %10.4e %10.4e\n")
+	        call pargr (pixel_buf[n_pix])
+	        call pargr (pixel_buf[n_pix + 1])
+	        call pargr (pixel_buf[n_pix + 2])
+	        call pargr (pixel_buf[n_pix + 3])
+	}
+	call printf ("\n")
+end
diff --git a/noao/mtlocal/idsmtn/wkeywords.x b/noao/mtlocal/idsmtn/wkeywords.x
new file mode 100644
index 00000000..12e41245
--- /dev/null
+++ b/noao/mtlocal/idsmtn/wkeywords.x
@@ -0,0 +1,90 @@
+include	<mach.h>
+include <imhdr.h>
+include "idsmtn.h"
+
+define	COL_VALUE	11
+define	LEN_KEYWORD	8
+define	LEN_OBJECT	65
+define	LEN_CARD	80
+
+# IDSM_STORE_KEYWORDS -- store IDS specific keywords in the IRAF image header.
+
+procedure idsm_store_keywords (ids, im)
+
+pointer	ids	# Pointer to program data structure
+pointer	im	# Pointer to image
+
+char	keyword[LEN_KEYWORD]
+int	fd, i, nrp 
+bool	fp_equalr()
+int	stropen()
+real	value
+errchk	stropen, addcard_i, addcard_r, addcard_st
+
+begin
+	# Open image user area as a file.
+	fd = stropen (Memc[IM_USERAREA(im)], LEN_USER_AREA - 1, NEW_FILE)
+
+	# FITS keyword are formatted and appended to the image user
+	# area with the addcard procedures.  
+
+	call addcard_i (fd, "RECORD", NREC(ids), "IDS record")
+	call addcard_i (fd, "EXPOSURE", ITM(ids), "Exposure time (seconds)")
+	call addcard_i (fd, "OFLAG", OFLAG(ids), "Object flag")
+
+	call addcard_i (fd, "BEAM-NUM", BEAM(ids), "Beam number")
+
+	value = real (W0(ids))
+	nrp = NDIGITS_RP
+	call addcard_r (fd, "W0", value, "Starting wavelength", nrp)
+
+	value = real (WPC(ids))
+	call addcard_r (fd, "WPC", value, "Wavelength per channel", nrp)
+
+	call addcard_i (fd, "NP1", NP1(ids), "Left plot limit")
+
+	call addcard_i (fd, "NP2", NP2(ids), "Right plot limit")
+
+	value = real (UT(ids) / 3600.)
+	call addcard_time (fd, "UT", value, "Universal time")
+
+	value = real (ST(ids)/ 3600.)
+	call addcard_time (fd, "ST", value, "Sidereal time")
+
+	value = real (RA(ids))
+	call addcard_time (fd, "RA", value, "Right ascension")
+
+	value = real (DEC(ids))
+	call addcard_time (fd, "DEC", value, "Declination")
+
+	value = real (HA(ids))
+	call addcard_time (fd, "HA", value, "Hour angle")
+
+	# The 9 reduction flags
+	call addcard_i (fd, "DF-FLAG", DF_FLAG(ids), "Dispersion flag")
+	call addcard_i (fd, "SM-FLAG", SM_FLAG(ids), "Smoothing flag")
+	call addcard_i (fd, "QF-FLAG", QF_FLAG(ids), "Quartz fit flag")
+	call addcard_i (fd, "DC-FLAG", DC_FLAG(ids), "Dispersion corrected")
+	call addcard_i (fd, "QD-FLAG", QD_FLAG(ids), "Quartz division flag")
+	call addcard_i (fd, "EX-FLAG", EX_FLAG(ids), "Extinction flag")
+	call addcard_i (fd, "BS-FLAG", BS_FLAG(ids), "Beam switch flag")
+	call addcard_i (fd, "CA-FLAG", CA_FLAG(ids), "Calibration flag")
+	call addcard_i (fd, "CO-FLAG", CO_FLAG(ids), "Coincidence flag")
+
+	# The df coeffecients are written out in the case where the df
+	# flag is set, and the first coefficient is nonzero.  (The later
+	# condition is a test for IDSOUT data, where the df coeffecients
+	# have been applied but not stored in the header.)
+
+	if (DF_FLAG(ids) != -1 && (! fp_equalr (Memr[COEFF(ids)], 0.))) {
+	    call strcpy ("DF", keyword, LEN_KEYWORD)
+   	    do i = 1, DF_FLAG(ids) {
+		call sprintf (keyword[3], LEN_KEYWORD, "%s")
+		    call pargi (i)
+		call addcard_r (fd, keyword, Memr[COEFF(ids)+i-1], "", nrp)
+	    }
+	}
+
+	# call strclose (fd)
+	call close (fd)
+end