aboutsummaryrefslogtreecommitdiff
path: root/noao/onedspec/irsiids/t_widstape.x
diff options
context:
space:
mode:
Diffstat (limited to 'noao/onedspec/irsiids/t_widstape.x')
-rw-r--r--noao/onedspec/irsiids/t_widstape.x343
1 files changed, 343 insertions, 0 deletions
diff --git a/noao/onedspec/irsiids/t_widstape.x b/noao/onedspec/irsiids/t_widstape.x
new file mode 100644
index 00000000..1f96d146
--- /dev/null
+++ b/noao/onedspec/irsiids/t_widstape.x
@@ -0,0 +1,343 @@
+include <mach.h>
+include <error.h>
+include <imhdr.h>
+include <smw.h>
+
+define SZ_IDSTITLE 64 # Length of IDSOUT title
+define SZ_CARD 80 # Columns on a card
+
+# T_WIDSTAPE -- Convert each line of an IRAF image to IDSOUT text format.
+# Each image line is treated as a one dimensional spectrum.
+# A maximum IDSOUT length of 1024 points is enforced silently.
+#
+# There are two types of output:
+# single -- All image lines are appended to a single IDSOUT file.
+# multiple -- Each image line is appended to a different IDSOUT file.
+
+procedure t_widstape ()
+
+pointer image # Image to be converted
+pointer recs # Record numbers
+pointer idsout # IDSOUT file or root name to be written
+int block_size # Block size
+bool ebcdic # ASCII or EBCDIC
+
+int i, mfd, root, nrecs
+pointer sp, im, mw, sh, ptr
+
+int open(), mtopen(), clgeti(), clpopni()
+int get_next_image(), decode_ranges(), mtfile(), mtneedfileno()
+bool clgetb()
+pointer immap(), smw_openim()
+errchk immap, smw_openim, shdr_open, wrt_ids_rec
+
+begin
+ call smark (sp)
+ call salloc (image, SZ_LINE, TY_CHAR)
+ call salloc (idsout, SZ_FNAME, TY_CHAR)
+ call salloc (recs, 300, TY_INT)
+
+ # Parameters
+ root = clpopni ("input")
+ call clgstr ("records", Memc[image], SZ_LINE)
+ call clgstr ("idsout", Memc[idsout], SZ_FNAME)
+ block_size = clgeti ("block_size")
+ ebcdic = clgetb ("ebcdic")
+
+ # Set record numbers
+ if (decode_ranges (Memc[image], Memi[recs], 100, nrecs) == ERR)
+ call error (0, "Bad range specification")
+
+ # Check that a realistic block size was requested
+ if (mod (block_size, SZ_CARD) == 0)
+ block_size = block_size / SZB_CHAR
+ else
+ call error (0, "Blocks not integral number of cards")
+
+ # Open output tape file
+ # First determine if a file number was specified
+ if (mtfile (Memc[idsout]) == YES) {
+
+ # If no file, check if new_tape was specified and if so,
+ # force file=1; otherwise force file=EOT
+
+ if (mtneedfileno (Memc[idsout]) == YES) {
+ if (!clgetb("new_tape"))
+ call mtfname (Memc[idsout], EOT, Memc[idsout], SZ_FNAME)
+
+ else
+ call mtfname (Memc[idsout], 1, Memc[idsout], SZ_FNAME)
+ }
+ mfd = mtopen (Memc[idsout], WRITE_ONLY, block_size)
+ } else
+ mfd = open (Memc[idsout], NEW_FILE, BINARY_FILE)
+
+ # Loop over all files
+ call reset_next_image ()
+ while (get_next_image (root, Memi[recs], nrecs, Memc[image],
+ SZ_LINE) != EOF) {
+ iferr {
+ im = NULL
+ mw = NULL
+ ptr = immap (Memc[image], READ_ONLY, 0); im = ptr
+ ptr = smw_openim (im); mw = ptr
+
+ # Write out a spectrum for each line in the image
+ do i = 1, IM_LEN (im,2) {
+ call shdr_open (im, mw, i, 1, INDEFI, SHDATA, sh)
+ call wrt_ids_rec (mfd, sh, Memc[image], ebcdic)
+ }
+
+ call printf ("copied - [%s]: %s\n")
+ call pargstr (IMNAME(sh))
+ call pargstr (TITLE(sh))
+ call flush (STDOUT)
+ } then
+ call erract (EA_WARN)
+
+ if (mw != NULL)
+ call smw_close (mw)
+ if (im != NULL)
+ call imunmap (im)
+ }
+
+ call shdr_close (sh)
+ call close (mfd)
+ call sfree (sp)
+end
+
+
+# WRT_IDS_REC -- Write one IIDS/IRS format record in IDSOUT form
+
+procedure wrt_ids_rec (mfd, sh, image, ebcdic)
+
+int mfd
+pointer sh
+char image[SZ_FNAME]
+bool ebcdic
+
+# IDSOUT header parameters
+char label[SZ_IDSTITLE] # Record label
+int record # Record number
+int uttime # UT time in seconds
+int st # Siderial time in seconds
+real ra # Right Ascension in hours
+real dec # Declination in degrees
+real ha # Hour angle in hours
+real airmass # Air mass
+int itime # Integration time
+real wavelen1 # Wavelength of first pixel
+real dispersion # Dispersion per pixel
+
+int i, rec_no, df, sm, qf, qd, bs, co
+pointer sp, padline, bufline
+
+int strmatch(), imgeti()
+
+begin
+ call smark (sp)
+ call salloc (padline, SZ_LINE, TY_CHAR)
+ call salloc (bufline, SZ_LINE, TY_CHAR)
+
+ # Fill in header parameters.
+
+ call strcpy (TITLE(sh), label, SZ_IDSTITLE)
+
+ # The following two calculations were causing floating overflows
+ # when the header values were indefinite. SEH 7-23-86
+ if (IS_INDEF(UT(sh)))
+ uttime = INDEFI
+ else
+ uttime = UT(sh) * 3600.
+
+ if (IS_INDEF(ST(sh)))
+ st = INDEFI
+ else
+ st = ST(sh) * 3600.
+
+ ra = RA(sh)
+ dec = DEC(sh)
+ ha = HA(sh)
+ airmass = AM(sh)
+ itime = IT(sh)
+ wavelen1 = W0(sh)
+ dispersion = WP(sh)
+
+ iferr (df = imgeti (IM(sh), "DF-FLAG"))
+ df = -1
+ iferr (sm = imgeti (IM(sh), "SM-FLAG"))
+ sm = -1
+ iferr (qf = imgeti (IM(sh), "QF-FLAG"))
+ qf = -1
+ iferr (qd = imgeti (IM(sh), "QD-FLAG"))
+ qd = -1
+ iferr (bs = imgeti (IM(sh), "BS-FLAG"))
+ bs = -1
+ iferr (co = imgeti (IM(sh), "CO-FLAG"))
+ co = -1
+
+ # Create a padding line to fill the IDSOUT block to 1024 points.
+
+ call sprintf (Memc[padline], SZ_LINE,
+ "%10.4e%10.4e%10.4e%10.4e%10.4e%10.4e%10.4e%10.4e\n")
+ do i = 1, 8
+ call pargr (0.)
+
+ # Line 1 -- Record number, etc.
+ rec_no = strmatch (image, ".")
+ call sscan (image[rec_no])
+ call gargi (record)
+
+ call sprintf (Memc[bufline], SZ_LINE,
+ "%5d%5d%15.7e%15.7e%5d%5d%5d%5d%5d%5d%10d")
+ call pargi (record)
+ call pargi (itime)
+ call pargr (wavelen1)
+ call pargr (dispersion)
+ call pargi (0)
+ call pargi (SN(sh))
+ call pargi (BEAM(sh))
+ call pargi (-1)
+ call pargi (-1)
+ call pargi (0)
+ call pargi (uttime)
+
+ call putcard (mfd, Memc[bufline], ebcdic)
+
+ # Line 2 -- Siderial time, RA, and Dec.
+
+ call sprintf (Memc[bufline], SZ_LINE,
+ "%10d%15.7e%15.7e%5d%5d%5d%5d%5d%5d%5d%5d")
+ call pargi (st)
+ call pargr (ra)
+ call pargr (dec)
+ call pargi (0)
+ call pargi (df)
+ call pargi (sm)
+ call pargi (qf)
+ call pargi (DC(sh))
+ call pargi (qd)
+ call pargi (EC(sh))
+ call pargi (bs)
+
+ call putcard (mfd, Memc[bufline], ebcdic)
+
+ # Line 3 -- Hour angle, air mass, UT date, and exposure title.
+
+ call sprintf (Memc[bufline], SZ_LINE,
+ "%5d%5d%2w%-3.3s%5d%15.7e%15.7e%27wEND")
+ call pargi (FC(sh))
+ call pargi (co)
+ call pargstr ("IRF")
+ call pargi (OFLAG(sh))
+ call pargr (ha)
+ call pargr (airmass)
+
+ call putcard (mfd, Memc[bufline], ebcdic)
+
+ # Line 4 -- Record label.
+ call sprintf (Memc[bufline], SZ_LINE, "%-77sEND")
+ call pargstr (TITLE(sh))
+
+ call putcard (mfd, Memc[bufline], ebcdic)
+
+ # Lines 5 to 132
+
+ call putdata (mfd, Memr[SY(sh)], SN(sh), Memc[padline],
+ Memc[bufline], ebcdic)
+
+ # Line 133 -- Blank line
+
+ call sprintf (Memc[bufline], SZ_LINE, "%80w")
+ call putcard (mfd, Memc[bufline], ebcdic)
+end
+
+
+# PUTDATA -- Format and output extraction data to IDSOUT length of 1024 points.
+# Special effort is made to make the zero padding efficient.
+
+procedure putdata (mfd, data, npts, padline, bufline, ebcdic)
+
+int mfd # IDSOUT file descriptor
+real data[npts] # Data
+int npts # Number of data points
+char padline[ARB] # Padding string
+char bufline[ARB] # Output buffer string
+bool ebcdic # Convert to ebcdic
+
+int i, j, k, l, n
+int index
+double ddata
+
+int dtoc3()
+
+begin
+ j = min (1024, npts) # Maximum number of data points
+ k = j / 8 * 8 # Index of last data point in last complete line
+ if (k < j)
+ l = k + 8 # Index of last point in last line with data
+ else
+ l = k
+
+ # Write all complete data lines.
+
+ index = 1
+ do i = 1, k {
+ ddata = double (data[i])
+ n = dtoc3 (ddata, bufline[index], 10, 4, 'e', 10)
+ while (n < 10) {
+ bufline[index+n] = ' '
+ n = n + 1
+ }
+ index = index + 10
+ if (mod (i, 8) == 0) {
+ call putcard (mfd, bufline, ebcdic)
+ index = 1
+ }
+ }
+
+ # Write partial data line.
+
+ index = 1
+ do i = k + 1, l {
+ if (i <= j) {
+ ddata = double (data[i])
+ n = dtoc3 (ddata, bufline[index], 11, 5, 'e', 10)
+ } else
+ n = dtoc3 (0.D0, bufline[index], 11, 5, 'e', 10)
+ while (n < 10) {
+ bufline[index+n] = ' '
+ n = n + 1
+ }
+ index = index + 10
+ if (mod (i, 8) == 0) {
+ call putcard (mfd, bufline, ebcdic)
+ index = 1
+ }
+ }
+
+ # Write remaining padding lines.
+
+ do i = l + 1, 1024, 8
+ call putcard (mfd, padline, ebcdic)
+end
+
+# PUTCARD -- Convert to ebcdic if desired and write out card
+
+procedure putcard (mfd, bufline, ebcdic)
+
+int mfd
+char bufline[ARB]
+bool ebcdic
+
+char packline[SZ_LINE]
+
+begin
+ if (ebcdic) {
+ call ascii_to_ebcdic (bufline, packline, SZ_CARD)
+ call achtsb (packline, packline, SZ_CARD)
+ } else
+ call chrpak (bufline, 1, packline, 1, SZ_CARD)
+
+ call write (mfd, packline, SZ_CARD/SZB_CHAR)
+end
generated by cgit (git 2.34.1) at 2025-09-20 07:17:30 -0400