Initial commit

1 files changed, 515 insertions, 0 deletions

diff --git a/noao/onedspec/identify/iddb.x b/noao/onedspec/identify/iddb.x
new file mode 100644
index 00000000..e354d1c4
--- /dev/null
+++ b/noao/onedspec/identify/iddb.x
@@ -0,0 +1,515 @@
+include	<imset.h>
+include	<math/curfit.h>
+include	<smw.h>
+include	<units.h>
+include	"identify.h"
+include	<pkg/dttext.h>
+
+
+# ID_DBREAD -- Read features data from the database.
+
+procedure id_dbread (id, name, ap, add, verbose)
+
+pointer	id				# ID pointer
+char	name[SZ_LINE]			# Image name
+int	ap[2]				# Aperture number
+int	add				# Add features?
+int	verbose				# Verbose flag
+
+int	rec, dtlocate()
+pointer	sp, line, str
+errchk	dtremap, dtlocate, id_dbread_rec
+
+begin
+	call smark (sp)
+	call salloc (line, SZ_LINE, TY_CHAR)
+
+	call strcpy ("id", Memc[line], SZ_LINE)
+	call imgcluster (name, Memc[line+2], SZ_LINE)
+	call dtremap (ID_DT(id), ID_DATABASE(id), Memc[line], READ_ONLY)
+
+	call id_dbsection (id, name, ap, ID_SECTION(id), ID_LENSTRING)
+	call sprintf (Memc[line], SZ_LINE, "identify %s%s")
+	    call pargstr (name)
+	    call pargstr (ID_SECTION(id))
+
+	iferr (rec = dtlocate (ID_DT(Id), Memc[line])) {
+	    call salloc (str, SZ_LINE, TY_CHAR)
+	    call sprintf (Memc[str], SZ_LINE, "Entry not found: %s")
+		call pargstr (Memc[line])
+	    call error (0, Memc[str])
+	}
+
+	call id_dbread_rec (id, rec, add)
+
+	if (ID_NFEATURES(id) > 0) {
+	    ID_NEWGRAPH(id) = YES
+	    ID_NEWFEATURES(id) = YES
+	    ID_CURRENT(id) = 1
+	} else
+	    ID_CURRENT(id) = 0
+
+	if (verbose == YES) {
+	    call printf ("identify %s%s\n")
+		call pargstr (name)
+		call pargstr (ID_SECTION(id))
+	}
+
+	call sfree (sp)
+end
+
+
+# ID_DBSAVE -- Read all entries from a database and save.
+
+procedure id_dbsave (id, name)
+
+pointer	id				# ID pointer
+char	name[SZ_LINE]			# Image name
+
+int	rec, dtgeti()
+pointer	sp, line, dt
+errchk	dtremap, dtgeti, id_dbread_rec, id_saveap
+
+begin
+	call smark (sp)
+	call salloc (line, SZ_FNAME, TY_CHAR)
+
+	call strcpy ("id", Memc[line], SZ_FNAME)
+	call imgcluster (name, Memc[line+2], SZ_FNAME)
+	call dtremap (ID_DT(id), ID_DATABASE(id), Memc[line], READ_ONLY)
+
+	dt = ID_DT(id)
+	do rec = 1, DT_NRECS(dt) {
+	    ID_AP(id,1) = dtgeti (dt, rec, "aperture")
+	    ID_AP(id,2) = 1
+	    call id_dbread_rec (id, rec, NO)
+	    call id_saveap (id)
+	}
+
+	call sfree (sp)
+end
+
+
+# ID_DBREAD_REC -- Read specified record from the database.
+
+procedure id_dbread_rec (id, rec, add)
+
+pointer	id				# ID pointer
+int	rec				# Database record
+int	add				# Add features?
+
+double	pix
+int	i, j, k, ncoeffs
+pointer	dt, sh, un, sp, line, coeffs
+
+int	dtgeti(), dcvstati(), dtscan(), nscan()
+real	dtgetr()
+double	dcvstatd()
+bool	un_compare()
+pointer	un_open()
+errchk	un_open, dtgeti(), dtgad()
+
+begin
+	call smark (sp)
+	call salloc (line, SZ_LINE, TY_CHAR)
+
+	dt = ID_DT(id)
+	sh = ID_SH(id)
+
+	if (add == YES) {
+	    j = dtgeti (dt, rec, "features")
+	    k = j + ID_NFEATURES(id)
+	    ID_NALLOC(id) = k
+
+	    call realloc (ID_PIX(id), k, TY_DOUBLE)
+	    call realloc (ID_FIT(id), k, TY_DOUBLE)
+	    call realloc (ID_USER(id), k, TY_DOUBLE)
+	    call realloc (ID_WTS(id), k, TY_DOUBLE)
+	    call realloc (ID_FWIDTHS(id), k, TY_REAL)
+	    call realloc (ID_FTYPES(id), k, TY_INT)
+	    call realloc (ID_LABEL(id), k, TY_POINTER)
+
+	    do i = 1, j {
+		k = dtscan (dt)
+		call gargd (pix)
+
+		ID_NFEATURES(id) = ID_NFEATURES(id) + 1
+		for (k=ID_NFEATURES(id); (k>1)&&(pix<PIX(id,k-1)); k=k-1) {
+		    PIX(id,k) = PIX(id,k-1)
+		    FIT(id,k) = FIT(id,k-1)
+		    USER(id,k) = USER(id,k-1)
+		    WTS(id,k) = WTS(id,k-1)
+		    FWIDTH(id,k) = FWIDTH(id,k-1)
+		    FTYPE(id,k) = FTYPE(id,k-1)
+		    Memi[ID_LABEL(id)+k-1] = Memi[ID_LABEL(id)+k-2]
+		}
+		PIX(id,k) = pix
+		call gargd (FIT(id,k))
+		call gargd (USER(id,k))
+		call gargr (FWIDTH(id,k))
+		call gargi (FTYPE(id,k))
+		call gargd (WTS(id,k))
+		call gargstr (Memc[line], SZ_LINE)
+		Memi[ID_LABEL(id)+k-1] = NULL
+		call id_label (Memc[line], Memi[ID_LABEL(id)+k-1])
+
+		# The following initialization is for backwards compatibility.
+		if (nscan() < 5) {
+		    FWIDTH(id,k) = ID_FWIDTH(id)
+		    FTYPE(id,k) = ID_FTYPE(id)
+		} else if (nscan() < 6)
+		    WTS(id,k) = 1.
+	    }
+
+	    if (ID_UN(id) != NULL) {
+		ifnoerr (call dtgstr (dt, rec, "units", Memc[line], SZ_LINE)) {
+		    un = un_open (Memc[line])
+		    if (!un_compare (un, ID_UN(id)) && j > 0) {
+			k = ID_NFEATURES(id) - j
+			call un_ctrand (un, ID_UN(id), FIT(id,k), FIT(id,k), j)
+			call un_ctrand (un, ID_UN(id), USER(id,k), USER(id,k),j)
+		    }
+		    call un_close (un)
+		}
+	    }
+
+	} else {
+	    if (sh != NULL) {
+		if (SMW_FORMAT(MW(sh))==SMW_ES || SMW_FORMAT(MW(sh))==SMW_MS) {
+		    iferr (APLOW(sh,1) = dtgetr (dt, rec, "aplow"))
+			APLOW(sh,1) = INDEF
+		    iferr (APHIGH(sh,1) = dtgetr (dt, rec, "aphigh"))
+			APHIGH(sh,1) = INDEF
+		}
+	    }
+
+	    do i = 1, ID_NFEATURES(id)
+		call mfree (Memi[ID_LABEL(id)+i-1], TY_CHAR)
+
+	    k = dtgeti (dt, rec, "features")
+	    ID_NFEATURES(id) = k
+	    ID_NALLOC(id) = k
+	    call realloc (ID_PIX(id), k, TY_DOUBLE)
+	    call realloc (ID_FIT(id), k, TY_DOUBLE)
+	    call realloc (ID_USER(id), k, TY_DOUBLE)
+	    call realloc (ID_WTS(id), k, TY_DOUBLE)
+	    call realloc (ID_FWIDTHS(id), k, TY_REAL)
+	    call realloc (ID_FTYPES(id), k, TY_INT)
+	    call realloc (ID_LABEL(id), k, TY_POINTER)
+
+	    do i = 1, ID_NFEATURES(id) {
+		k = dtscan (dt)
+		call gargd (PIX(id,i))
+		call gargd (FIT(id,i))
+		call gargd (USER(id,i))
+		call gargr (FWIDTH(id,i))
+		call gargi (FTYPE(id,i))
+		call gargd (WTS(id,i))
+		call gargstr (Memc[line], SZ_LINE)
+		Memi[ID_LABEL(id)+i-1] = NULL
+		call id_label (Memc[line], Memi[ID_LABEL(id)+i-1])
+
+		# The following initialization is for backwards compatibility.
+		if (nscan() < 5) {
+		    FWIDTH(id,i) = ID_FWIDTH(id)
+		    FTYPE(id,i) = ID_FTYPE(id)
+		} else if (nscan() < 6)
+		    WTS(id,i) = 1.
+	    }
+
+	    iferr (ID_SHIFT(id) = dtgetr (dt, rec, "shift"))
+		ID_SHIFT(id) = 0.
+
+	    iferr {
+		ncoeffs = dtgeti (dt, rec, "coefficients")
+		call salloc (coeffs, ncoeffs, TY_DOUBLE)
+		call dtgad (dt, rec, "coefficients", Memd[coeffs], ncoeffs,
+		    ncoeffs)
+
+		if (ID_CV(id) != NULL)
+		    call dcvfree (ID_CV(id))
+		call dcvrestore (ID_CV(id), Memd[coeffs])
+
+		call ic_putr (ID_IC(id), "xmin", real (dcvstatd(ID_CV(id),
+		    CVXMIN)))
+		call ic_putr (ID_IC(id), "xmax", real (dcvstatd(ID_CV(id),
+		    CVXMAX)))
+		ifnoerr (call dtgstr (dt,rec,"function",Memc[line],SZ_LINE)) {
+		    call ic_pstr (ID_IC(id), "function", Memc[line])
+		    call ic_puti (ID_IC(id), "order", dtgeti (dt, rec, "order"))
+		    call dtgstr (dt, rec, "sample", Memc[line], SZ_LINE)
+		    call ic_pstr (ID_IC(id), "sample", Memc[line])
+		    call ic_puti (ID_IC(id), "naverage",
+			dtgeti (dt, rec, "naverage"))
+		    call ic_puti (ID_IC(id), "niterate",
+			dtgeti (dt, rec, "niterate"))
+		    call ic_putr (ID_IC(id), "low",
+			dtgetr (dt, rec, "low_reject"))
+		    call ic_putr (ID_IC(id), "high",
+			dtgetr (dt, rec, "high_reject"))
+		    call ic_putr (ID_IC(id), "grow", dtgetr (dt, rec, "grow"))
+		} else {
+		    call ic_puti (ID_IC(id), "order", dcvstati (ID_CV(id),
+			CVORDER))
+		    switch (dcvstati (ID_CV(id), CVTYPE)) {
+		    case LEGENDRE:
+			call ic_pstr (ID_IC(id), "function", "legendre")
+		    case CHEBYSHEV:
+			call ic_pstr (ID_IC(id), "function", "chebyshev")
+		    case SPLINE1:
+			call ic_pstr (ID_IC(id), "function", "spline1")
+		    case SPLINE3:
+			call ic_pstr (ID_IC(id), "function", "spline3")
+		    }
+		}
+
+		ID_NEWCV(id) = YES
+		ID_CURRENT(id) = min (1, ID_NFEATURES(id))
+	    } then
+		;
+
+	    ifnoerr (call dtgstr (dt, rec, "units", Memc[line], SZ_LINE)) {
+		if (ID_UN(id) == NULL)
+		    ID_UN(id) = un_open (Memc[line])
+		else {
+		    un = un_open (Memc[line])
+		    if (!un_compare (un, ID_UN(id))) {
+			call id_unitsll (id, Memc[line])
+			call un_close (ID_UN(id))
+			ID_UN(id) = un
+		    } else
+			call un_close (un)
+		}
+	    }
+	}
+
+	call sfree (sp)
+end
+
+
+# ID_DBWRITE -- Write features data to the database.
+
+procedure id_dbwrite (id, name, ap, verbose)
+
+pointer	id				# ID pointer
+char	name[ARB]			# Image name
+int	ap[2]				# Aperture number
+int	verbose				# Verbose flag
+
+int	i, ncoeffs
+pointer	dt, sp, coeffs, root, sh, im
+
+int	dcvstati(), ic_geti()
+real	ic_getr()
+
+errchk	dtremap
+
+begin
+	call smark (sp)
+	call salloc (root, SZ_FNAME, TY_CHAR)
+
+	call strcpy ("id", Memc[root], SZ_FNAME)
+	call imgcluster (name, Memc[root+2], SZ_FNAME)
+	call dtremap (ID_DT(id), ID_DATABASE(id), Memc[root], APPEND)
+
+	call id_dbsection (id, name, ap, ID_SECTION(id), ID_LENSTRING)
+
+	sh = ID_SH(id)
+	dt = ID_DT(id)
+	call dtptime (dt)
+	call dtput (dt, "begin\tidentify %s%s\n")
+	    call pargstr (name)
+	    call pargstr (ID_SECTION(id))
+	call dtput (dt, "\tid\t%s\n")
+	    call pargstr (name)
+	call dtput (dt, "\ttask\tidentify\n")
+	call dtput (dt, "\timage\t%s%s\n")
+	    call pargstr (ID_IMAGE(id))
+	    call pargstr (ID_SECTION(id))
+	if (SMW_FORMAT(MW(sh)) == SMW_ES || SMW_FORMAT(MW(sh)) == SMW_MS) {
+	    call dtput (dt, "\taperture\t%d\n")
+		call pargi (ID_AP(id,1))
+	    call dtput (dt, "\taplow\t%g\n")
+		call pargr (APLOW(sh,1))
+	    call dtput (dt, "\taphigh\t%g\n")
+		call pargr (APHIGH(sh,1))
+	}
+
+	if (ID_UN(id) != NULL) {
+	    call dtput (dt, "\tunits\t%s\n")
+		call pargstr (UN_USER(ID_UN(id)))
+	}
+	call dtput (dt, "\tfeatures\t%d\n")
+	    call pargi (ID_NFEATURES(id))
+	do i = 1, ID_NFEATURES(id) {
+	    call dtput (dt, "\t    %10.2f %10.9g %10.9g %5.1f %d %d %s\n")
+		call pargd (PIX(id,i))
+		call pargd (FIT(id,i))
+		call pargd (USER(id,i))
+		call pargr (FWIDTH(id,i))
+		call pargi (FTYPE(id,i))
+		call pargd (WTS(id,i))
+		if (Memi[ID_LABEL(id)+i-1] != NULL)
+		    call pargstr (Memc[Memi[ID_LABEL(id)+i-1]])
+		else
+		    call pargstr ("")
+	}
+
+	if (ID_SHIFT(id) != 0.) {
+	    call dtput (dt, "\tshift\t%g\n")
+		call pargd (ID_SHIFT(id))
+	}
+
+	if (ID_CV(id) != NULL) {
+	    call dtput (dt, "\tfunction %s\n")
+		call ic_gstr (ID_IC(id), "function", Memc[root], SZ_FNAME)
+		call pargstr (Memc[root])
+	    call dtput (dt, "\torder %d\n")
+		call pargi (ic_geti (ID_IC(id), "order"))
+	    call dtput (dt, "\tsample %s\n")
+		call ic_gstr (ID_IC(id), "sample", Memc[root], SZ_FNAME)
+		call pargstr (Memc[root])
+	    call dtput (dt, "\tnaverage %d\n")
+		call  pargi (ic_geti (ID_IC(id), "naverage"))
+	    call dtput (dt, "\tniterate %d\n")
+		call  pargi (ic_geti (ID_IC(id), "niterate"))
+	    call dtput (dt, "\tlow_reject %g\n")
+		call  pargr (ic_getr (ID_IC(id), "low"))
+	    call dtput (dt, "\thigh_reject %g\n")
+		call  pargr (ic_getr (ID_IC(id), "high"))
+	    call dtput (dt, "\tgrow %g\n")
+		call  pargr (ic_getr (ID_IC(id), "grow"))
+
+	    ncoeffs = dcvstati (ID_CV(id), CVNSAVE)
+	    call salloc (coeffs, ncoeffs, TY_DOUBLE)
+	    call dcvsave (ID_CV(id), Memd[coeffs])
+	    call dtput (dt, "\tcoefficients\t%d\n")
+		call pargi (ncoeffs)
+	    do i = 1, ncoeffs {
+		call dtput (dt, "\t\t%g\n")
+		    call pargd (Memd[coeffs+i-1])
+	    }
+	}
+
+	call dtput (dt, "\n")
+
+	ID_NEWFEATURES(id) = NO
+	ID_NEWCV(id) = NO
+	ID_NEWDBENTRY(id) = NO
+
+	if (verbose == YES) {
+	    call printf ("identify %s%s\n")
+		call pargstr (name)
+	        call pargstr (ID_SECTION(id))
+	}
+
+	# Enter reference spectrum name in image header.
+	im = IM(sh)
+	call imseti (im, IM_WHEADER, YES)
+	call imastr (im, "REFSPEC1", ID_IMAGE(id))
+	iferr (call imdelf (im, "REFSPEC2"))
+	    ;
+ 
+	call sfree (sp)
+end
+
+
+# ID_DBCHECK -- Check if there is an entry in the database.
+# This does not actually read the database entry.  It also assumes that
+# if a database is already open it is for the same image (the image
+# names are not checked) and the database has been scanned.
+
+int procedure id_dbcheck (id, name, ap)
+
+pointer	id				# ID pointer
+char	name[SZ_LINE]			# Image name
+int	ap[2]				# Aperture number
+
+int	rec, stat
+pointer	sp, line, sec
+
+int	dtlocate()
+
+errchk	dtremap(), dtlocate()
+
+begin
+	call smark (sp)
+	call salloc (line, SZ_LINE, TY_CHAR)
+	call salloc (sec, SZ_LINE, TY_CHAR)
+
+	if (ID_DT(id) == NULL) {
+	    call strcpy ("id", Memc[line], SZ_LINE)
+	    call imgcluster (name, Memc[line+2], SZ_LINE)
+	    iferr (call dtremap (ID_DT(id), ID_DATABASE(id), Memc[line],
+		READ_ONLY)) {
+		call sfree (sp)
+		return (NO)
+	    }
+	}
+
+	call id_dbsection (id, name, ap, Memc[sec], SZ_LINE)
+	call sprintf (Memc[line], SZ_LINE, "identify %s%s")
+	    call pargstr (name)
+	    call pargstr (Memc[sec])
+
+	iferr (rec = dtlocate (ID_DT(id), Memc[line]))
+	    stat = NO
+	else
+	    stat = YES
+
+	call sfree (sp)
+	return (stat)
+end
+
+
+# ID_DBSECTION -- Make the IDENTIFY section.
+
+procedure id_dbsection (id, name, ap, section, sz_section)
+
+pointer	id				#I ID pointer
+char	name[SZ_LINE]			#I Image name
+int	ap[2]				#I Aperture number
+char	section[sz_section]		#O IDENTIFY section
+int	sz_section			#I Size of section string
+
+pointer	sh, smw
+bool	streq()
+
+begin
+	sh = ID_SH(id)
+	smw = MW(sh)
+
+	switch (SMW_FORMAT(smw)) {
+	case SMW_ND:
+	    section[1] = EOS
+	    if (streq (name, ID_IMAGE(id))) {
+		switch (SMW_LDIM(smw)) {
+		case 2:
+		    switch (SMW_LAXIS(smw,1)) {
+		    case 1:
+			call sprintf (section, sz_section, "[*,%d]")
+		    case 2:
+			call sprintf (section, sz_section, "[%d,*]")
+		    }
+		    #call pargi (LINDEX(sh,1))
+		    call pargi (ap[1])
+		case 3:
+		    switch (SMW_LAXIS(smw,1)) {
+		    case 1:
+			call sprintf (section, sz_section, "[*,%d,%d]")
+		    case 2:
+			call sprintf (section, sz_section, "[%d,*,%d]")
+		    case 3:
+			call sprintf (section, sz_section, "[%d,%d,*]")
+		    }
+		    #call pargi (LINDEX(sh,1))
+		    #call pargi (LINDEX(sh,2))
+		    call pargi (ap[1])
+		    call pargi (ap[2])
+		}
+	    }
+	case SMW_ES, SMW_MS:
+	    call sprintf (section, sz_section, " - Ap %d")
+		call pargi (ap[1])
+	}
+end