1 files changed, 428 insertions, 0 deletions

diff --git a/noao/onedspec/t_sapertures.x b/noao/onedspec/t_sapertures.x
new file mode 100644
index 00000000..4aa0c16f
--- /dev/null
+++ b/noao/onedspec/t_sapertures.x
@@ -0,0 +1,428 @@
+include	<error.h>
+include	<imhdr.h>
+include	<smw.h>
+
+define	LEN_SAP		52		# Length of structure
+define	LEN_SAPTITLE	79		# Length of title
+
+define	AP	Memi[$1]		# Aperture number
+define	BEAM	Memi[$1+1]		# Beam number
+define	DTYPE	Memi[$1+2]		# Dispersion type
+define	W1	Memd[P2D($1+4)]		# Starting wavelength
+define	DW	Memd[P2D($1+6)]		# Wavelength per pixel
+define	Z	Memd[P2D($1+8)]		# Doppler factor
+define	APLOW	Memr[P2R($1+10)]	# Low aperture
+define	APHIGH	Memr[P2R($1+11)]	# High aperture
+define	TITLE	Memc[P2C($1+12)]	# Title
+ 
+ 
+# T_SAPERTURES -- Set aperture beam numbers and titles.
+ 
+procedure t_sapertures()
+ 
+int	list			# Input list
+bool	wcsreset		# Reset WCS?
+bool	verbose			# Verbose?
+pointer	saps			# Pointer to array of aperture structures
+ 
+int	imtopenp(), imtgetim()
+bool	clgetb()
+pointer	sp, input, ranges, tmp, im, mw, rng_open(), immap(), smw_openim()
+errchk	sap_gids, immap, smw_openim
+ 
+begin
+	call smark (sp)
+	call salloc (input, SZ_FNAME, TY_CHAR)
+
+	list = imtopenp ("input")
+	wcsreset = clgetb ("wcsreset")
+	verbose = clgetb ("verbose")
+	call clgstr ("apertures", Memc[input], SZ_FNAME)
+	iferr (ranges = rng_open (Memc[input], INDEF, INDEF, INDEF))
+	    call error (0, "Bad aperture list")
+
+	call sap_gids (saps, wcsreset, verbose)
+	
+	while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) {
+	    im = NULL
+	    mw = NULL
+	    iferr {
+	        tmp = immap (Memc[input], READ_WRITE, 0); im = tmp
+		tmp = smw_openim (im); mw = tmp
+		if (SMW_FORMAT(mw) != SMW_ES && SMW_FORMAT(mw) != SMW_MS)
+		    call error (1, "Wrong spectrum format")
+		call sap_ms (im, mw, Memc[input], ranges, saps, verbose)
+	    } then
+		call erract (EA_WARN)
+
+	    if (mw != NULL) {
+		call smw_saveim (mw, im)
+		call smw_close (mw)
+	    }
+	    if (im != NULL)
+		call imunmap (im)
+	}
+
+	call rng_close (ranges)
+	call imtclose (list)
+	call sap_fids (saps)
+	call sfree (sp)
+end
+
+
+# SAP_MS -- Set aperture information
+
+procedure sap_ms (im, mw, input, ranges, saps, verbose)
+
+pointer	im			# IMIO pointer
+pointer	mw			# SMW pointer
+char	input[ARB]		# Image name
+pointer	ranges			# Aperture range list
+pointer	saps			# Pointer to array of aperture structures
+bool	verbose			# Verbose?
+
+int	i, naps, ap, beam, dtype, nw, obeam, odtype
+double	w1, dw, z, ow1, odw, oz
+real	aplow[2], aphigh[2], oaplow[2], oaphigh[2]
+bool	newtitle, streq(), rng_elementi()
+pointer	sp, title, coeff, sap
+
+begin
+	call smark (sp)
+	call salloc (title, SZ_LINE, TY_CHAR)
+	coeff = NULL
+ 
+	# Go through each spectrum and change the selected apertures.
+	naps = -1
+	do i = 1, SMW_NSPEC(mw) {
+	    # Get aperture info
+	    iferr (call smw_gwattrs (mw, i, 1, ap, beam, dtype, w1, dw, nw, z,
+		aplow, aphigh, coeff))
+		break
+
+	    # Check if aperture is to be changed
+	    if (!rng_elementi (ranges, ap))
+		next
+
+	    # Check for aperture info
+	    for (sap = saps; Memi[sap] != NULL; sap = sap + 1)
+		if (ap == AP(Memi[sap]))
+		    break
+	    if (Memi[sap] == NULL) {
+		for (sap = saps; Memi[sap] != NULL; sap = sap + 1)
+		    if (IS_INDEFI (AP(Memi[sap])))
+			break
+	    }
+	    if (Memi[sap] == NULL)
+		next
+
+	    # Get aperture title
+	    call smw_gapid (mw, i, 1, Memc[title], SZ_LINE)
+
+	    # Set new aperture values
+	    sap = Memi[sap]
+	    obeam = BEAM(sap)
+	    odtype = DTYPE(sap)
+	    ow1 = W1(sap)
+	    odw = DW(sap)
+	    oz = Z(sap)
+	    oaplow[1] = APLOW(sap)
+	    oaphigh[1] = APHIGH(sap)
+	    oaplow[2] = INDEF
+	    oaphigh[2] = INDEF
+
+	    if (IS_INDEFI (obeam))
+		obeam = beam
+	    if (IS_INDEFI (odtype))
+		odtype = dtype
+	    else
+		odtype = max (-1, min (1, odtype))
+	    if (IS_INDEFD (ow1))
+		ow1 = w1
+	    if (IS_INDEFD (odw))
+		odw = dw
+	    if (IS_INDEFD (oz))
+		oz = z
+	    if (IS_INDEF (oaplow[1]))
+		oaplow[1] = aplow[1]
+	    if (IS_INDEF (oaphigh[1]))
+		oaphigh[1] = aphigh[1]
+	    if (streq (TITLE(sap), "INDEF") || TITLE(sap) == EOS)
+		newtitle = false
+	    else
+		newtitle = !streq (TITLE(sap), Memc[title])
+
+	    if (dtype == 2 && odtype != 2)
+		Memc[coeff] = EOS
+
+	    # Make change if needed
+	    if (obeam!=beam || odtype!=dtype || ow1!=w1 || odw !=dw || oz!=z ||
+		oaplow[1]!=aplow[1] || oaphigh[1]!=aphigh[1] || newtitle) {
+		call smw_swattrs (mw, i, 1, ap, obeam, odtype, ow1, odw, nw,
+		    oz, oaplow, oaphigh, Memc[coeff])
+		if (newtitle)
+		    call smw_sapid (mw, i, 1, TITLE(sap))
+		naps = naps + 1
+
+		# Make record
+		if (verbose) {
+		    if (naps == 0) {
+			call printf ("%s:\n")
+			    call pargstr (input)
+			naps = naps + 1
+		    }
+		    call printf ("  Aperture %d:\n")
+			call pargi (ap)
+		    if (obeam != beam) {
+			call printf ("    beam %d --> %d\n")
+			    call pargi (beam)
+			    call pargi (obeam)
+		    }
+		    if (odtype != dtype) {
+			call printf ("    dtype %d --> %d\n")
+			    call pargi (dtype)
+			    call pargi (odtype)
+		    }
+		    if (ow1 != w1) {
+			call printf ("    w1 %g --> %g\n")
+			    call pargd (w1)
+			    call pargd (ow1)
+		    }
+		    if (odw != dw) {
+			call printf ("    dw %g --> %g\n")
+			    call pargd (dw)
+			    call pargd (odw)
+		    }
+		    if (oz != z) {
+			call printf ("    z %g --> %g\n")
+			    call pargd (z)
+			    call pargd (oz)
+		    }
+		    if (oaplow[1] != aplow[1]) {
+			call printf ("    aplow %g --> %g\n")
+			    call pargr (aplow[1])
+			    call pargr (oaplow[1])
+		    }
+		    if (oaphigh[1] != aphigh[1]) {
+			call printf ("    aphigh %g --> %g\n")
+			    call pargr (aphigh[1])
+			    call pargr (oaphigh[1])
+		    }
+		    if (newtitle) {
+			call printf ("    apid %s --> %s\n")
+			    call pargstr (Memc[title])
+			    call pargstr (TITLE(sap))
+		    }
+		}
+	    }
+	}
+
+	call mfree (coeff, TY_CHAR)
+	call sfree (sp)
+end
+
+
+# SA_GIDS -- Get user aperture ID's.
+
+procedure sap_gids (saps, wcsreset, verbose)
+
+pointer	saps			# Pointer to array of aperture structures
+bool	wcsreset		# Reset WCS?
+bool	verbose			# Verbose (negative beam warning)?
+pointer	sap
+
+int	naps, ap, beam, fd, nalloc
+double	ra, dec
+pointer	sp, str, key, im, list
+
+real	clgetr()
+double	clgetd()
+int	nowhite(), open(), fscan(), nscan(), clgeti()
+pointer	immap(), imofnlu(), imgnfn()
+errchk	open
+
+begin
+
+	# If resetting ignore the APIDTABLE and the task parameters.
+	if (wcsreset) {
+	    call malloc (saps, 2, TY_POINTER)
+	    call malloc (Memi[saps], LEN_SAP, TY_STRUCT)
+	    Memi[saps+1] = NULL
+
+	    sap = Memi[saps]
+	    AP(sap) = INDEFI
+	    BEAM(sap) = INDEFI
+	    DTYPE(sap) = -1
+	    W1(sap) = 1.
+	    DW(sap) = 1.
+	    Z(sap) = 0.
+	    APLOW(sap) = INDEF
+	    APHIGH(sap) = INDEF
+	    TITLE(sap) = EOS
+	    return
+	}
+
+	call smark (sp)
+	call salloc (str, SZ_LINE, TY_CHAR)
+	call salloc (key, SZ_FNAME, TY_CHAR)
+	call clgstr ("apidtable", Memc[str], SZ_LINE)
+
+	# Set parameters from an APIDTABLE if given.
+	naps = 0
+	if (nowhite (Memc[str], Memc[str], SZ_LINE) > 0) {
+	    iferr {
+		# Read aperture information from an image.
+		ifnoerr (im = immap (Memc[str], READ_ONLY, 0)) {
+		    list = imofnlu (im, "SLFIB[0-9]*")
+		    while (imgnfn (list, Memc[key], SZ_FNAME) != EOF) {
+			call imgstr (im, Memc[key], Memc[str], SZ_LINE)
+			call sscan (Memc[str])
+			call gargi (ap)
+			call gargi (beam)
+			if (nscan() < 2)
+			    next
+			if (!IS_INDEFI(beam) && beam < 0 && verbose) {
+			    call eprintf (
+			    "Negative beam number for aperture %d ignored.\n") 
+				call pargi (ap)
+			    beam = INDEFI
+			}
+			if (naps == 0) {
+			    nalloc = 50
+			    call malloc (saps, nalloc, TY_POINTER)
+			} else if (naps == nalloc) {
+			    nalloc = nalloc + 50
+			    call realloc (saps, nalloc, TY_POINTER)
+			}
+			call malloc (Memi[saps+naps], LEN_SAP, TY_STRUCT)
+
+			sap = Memi[saps+naps]
+			AP(sap) = ap
+			BEAM(sap) = beam
+			call gargd (ra)
+			call gargd (dec)
+                        if (nscan() != 4) {
+                            call reset_scan ()
+                            call gargi (ap)
+                            call gargi (beam)
+			    call gargstr (TITLE(sap), LEN_SAPTITLE)
+                        } else {
+                            Memc[str] = EOS
+                            call gargstr (Memc[str], SZ_LINE)
+                            call xt_stripwhite (Memc[str])
+                            if (Memc[str] == EOS) {
+                                call sprintf (TITLE(sap), LEN_SAPTITLE,
+                                    "(%.2h %.2h)")
+                                    call pargd (ra)
+                                    call pargd (dec)
+                            } else {
+                                call sprintf (TITLE(sap), LEN_SAPTITLE,
+                                    "%s (%.2h %.2h)")
+                                    call pargstr (Memc[str])
+                                    call pargd (ra)
+                                    call pargd (dec)
+                            }
+                        }
+			DTYPE(sap) = INDEFI
+			W1(sap) = INDEFD
+			DW(sap) = INDEFD
+			Z(sap) = INDEFD
+			APLOW(sap) = INDEF
+			APHIGH(sap) = INDEF
+			call xt_stripwhite (TITLE(sap))
+			naps = naps + 1
+		    }	
+		    call imcfnl (list)
+		    call imunmap (im)
+
+		# Read aperture information from a file.
+		} else {
+		    fd = open (Memc[str], READ_ONLY, TEXT_FILE)
+		    while (fscan (fd) != EOF) {
+			call gargi (ap)
+			call gargi (beam)
+			if (nscan() < 2)
+			    next
+			if (!IS_INDEFI(beam) && beam < 0 && verbose) {
+			    call eprintf (
+			    "Negative beam number for aperture %d ignored.\n") 
+				call pargi (ap)
+			    beam = INDEFI
+			}
+			if (naps == 0) {
+			    nalloc = 50
+			    call malloc (saps, nalloc, TY_POINTER)
+			} else if (naps == nalloc) {
+			    nalloc = nalloc + 50
+			    call realloc (saps, nalloc, TY_POINTER)
+			}
+			call malloc (Memi[saps+naps], LEN_SAP, TY_STRUCT)
+
+			sap = Memi[saps+naps]
+			AP(sap) = ap
+			BEAM(sap) = beam
+			call gargi (DTYPE(sap))
+			call gargd (W1(sap))
+			call gargd (DW(sap))
+			call gargd (Z(sap))
+			call gargr (APLOW(sap))
+			call gargr (APHIGH(sap))
+			call gargstr (TITLE(sap), LEN_SAPTITLE)
+			if (nscan() < 9) {
+			    call reset_scan()
+			    call gargi (AP(sap))
+			    call gargi (BEAM(sap))
+			    if (!IS_INDEFI(BEAM(sap)) && BEAM(sap) < 0)
+				BEAM(sap) = INDEFI
+			    call gargstr (TITLE(sap), LEN_SAPTITLE)
+			    DTYPE(sap) = INDEFI
+			    W1(sap) = INDEFD
+			    DW(sap) = INDEFD
+			    Z(sap) = INDEFD
+			    APLOW(sap) = INDEF
+			    APHIGH(sap) = INDEF
+			}
+			call xt_stripwhite (TITLE(sap))
+			naps = naps + 1
+		    }	
+		    call close (fd)
+		}
+	    } then
+		call erract (EA_WARN)
+	}
+
+	# Set remaining default parameters and the list terminator.
+	call realloc (saps, naps+2, TY_INT)
+	call malloc (Memi[saps+naps], LEN_SAP, TY_STRUCT)
+	Memi[saps+naps+1] = NULL
+
+	sap = Memi[saps+naps]
+	AP(sap) = INDEFI
+	BEAM(sap) = clgeti ("beam")
+	if (!IS_INDEFI(BEAM(sap)) && BEAM(sap) < 0 && verbose) {
+	    call eprintf (
+		"Negative default beam number ignored.\n") 
+	    BEAM(sap) = INDEFI
+	}
+	DTYPE(sap) = clgeti ("dtype")
+	W1(sap) = clgetd ("w1")
+	DW(sap) = clgetd ("dw")
+	Z(sap) = clgetd ("z")
+	APLOW(sap) = clgetr ("aplow")
+	APHIGH(sap) = clgetr ("aphigh")
+	call clgstr ("title", TITLE(sap), LEN_SAPTITLE)
+
+	call sfree (sp)
+end
+
+
+procedure sap_fids (saps)
+
+pointer	saps			# Pointer to array of aperture structures
+pointer	sap
+
+begin
+	for (sap=saps; Memi[sap] != NULL; sap = sap + 1)
+	    call mfree (Memi[sap], TY_STRUCT)
+	call mfree (saps, TY_POINTER)
+end