1 files changed, 455 insertions, 0 deletions
diff --git a/noao/obsutil/src/sptime/stdisperser.x b/noao/obsutil/src/sptime/stdisperser.x
new file mode 100644
index 00000000..090cf010
--- /dev/null
+++ b/noao/obsutil/src/sptime/stdisperser.x
@@ -0,0 +1,455 @@
+include	"sptime.h"
+
+# These routines interface between any type of disperser and the
+# disperser type specific routines (such as those for gratings).
+
+
+# ST_DISPERSER -- Initialize disperser data.
+
+procedure st_disperser (st, name, index)
+
+pointer st		#I SPECTIME pointer
+char	name[ARB]	#I Table name
+int	index		#I Grating index
+
+int	order, oref, stgeti(), tabgeti(), strdic()
+real	f, phi, g, blaze, wb, db, ref, stgetr(), tabgetr(), gr_getr()
+pointer sp, str, fname, gr, gr_open()
+bool	streq()
+errchk	gr_open, tab_getr, gr_getr, st_gtable1
+
+begin
+	call smark (sp)
+	call salloc (str, SZ_LINE, TY_CHAR)
+	call salloc (fname, SZ_LINE, TY_CHAR)
+
+	ST_GR(st,index) = NULL
+	ST_DISPTYPE(st,index) = 0
+
+	# Get disperser type.
+	if (streq (name, "disperser")) {
+	    call stgstr (st, "disptype", "disperser", "", Memc[str], SZ_LINE)
+	    if (Memc[str] == EOS) {
+		iferr (call tabgstr (ST_TAB(st), "disperser", "spectrograph",
+		    "type", Memc[str], SZ_LINE))
+		    call strcpy ("generic", Memc[str], SZ_LINE)
+	    }
+	} else if (streq (name, "xdisperser")) {
+	    call stgstr (st, "xdisptype", "xdisperser", "", Memc[str], SZ_LINE)
+	    if (Memc[str] == EOS) {
+		iferr (call tabgstr (ST_TAB(st), "xdisperser", "spectrograph",
+		    "type", Memc[str], SZ_LINE))
+		    Memc[str] = EOS
+	    }
+	} else
+	    Memc[str] = EOS
+	ST_DISPTYPE(st,index) = strdic (Memc[str],Memc[str],SZ_LINE,DISPTYPES)
+
+	switch (ST_DISPTYPE(st,index)) {
+	case GRATING:
+	    f = ST_CAMFL(st) * 1000
+	    switch (index) {
+	    case 1:
+		g = stgetr (st, "gmm", name, INDEFR)
+		blaze = stgetr (st, "blaze", name, INDEFR)
+		oref = stgeti (st, "oref", name, 1)
+		wb = stgetr (st, "wavelength", name, INDEFR)
+		db = stgetr (st, "dispersion", name, INDEFR)
+		ref = stgetr (st, "eff", name, INDEFR)
+	    case 2:
+		g = stgetr (st, "xgmm", name, INDEFR)
+		blaze = stgetr (st, "xblaze", name, INDEFR)
+		oref = stgeti (st, "xoref", name, 1)
+		wb = stgetr (st, "xwavelength", name, INDEFR)
+		db = stgetr (st, "xdispersion", name, INDEFR)
+		ref = stgetr (st, "xeff", name, INDEFR)
+
+		# Check old names.
+		if (IS_INDEFR(g)) {
+		    iferr (g = tabgetr (ST_TAB(st), name, "spectrograph",
+			"gmm"))
+		    g = INDEFR
+		}
+	    }
+
+	    # Old names.
+	    if (IS_INDEFR(g)) {
+		iferr (g = tabgetr (ST_TAB(st), name, "spectrograph",
+		    "gmm"))
+		    g = INDEFR
+	    }
+	    if (IS_INDEFR(blaze)) {
+		iferr (blaze = tabgetr (ST_TAB(st), name, "spectrograph",
+		    "blaze"))
+		    blaze = INDEFR
+	    }
+	    if (IS_INDEFI(oref)) {
+		iferr (oref = tabgeti (ST_TAB(st), name, "spectrograph",
+		    "oref"))
+		    oref = 1
+	    }
+	    if (IS_INDEFR(wb)) {
+		iferr (wb = tabgetr (ST_TAB(st), name, "spectrograph",
+		    "wavelength"))
+		    wb = INDEFR
+	    }
+	    if (IS_INDEFR(db)) {
+		iferr (db = tabgetr (ST_TAB(st), name, "spectrograph",
+		    "dispersion"))
+		    db = INDEFR
+	    }
+	    if (IS_INDEFR(ref)) {
+		iferr (ref = tabgetr (ST_TAB(st), name, "spectrograph",
+		    "reflectance"))
+		    ref = 1.
+	    }
+
+	    phi = ST_INOUTA(st,index)
+#	    if (!IS_INDEFR(db))
+#		db = db / f
+
+	    iferr (gr = gr_open (ST_CW(st), ST_ORDER(st,index), ref, wb, db,
+		oref, f, g, blaze, 1., phi, INDEF, INDEF, 1, YES)) {
+		g = 300.
+		blaze = 6
+	        gr = gr_open (ST_CW(st), ST_ORDER(st,index), ref, wb, db,
+		    oref, f, g, blaze, 1., phi, INDEF, INDEF, 1, YES)
+	    }
+	    ST_GR(st,index) = gr
+
+	    if (IS_INDEF(ST_CW(st)))
+		ST_CW(st,index) = gr_getr (gr, "wavelength")
+	    if (IS_INDEFI(ST_ORDER(st,index)))
+		ST_ORDER(st,index) = nint (gr_getr (gr, "order"))
+	    ST_DISP(st,index) = gr_getr (gr, "dblaze") * oref * f
+
+	    # Look for explicit blaze functions.
+	    do order = ST_ORDER(st,index)-1, ST_ORDER(st,index)+1 {
+		call sprintf (Memc[str], SZ_LINE, "eff%d")
+		    call pargi (order)
+		ifnoerr (call tabgstr (ST_TAB(st), name, "spectrograph",
+		    Memc[str], Memc[fname], SZ_LINE)) {
+		    if (streq (name, "disperser"))
+			call st_gtable1 (st, Memc[str], Memc[fname])
+		    else if (streq (name, "xdisperser")) {
+			call sprintf (Memc[str], SZ_LINE, "xeff%d")
+			    call pargi (order)
+			call st_gtable1 (st, Memc[str], Memc[fname])
+		    }
+		}
+	    }
+	case GRISM:
+	    f = ST_CAMFL(st) * 1000
+	    switch (index) {
+	    case 1:
+		g = stgetr (st, "gmm", name, INDEFR)
+		blaze = stgetr (st, "blaze", name, INDEFR)
+		ref = stgetr (st, "eff", name, 1.)
+		db = stgetr (st, "indexref", name, INDEFR)
+		if (!IS_INDEFI(ST_ORDER(st,index)) && ST_ORDER(st,index)!=1) {
+		    call sprintf (Memc[str], SZ_LINE, "index%d")
+			call pargi (ST_ORDER(st,index))
+		    iferr (wb = tabgetr (ST_TAB(st), name, "spectrograph",
+			Memc[str]))
+			wb = db
+		    db = wb
+		}
+	    case 2:
+		g = stgetr (st, "xgmm", name, INDEFR)
+		blaze = stgetr (st, "xblaze", name, INDEFR)
+		ref = stgetr (st, "xeff", name, 1.)
+		db = stgetr (st, "xindexref", name, INDEFR)
+		if (!IS_INDEFI(ST_ORDER(st,index)) && ST_ORDER(st,index)!=1) {
+		    call sprintf (Memc[str], SZ_LINE, "index%d")
+			call pargi (ST_ORDER(st,index))
+		    iferr (wb = tabgetr (ST_TAB(st), name, "spectrograph",
+			Memc[str]))
+			wb = db
+		    db = wb
+		}
+	    }
+
+	    # Old names.
+	    if (IS_INDEFR(g)) {
+		iferr (g = tabgetr (ST_TAB(st), name, "spectrograph",
+		    "gmm"))
+		    g = INDEFR
+	    }
+	    if (IS_INDEFR(blaze)) {
+		iferr (blaze = tabgetr (ST_TAB(st), name, "spectrograph",
+		    "prism"))
+		    blaze = INDEFR
+	    }
+	    if (IS_INDEFR(ref)) {
+		iferr (ref = tabgetr (ST_TAB(st), name, "spectrograph",
+		    "transmission"))
+		    ref = 1
+	    }
+	    if (IS_INDEFR(db)) {
+		if (!IS_INDEFI(ST_ORDER(st,index))) {
+		    call sprintf (Memc[str], SZ_LINE, "index%d")
+			call pargi (ST_ORDER(st,index))
+		    iferr (db = tabgetr (ST_TAB(st), name, "spectrograph",
+			Memc[str]))
+			db = tabgetr (ST_TAB(st), name, "spectrograph",
+			    "index1")
+		} else
+		    db = tabgetr (ST_TAB(st), name, "spectrograph", "index1")
+	    }
+	    oref = 1
+
+	    iferr (gr = gr_open (ST_CW(st), ST_ORDER(st,index), ref, INDEF,
+		INDEF, oref, f, g, blaze, db, 0., blaze, blaze, 1, YES)) {
+		g = 300.
+		blaze = 6.
+		gr = gr_open (ST_CW(st), ST_ORDER(st,index), ref, INDEF,
+		    INDEF, oref, f, g, blaze, db, 0., blaze, blaze, 1, YES)
+	    }
+
+	    ST_GR(st,index) = gr
+
+	    if (IS_INDEF(ST_CW(st)))
+		ST_CW(st,index) = gr_getr (gr, "wavelength")
+	    if (IS_INDEFI(ST_ORDER(st,index)))
+		ST_ORDER(st,index) = nint (gr_getr (gr, "order"))
+	    ST_DISP(st,index) = gr_getr (gr, "dblaze") * oref * f
+
+	    # Look for explicit blaze functions.
+	    do order = ST_ORDER(st,index)-1, ST_ORDER(st,index)+1 {
+		call sprintf (Memc[str], SZ_LINE, "eff%d")
+		    call pargi (order)
+		ifnoerr (call tabgstr (ST_TAB(st), name, "spectrograph",
+		    Memc[str], Memc[fname], SZ_LINE)) {
+		    if (streq (name, "disperser"))
+			call st_gtable1 (st, Memc[str], Memc[fname])
+		    else if (streq (name, "xdisperser")) {
+			call sprintf (Memc[str], SZ_LINE, "xeff%d")
+			    call pargi (order)
+			call st_gtable1 (st, Memc[str], Memc[fname])
+		    }
+		}
+	    }
+	case GENERIC:
+	    f = ST_CAMFL(st) * 1000
+	    g = INDEFR
+	    blaze = INDEFR
+	    oref = 1
+
+	    switch (index) {
+	    case 1:
+		g = INDEFR
+		blaze = INDEFR
+		oref = 1
+		wb = stgetr (st, "wavelength", name, INDEFR)
+		db = stgetr (st, "dispersion", name, INDEFR)
+		ref = stgetr (st, "eff", name, INDEFR)
+	    case 2:
+		g = INDEFR
+		blaze = INDEFR
+		oref = 1
+		wb = stgetr (st, "xwavelength", name, INDEFR)
+		db = stgetr (st, "xdispersion", name, INDEFR)
+		ref = stgetr (st, "xeff", name, INDEFR)
+	    }
+
+	    if (IS_INDEFR(wb)) {
+		iferr (wb = tabgetr (ST_TAB(st), name, "spectrograph",
+		    "wavelength"))
+		    wb = INDEFR
+	    }
+	    if (IS_INDEFR(db)) {
+		iferr (db = tabgetr (ST_TAB(st), name, "spectrograph",
+		    "dispersion"))
+		    db = INDEFR
+	    }
+	    if (IS_INDEFR(ref)) {
+		iferr (ref = tabgetr (ST_TAB(st), name, "spectrograph",
+		    "reflectance"))
+		    ref = 1.
+	    }
+
+	    phi = ST_INOUTA(st,index)
+
+	    gr = gr_open (ST_CW(st), ST_ORDER(st,index), ref, wb, db,
+		oref, f, g, blaze, 1., phi, INDEF, INDEF, 1, NO)
+	    ST_GR(st,index) = gr
+
+	    if (IS_INDEF(ST_CW(st)))
+		ST_CW(st,index) = gr_getr (gr, "wavelength")
+	    if (IS_INDEFI(ST_ORDER(st,index)))
+		ST_ORDER(st,index) = nint (gr_getr (gr, "order"))
+	    ST_DISP(st,index) = gr_getr (gr, "dblaze") * oref * f
+
+	    # Look for explicit blaze functions.
+	    do order = ST_ORDER(st,index)-1, ST_ORDER(st,index)+1 {
+		call sprintf (Memc[str], SZ_LINE, "eff%d")
+		    call pargi (order)
+		ifnoerr (call tabgstr (ST_TAB(st), name, "spectrograph",
+		    Memc[str], Memc[fname], SZ_LINE)) {
+		    if (streq (name, "disperser"))
+			call st_gtable1 (st, Memc[str], Memc[fname])
+		    else if (streq (name, "xdisperser")) {
+			call sprintf (Memc[str], SZ_LINE, "xeff%d")
+			    call pargi (order)
+			call st_gtable1 (st, Memc[str], Memc[fname])
+		    }
+		}
+	    }
+	}
+
+	call sfree (sp)
+end
+
+
+# ST_DISPEFF -- Return disperser efficiency.
+
+real procedure st_dispeff (st, name, wave, order)
+
+pointer st		#I SPECTIME pointer
+char	name[ARB]	#I Table name
+real	wave		#I Wavelength
+int	order		#I Order
+real	eff		#O Efficiency
+
+real	w
+pointer	sp, tab, str
+
+int	tabgeti()
+real	tabinterp1(), tabgetr(), gr_eff()
+bool	tabexists(), streq()
+errchk	tabinterp1, gr_eff
+
+begin
+	tab = ST_TAB(st)
+	eff = INDEF
+
+	if (streq (name, "disperser") && ST_DISPTYPE(st,1) == 0)
+	    return (eff)
+	if (streq (name, "xdisperser") && ST_DISPTYPE(st,2) == 0)
+	    return (eff)
+
+	call smark (sp)
+	call salloc (str, SZ_FNAME, TY_CHAR)
+	if (streq (name, "disperser")) {
+	    call sprintf (Memc[str], SZ_FNAME, "eff%d")
+		call pargi (order)
+	    if (!tabexists (tab, Memc[str])) {
+		if (order == 1 && tabexists (tab, name)) {
+		    if (tabgeti (tab, name, "", "table.ndim") != 0)
+			call strcpy (name, Memc[str], SZ_FNAME)
+		}
+	    }
+	    if (tabexists (tab, Memc[str])) {
+		eff = tabinterp1 (tab, Memc[str], wave)
+		w = max (tabgetr (tab, Memc[str], "", "table.xmin"), wave)
+		w = min (tabgetr (tab, Memc[str], "", "table.xmax"), w)
+		if (w != wave) {
+		    eff = tabinterp1 (tab, Memc[str], w) /
+		        gr_eff (ST_GR(st,1), w, order)
+		    eff = eff * gr_eff (ST_GR(st,1), wave, order)
+		}
+	    } else
+		eff = gr_eff (ST_GR(st,1), wave, order)
+	} else if (streq (name, "xdisperser")) {
+	    call sprintf (Memc[str], SZ_FNAME, "xeff%d")
+		call pargi (order)
+	    if (!tabexists (tab, Memc[str])) {
+		if (order == 1 && tabexists (tab, name)) {
+		    if (tabgeti (tab, name, "", "table.ndim") != 0)
+			call strcpy (name, Memc[str], SZ_FNAME)
+		}
+	    }
+	    if (tabexists (tab, Memc[str])) {
+		eff = tabinterp1 (tab, Memc[str], wave)
+		w = max (tabgetr (tab, Memc[str], "", "table.xmin"), wave)
+		w = min (tabgetr (tab, Memc[str], "", "table.xmax"), w)
+		if (w != wave) {
+		    eff = tabinterp1 (tab, Memc[str], w) /
+		        gr_eff (ST_GR(st,2), w, order)
+		    eff = eff * gr_eff (ST_GR(st,2), wave, order)
+		}
+	    } else
+		eff = gr_eff (ST_GR(st,2), wave, order)
+	}
+
+	if (IS_INDEF(eff))
+	    eff = 0.
+
+	call sfree (sp)
+	return (eff)
+end
+
+
+# ST_X2W -- Return wavelength at given position on detector.
+
+real procedure st_x2w (st, index, x)
+
+pointer st		#I SPECTIME pointer
+int	index		#I Grating index
+real	x		#I Detector position (mm from center)
+real	w		#O Wavelength (Angstroms)
+
+real	gr_x2w()
+
+begin
+	switch (ST_DISPTYPE(st,index)) {
+	case GRATING:
+	    w = gr_x2w (ST_GR(st,index), x, ST_ORDER(st,index)) 
+	case GRISM:
+	    w = gr_x2w (ST_GR(st,index), x, ST_ORDER(st,index)) 
+	case GENERIC:
+	    w = gr_x2w (ST_GR(st,index), x, ST_ORDER(st,index)) 
+	}
+
+	return (w)
+end
+
+
+# ST_W2X -- Return wavelength at given position on detector.
+
+real procedure st_w2x (st, index, w)
+
+pointer st		#I SPECTIME pointer
+int	index		#I Grating index
+real	w		#I Wavelength (Angstroms)
+real	x		#O Detector position (mm from center)
+
+real	gr_w2x()
+
+begin
+	switch (ST_DISPTYPE(st,index)) {
+	case GRATING:
+	    x = gr_w2x (ST_GR(st,index), w, ST_ORDER(st,index)) 
+	case GRISM:
+	    x = gr_w2x (ST_GR(st,index), w, ST_ORDER(st,index)) 
+	case GENERIC:
+	    x = gr_w2x (ST_GR(st,index), w, ST_ORDER(st,index)) 
+	}
+
+	return (x)
+end
+
+
+# ST_W2DW -- Return dispersion on detector at given wavelength.
+
+real procedure st_w2dw (st, index, w)
+
+pointer st		#I SPECTIME pointer
+int	index		#I Grating index
+real	w		#I Wavelength (Angstroms)
+real	d		#I Dispersion (Angstroms/mm)
+
+real	gr_w2dw()
+
+begin
+	switch (ST_DISPTYPE(st,index)) {
+	case GRATING:
+	    d = gr_w2dw (ST_GR(st,index), w, ST_ORDER(st,index)) 
+	case GRISM:
+	    d = gr_w2dw (ST_GR(st,index), w, ST_ORDER(st,index)) 
+	case GENERIC:
+	    d = gr_w2dw (ST_GR(st,index), w, ST_ORDER(st,index)) 
+	}
+
+	return (d)
+end