diff options
Diffstat (limited to 'noao/mtlocal/idsmtn')
| -rw-r--r-- | noao/mtlocal/idsmtn/README | 3 | ||||
| -rw-r--r-- | noao/mtlocal/idsmtn/idsmtn.h | 82 | ||||
| -rw-r--r-- | noao/mtlocal/idsmtn/lut.com | 6 | ||||
| -rw-r--r-- | noao/mtlocal/idsmtn/mkpkg | 14 | ||||
| -rw-r--r-- | noao/mtlocal/idsmtn/powersof2.com | 6 | ||||
| -rw-r--r-- | noao/mtlocal/idsmtn/redflags.x | 97 | ||||
| -rw-r--r-- | noao/mtlocal/idsmtn/ridsmtn.semi | 94 | ||||
| -rw-r--r-- | noao/mtlocal/idsmtn/rvarian.x | 126 | ||||
| -rw-r--r-- | noao/mtlocal/idsmtn/t_ridsmtn.x | 523 | ||||
| -rw-r--r-- | noao/mtlocal/idsmtn/wkeywords.x | 90 |
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 |