aboutsummaryrefslogtreecommitdiff
path: root/noao/mtlocal/cyber/t_ridsfile.x
diff options
context:
space:
mode:
Diffstat (limited to 'noao/mtlocal/cyber/t_ridsfile.x')
-rw-r--r--noao/mtlocal/cyber/t_ridsfile.x516
1 files changed, 516 insertions, 0 deletions
diff --git a/noao/mtlocal/cyber/t_ridsfile.x b/noao/mtlocal/cyber/t_ridsfile.x
new file mode 100644
index 00000000..c7179763
--- /dev/null
+++ b/noao/mtlocal/cyber/t_ridsfile.x
@@ -0,0 +1,516 @@
+include <mach.h>
+include <imhdr.h>
+include <fset.h>
+include <error.h>
+include "cyber.h"
+
+
+# T_RIDSFILE __ code for the DUMPF IDSFILE reader. IDS records in an IDSFILE
+# are read from a Cyber DUMPF tape and optionally converted to IRAF images.
+# IDS records are not written sequentially in the IDSFILE, so, each record
+# must be read and then checked against the list of "record_numbers" to
+# see if the user requested the record to be read. The procedure terminates
+# when the requested number of records has been read or EOF is encountered.
+# The IDS trailer information is printed in either a short or long form;
+# the pixel values can also be printed.
+
+procedure t_ridsfile()
+
+pointer sp, cp
+char in_fname[SZ_FNAME], dumpf_file[SZ_FNAME]
+int file_ordinal
+
+int mtfile(), clgeti(), get_data_type(), btoi()
+bool clgetb()
+char clgetc()
+
+begin
+ # Allocate space for the control parameter descriptor structure
+ call smark (sp)
+ call salloc (cp, LEN_CP, TY_STRUCT)
+
+ call fseti (STDOUT, F_FLUSHNL, YES)
+
+ # Get parameters from cl and generate input file name. If the input
+ # file is a tape, append the file_ordinal suffix, incremented by one
+ # to skip over the DUMPF tape label.
+
+ call clgstr ("dumpf_file", dumpf_file, SZ_FNAME)
+ if (mtfile (dumpf_file) == YES) {
+ file_ordinal = clgeti ("file_ordinal")
+ call mtfname (dumpf_file, file_ordinal + 1, in_fname, SZ_FNAME)
+ } else
+ call strcpy (dumpf_file, in_fname, SZ_FNAME)
+
+ LONG_HEADER(cp) = btoi (clgetb ("long_header"))
+ PRINT_PIXELS(cp) = btoi (clgetb ("print_pixels"))
+ call clgstr ("record_numbers", REC_NUMBERS(cp), SZ_LINE)
+
+ # If an output image is to be written, get root output file name and
+ # output data type.
+ MAKE_IMAGE(cp) = btoi (clgetb ("make_image"))
+ if (MAKE_IMAGE(cp) == YES) {
+ call clgstr ("iraf_file", IRAF_FILE(cp), SZ_FNAME)
+ DATA_TYPE(cp) = get_data_type (clgetc ("data_type"))
+ if (DATA_TYPE(cp) == ERR)
+ DATA_TYPE(cp) = TY_REAL
+ }
+ call read_idsfile (in_fname, cp)
+
+ call sfree (sp)
+end
+
+
+# READ_IDSFILE -- read and sort the index of record ranges. Call
+# idsf_read_record for each record in each index range.
+
+procedure read_idsfile (in_fname, cp)
+
+char in_fname[SZ_FNAME] # Name of input file
+pointer cp # Pointer to control parameter structure
+
+int records[3, MAX_RANGES], nrecs, i
+pointer sp, pft, pru_buf
+int fd, junk, index_buf[LEN_INDEX * NINT_CYBER_WRD], nranges, nids_read
+int current_pru, n_index, next_pru, nrecords_to_read, npru_skip, n_rec
+long sorted_index[LEN_INDEX]
+
+int mtopen(), get_cyber_words_init(), read_dumpf_init(), read_dumpf()
+int get_cyber_words(), idsf_read_record(), decode_ranges()
+errchk mtopen, read_dumpf, get_cyber_words, idsf_read_record
+errchk sort_index, decode_ranges
+
+begin
+ # Allocate space for program data structure and buffers
+ call smark (sp)
+ call salloc (pft, NINT_CYBER_WRD * LEN_PFT, TY_INT)
+ call salloc (pru_buf, NINT_CYBER_WRD * LEN_PRU, TY_INT)
+
+ # Open and initialize the tape file, and read the permanent file table
+ fd = mtopen (in_fname, READ_ONLY, SZ_TAPE_BUFFER)
+ junk = get_cyber_words_init()
+ junk = read_dumpf_init()
+ if (get_cyber_words (fd, Memi[pft], LEN_PFT) == EOF) {
+ call printf ("DUMPF tape at EOT\n")
+ call sfree (sp)
+ call close (fd)
+ return
+ }
+
+ # Read and sort IDSFILE user index information. The first two
+ # pru's of this index are relevant. Up to 3 more pru's can
+ # follow, depending on the format of the idsfile. The code was
+ # modified 13Jan86 to read an old format tape of Paul Hintzen's
+ # and hopefully provide a general solution to the problem of
+ # different formats.
+
+ if (read_dumpf (fd, index_buf, LEN_USER_INDEX)== EOF) {
+ call close (fd)
+ call error (1, "Unexpected EOF when reading index")
+ }
+ if (decode_ranges (REC_NUMBERS(cp), records, MAX_RANGES, junk) == ERR)
+ call error (2, "Error in record_numbers specification")
+
+ call sort_index (index_buf, records, sorted_index, nranges, nrecs)
+
+ # Loop over each range of records in the index. nids_read counts
+ # the number of records requested by the user that have been read.
+ # nrecords_to_read is the number of records in the current index range.
+
+ nids_read = 0
+ current_pru = 3
+ for (n_index = 1; n_index <= nranges; n_index = n_index + 1) {
+ next_pru = sorted_index[n_index] / 1000
+ nrecords_to_read = mod (sorted_index[n_index], 1000)
+ npru_skip = next_pru - current_pru
+ do i = 1, npru_skip {
+ if (read_dumpf (fd, Memi[pru_buf], LEN_PRU) == EOF) {
+ # At end of IDSFILE
+ call printf ("DUMPF tape at EOF\n")
+ break
+ }
+ }
+
+ current_pru = current_pru + npru_skip
+
+ # Loop over each record within the current range of records
+ for (n_rec = 1; n_rec <= nrecords_to_read; n_rec = n_rec + 1) {
+ if (nids_read >= nrecs) {
+ # No need to continue
+ call close (fd)
+ call sfree (sp)
+ return
+ }
+
+ if (idsf_read_record (fd, records, nrecs, nids_read,
+ cp) == EOF) {
+ call close (fd)
+ call sfree (sp)
+ return
+ }
+
+
+ current_pru = current_pru + (LEN_IDS_RECORD / LEN_PRU)
+ }
+ }
+
+ call close (fd)
+ call sfree (sp)
+end
+
+
+# IDSF_READ_RECORD -- reads a single idsrecord. If the record is in the
+# set of records to be read, the record is processed and the count of requested
+# records read is incremented.
+
+int procedure idsf_read_record (fd, records, nrecs, nids_read, cp)
+
+int fd # File descriptor of input file
+int records[3, MAX_RANGES] # Array of ranges of records specified by user
+int nrecs # Number of requested records found on tape
+int nids_read # Number of requested records already read
+pointer cp # Pointer to control parameter structure
+
+char out_fname[SZ_FNAME]
+pointer sp, ids
+int ids_buffer[LEN_IDS_RECORD * NINT_CYBER_WRD], this_record
+int tape, scan
+real pixels[NPIX_IDS_RECORD]
+
+bool is_in_range()
+int read_dumpf(), bitupk(), strlen()
+errchk read_dumpf, read_header, idsf_write_image, list_values
+
+begin
+ # Allocate space for program data structure
+ call smark (sp)
+ call salloc (ids, LEN_IDS, TY_STRUCT)
+
+ # Read the next ids record
+ if (read_dumpf (fd, ids_buffer, LEN_IDS_RECORD) == EOF) {
+ # At end of IDSFILE
+ call printf ("DUMPF tape at EOF\n")
+ call sfree (sp)
+ return (EOF)
+ }
+
+ scan = bitupk (ids_buffer, SCAN_OFFSET, NBITS_INT)
+ tape = bitupk (ids_buffer, TAPE_OFFSET, NBITS_INT)
+ this_record = (tape * 1000) + scan
+ if (is_in_range (records, this_record)) {
+ nids_read = nids_read + 1
+ RECORD_NUMBER(ids) = this_record
+ iferr {
+ call calloc (COEFF(ids), MAX_COEFF, TY_DOUBLE)
+ call idsf_read_header (ids_buffer, ids)
+ } then {
+ call erract (EA_WARN)
+ call mfree (COEFF(ids), TY_DOUBLE)
+ call sfree (sp)
+ return (ERR)
+ }
+
+ call print_header (ids, LONG_HEADER(cp))
+
+ if (MAKE_IMAGE(cp) == YES) {
+ call strcpy (IRAF_FILE(cp), out_fname, SZ_FNAME)
+ call sprintf (out_fname[strlen(out_fname) + 1], SZ_FNAME, ".%d")
+ call pargi (RECORD_NUMBER(ids))
+ iferr {
+
+ call idsf_write_image (ids_buffer, DATA_TYPE(cp),
+ PRINT_PIXELS(cp), out_fname, ids)
+
+ } then {
+ call ERRACT (EA_WARN)
+ call mfree (COEFF(ids), TY_DOUBLE)
+ call sfree (sp)
+ return (ERR)
+ }
+ }
+
+ if (PRINT_PIXELS(cp) == YES && MAKE_IMAGE(cp) == NO) {
+ call unpk_30 (ids_buffer, 1, pixels, NPIX_IDS_RECORD)
+ call list_values (pixels)
+ }
+ call mfree (COEFF(ids), TY_DOUBLE)
+ }
+
+ call sfree (sp)
+ return (OK)
+end
+
+
+# SORT_INDEX -- Sort index information that precedes each IDSFILE. This
+# index occupies 5 PRU's and points to ranges of records. Each index
+# entry contains a PRU number and the low and high record numbers of the
+# records that begin at the stated PRU. These three pieces of information
+# are stored in a single 60-bit Cyber word. The number of records requested
+# by the user that are actually in the IDSFILE is also counted. This
+# number is returned as a parameter to the calling procedure.
+
+procedure sort_index (index_buf, records, sorted_index, nranges, nrecs_on_tape)
+
+int index_buf[ARB] # Buffer containing IDS index information
+int records[3, MAX_RANGES] # Array of ranges of records specified by user
+long sorted_index[LEN_INDEX] # Returned array of sorted index information
+int nranges # Number of ranges of IDS records in IDSFILE
+int nrecs_on_tape # Number of requested records actually on tape
+
+int i, start_pru, low_record_number, high_record_number, nrecs, j
+long index[LEN_INDEX]
+bool is_in_range()
+int bitupk()
+errchk asrtl, bitupk
+
+begin
+ nrecs_on_tape = 0
+ nranges = 0
+ do i = 1, NINT_CYBER_WRD * LEN_USER_INDEX, NINT_CYBER_WRD {
+ start_pru = bitupk (index_buf[i], NPRU_OFFSET, NBITS_NPRU)
+ if (start_pru == 0)
+ next
+ low_record_number = bitupk (index_buf[i], LRN_OFFSET, NBITS_LRN)
+ high_record_number = bitupk (index_buf[i], HRN_OFFSET, NBITS_HRN)
+ nrecs = high_record_number - low_record_number + 1
+ nranges = nranges + 1
+ index[nranges] = real (start_pru * 1000) + nrecs
+
+ for (j=low_record_number; j<=high_record_number; j=j+1) {
+ if (is_in_range (records, j))
+ nrecs_on_tape = nrecs_on_tape + 1
+ }
+ }
+
+ call asrtl (index, sorted_index, nranges)
+end
+
+
+# LIST_VALUES -- Print the ids pixel values.
+
+procedure list_values (pixel_buf)
+
+real pixel_buf[NPIX_IDS_RECORD] # Buffer containing pixels to be listed
+int n_pix
+
+begin
+ for (n_pix = 1; n_pix <= NPIX_IDS_RECORD; 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
+
+# IDSF_READ_HEADER -- Decode ids header parameters from the input buffer and
+# fill the program data structure.
+
+procedure idsf_read_header (ids_buffer, ids)
+
+int ids_buffer[NINT_CYBER_WRD*LEN_IDS_RECORD] # Input IDSFILE buffer
+pointer ids # Pointer to program data structure
+
+int n_coeff, i
+char alpha[3]
+int bitupk()
+double convert_60bit_fp()
+errchk bitupk, unpk_60i, convert_60bit_fp, unpk_id, display_code
+
+begin
+ # Get unsigned integer parameters from header
+ ITM(ids) = bitupk (ids_buffer, ITM_OFFSET, NBITS_INT)
+ NP1(ids) = bitupk (ids_buffer, NP1_OFFSET, NBITS_INT)
+ NP2(ids) = bitupk (ids_buffer, NP2_OFFSET, NBITS_INT)
+ BEAM_NUMBER(ids) = bitupk (ids_buffer, BEAM_OFFSET, NBITS_INT)
+ SMODE(ids) = bitupk (ids_buffer, SMODE_OFFSET, NBITS_INT)
+ if (SMODE(ids) != 0) {
+ # Determine companion record number
+ if (BEAM_NUMBER(ids) == 1)
+ COMPANION_RECORD(ids) = RECORD_NUMBER(ids) - 1
+ else
+ COMPANION_RECORD(ids) = RECORD_NUMBER(ids) + 1
+ }
+ UT(ids) = bitupk (ids_buffer, UT_OFFSET, NBITS_INT)
+ ST(ids) = bitupk (ids_buffer, ST_OFFSET, NBITS_INT)
+
+ # The following integer parameters can be negative
+ call unpk_60i (ids_buffer, DF_OFFSET, DF_FLAG(ids), 1)
+ call unpk_60i (ids_buffer, SM_OFFSET, SM_FLAG(ids), 1)
+ call unpk_60i (ids_buffer, QF_OFFSET, QF_FLAG(ids), 1)
+ call unpk_60i (ids_buffer, DC_OFFSET, DC_FLAG(ids), 1)
+ call unpk_60i (ids_buffer, QD_OFFSET, QD_FLAG(ids), 1)
+ call unpk_60i (ids_buffer, EX_OFFSET, EX_FLAG(ids), 1)
+ call unpk_60i (ids_buffer, BS_OFFSET, BS_FLAG(ids), 1)
+ call unpk_60i (ids_buffer, CA_OFFSET, CA_FLAG(ids), 1)
+ call unpk_60i (ids_buffer, CO_OFFSET, CO_FLAG(ids), 1)
+ call unpk_60i (ids_buffer, OFLAG_OFFSET, OFLAG(ids), 1)
+
+ # If the dispersion flag (DF) is set, get the coeffecients. The pointer
+ # to the coeffecient array is stored in the structure ids.
+ if (DF_FLAG(ids) > -1) {
+ n_coeff = DF_FLAG(ids)
+ do i = 1, n_coeff {
+ Memd[COEFF(ids)+i-1] = convert_60bit_fp (ids_buffer,
+ (COEFF_OFFSET + (i - 1)) * 64 + 1)
+ }
+ }
+
+ # These header values converted from Cyber 60-bit floating point
+ HA(ids) = convert_60bit_fp (ids_buffer, HA_OFFSET)
+ AIRMASS(ids) = convert_60bit_fp (ids_buffer, AIR_OFFSET)
+ RA(ids) = convert_60bit_fp (ids_buffer, RA_OFFSET)
+ DEC(ids) = convert_60bit_fp (ids_buffer, DEC_OFFSET)
+ LAMBDA0(ids) = convert_60bit_fp (ids_buffer, LAM_OFFSET)
+ DELTA_LAMBDA(ids) = convert_60bit_fp (ids_buffer, DEL_OFFSET)
+
+ # The 3 character ALPHA_ID is stored in Cyber display code
+ call display_code (bitupk (ids_buffer, ALPHA1_OFFSET, NBITS_DC),
+ alpha[1])
+ call display_code (bitupk (ids_buffer, ALPHA2_OFFSET, NBITS_DC),
+ alpha[2])
+ call display_code (bitupk (ids_buffer, ALPHA3_OFFSET, NBITS_DC),
+ alpha[3])
+ call strcpy (alpha, ALPHA_ID(ids), NCHAR_ALPHA)
+
+ # The ids label is written in 7-bit ascii
+ call unpk_id (ids_buffer, IDS_ID_OFFSET, LABEL(ids))
+end
+
+
+# PRINT_HEADER -- print the ids header in either long or short mode.
+
+procedure print_header (ids, long_header)
+
+pointer ids # Pointer to program data structure
+int long_header # Print header in long format (YES/NO)?
+int i
+
+real value1, value2
+
+begin
+ if (long_header == YES) {
+ call printf ("RECORD = %d, label = \"%s\",\n")
+ call pargi (RECORD_NUMBER(ids))
+ call pargstr (LABEL(ids))
+
+ if (OFLAG(ids) == 1) {
+ call printf ("oflag = OBJECT, beam_number = %d, ")
+ call pargi (BEAM_NUMBER(ids))
+ } else if (OFLAG (ids) == 0) {
+ call printf ("oflag = SKY, beam_number = %d, ")
+ call pargi (BEAM_NUMBER(ids))
+ }
+ call printf ("alpha_ID = %s")
+ call pargstr (ALPHA_ID(ids))
+ if (SMODE(ids) != 0) {
+ call printf (", companion = %d,\n")
+ call pargi (COMPANION_RECORD(ids))
+ } else
+ call printf (",\n")
+
+ call printf ("airmass = %5.3f,%24tW0 = %0.3f,")
+ call pargd (AIRMASS(ids))
+ call pargd (LAMBDA0(ids))
+ call printf (" WPC = %0.3f, ITM = %d,\n")
+ call pargd (DELTA_LAMBDA(ids))
+ call pargi (ITM(ids))
+ call printf ("NP1 = %d, NP2 = %d,")
+ call pargi (NP1(ids))
+ call pargi (NP2(ids))
+
+ if (IS_INDEFI (UT(ids)))
+ value1 = INDEFR
+ else
+ value1 = real (UT(ids) / 3600.)
+
+ if (IS_INDEFI (ST(ids)))
+ value2 = INDEFR
+ else
+ value2 = real (ST(ids) / 3600.)
+ call printf (" UT = %h, ST = %h,\n")
+ call pargr (value1)
+ call pargr (value2)
+
+ call printf ("HA = %h,")
+ call pargd (HA(ids))
+ call printf (" RA = %h, DEC = %h,\n")
+ call pargd (RA(ids))
+ call pargd (DEC(ids))
+ 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 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 && COEFF(ids) != 0) {
+ call printf (",\n")
+ do i = 1, DF_FLAG(ids) {
+ call printf ("df[%d] = %10.8g")
+ call pargi(i)
+ call pargd(Memd[COEFF(ids)+i-1])
+ if (i != DF_FLAG(ids))
+ call printf (", ")
+ if (mod (i, 4) == 0)
+ call printf ("\n")
+ }
+ call printf ("\n")
+ } else
+ call printf ("\n")
+ call printf ("\n")
+ } else {
+ call printf ("RECORD = %d, label = \"%s\"\n")
+ call pargi (RECORD_NUMBER(ids))
+ call pargstr (LABEL(ids))
+ }
+end
+
+
+# IDSF_WRITE_IMAGE -- pixels are unpacked from the input buffer and written to
+# a one dimensional IRAF image.
+
+procedure idsf_write_image (ids_buffer, data_type, print_pixels, out_fname,
+ ids)
+
+int ids_buffer[NINT_CYBER_WRD * LEN_IDS_RECORD] # Input IDSFILE buffer
+int data_type # Data type of pixels to be written
+int print_pixels # List pixel values (YES/NO)?
+char out_fname[SZ_FNAME] # Name of output image
+pointer ids # Pointer to program data structure
+
+pointer im, pixels
+pointer impl1r(), immap()
+errchk immap, unpk_30, cy_store_keywords, imunmap
+
+begin
+ # Map new iraf image and set up image header
+ im = immap (out_fname, NEW_IMAGE, LEN_USER_AREA)
+ IM_NDIM(im) = 1
+ IM_LEN(im, 1) = NPIX_IDS_RECORD
+ call strcpy (LABEL(ids), IM_TITLE(im), SZ_IMTITLE)
+ IM_PIXTYPE(im) = data_type
+ pixels = impl1r(im)
+
+ # Convert pixels to spp reals and write image line
+ call unpk_30 (ids_buffer, 1, Memr[pixels], NPIX_IDS_RECORD)
+
+ if (print_pixels == YES)
+ call list_values (Memr[pixels])
+
+ # Write ids specific header words to iraf image header
+ call cy_store_keywords (ids, im)
+
+ call imunmap (im)
+end
generated by cgit (git 2.34.1) at 2025-09-20 13:20:53 -0400