include <tbset.h>
include "ratio_obj.h"

# Memory management.
define	Col_name		Memc[col_name]
define	Null			Memb[null]
define	Par_name		Memc[par_name]
define	SZ_TMPSTRING		SZ_COMMAND
define	Sx			Memc[sx]
define	Sy			Memc[sy]
define	DEFAULT_GROW		2000

#---------------------------------------------------------------------------
.help ratio_obj May94 source
.ih
NAME
ratio_obj -- Definition of a hybrid spectrum/centerflux object.
.endhelp
#---------------------------------------------------------------------------
pointer	procedure ra_alloc ()

pointer	obj			# The centerflux results object.
int	i			# Generic.

begin
	# Allocate the memory structure.
	call malloc (obj, RA_SIZE, TY_STRUCT)
	call malloc (RA_UNITS_PTR(obj), RA_SZ_UNITS, TY_CHAR)
	call malloc (RA_WUNITS_PTR(obj), RA_SZ_WUNITS, TY_CHAR)
	call malloc (RA_DATA_ARRAY_PTR(obj), RA_N_COLUMNS, TY_POINTER)
	call malloc (RA_EXIST_PTR(obj), RA_N_COLUMNS, TY_INT)
        call malloc (RA_APERTURE_PTR(obj), RA_SZ_APERTURE, TY_CHAR)
        call malloc (RA_GRATING_PTR(obj), RA_SZ_GRATING, TY_CHAR)
	
        # Set default values.
        call strcpy ("", RA_UNITS(obj), RA_SZ_UNITS)
        call strcpy ("", RA_WUNITS(obj), RA_SZ_WUNITS)
        call strcpy ("", RA_APERTURE(obj), RA_SZ_APERTURE)
        call strcpy ("", RA_GRATING(obj), RA_SZ_GRATING)
        RA_GROW(obj) = DEFAULT_GROW
        RA_N(obj) = 0
        RA_MAX_DATA(obj) = 0
        do i = 1, RA_N_COLUMNS {
            RA_DATA_ARRAY(obj,i) = NULL
	    RA_EXIST(obj,i) = NO
        }

        # That's all folks.
        return (obj)
end
#---------------------------------------------------------------------------
# end of ra_alloc
#---------------------------------------------------------------------------
procedure ra_free (obj)

pointer	obj			# IO: OBJ obj object, NULL on return.

int	i			# Generic.

begin
	# Free the memory.
	do i = 1, RA_N_COLUMNS
	    if (RA_EXIST(obj,i) == YES)
		switch (i) {
		case RA_CARPOS, RA_ORDER:
		    call mfree (RA_DATA_ARRAY(obj,i), TY_INT)
		default:
		    call mfree (RA_DATA_ARRAY(obj,i), TY_DOUBLE)
		}	

	call mfree (RA_APERTURE_PTR(obj), TY_CHAR)
	call mfree (RA_GRATING_PTR(obj), TY_CHAR)
	call mfree (RA_EXIST_PTR(obj), TY_INT)
	call mfree (RA_DATA_ARRAY_PTR(obj), TY_POINTER)
	call mfree (RA_WUNITS_PTR(obj), TY_CHAR)
	call mfree (RA_UNITS_PTR(obj), TY_CHAR)
	call mfree (obj, TY_STRUCT)
end
#---------------------------------------------------------------------------
# end of ra_free
#---------------------------------------------------------------------------
procedure ra_add_point (obj, carpos, order, value, wave, err)

pointer	obj			# I:  RA output ra descriptor.
int	carpos			# I:  Carrousel position.
int	order			# I:  Spectral order.
double	value			# I:   Value.
double	wave			# I:  Wavelength.
double	err			# I:  Standard deviation.

begin
        call ra_grow (obj, RA_N(obj)+1)
        if (RA_EXIST(obj,RA_CARPOS) == YES)
            RA_CARPOS_DATA(obj,RA_N(obj)) = carpos
        if (RA_EXIST(obj,RA_ORDER) == YES)
            RA_ORDER_DATA(obj,RA_N(obj)) = order
        if (RA_EXIST(obj,RA_VALUE) == YES)
            RA_VALUE_DATA(obj,RA_N(obj)) = value
        if (RA_EXIST(obj,RA_WAVE) == YES)
            RA_WAVE_DATA(obj,RA_N(obj)) = wave
        if (RA_EXIST(obj,RA_ERR) == YES)
            RA_ERR_DATA(obj,RA_N(obj)) = err
end
#---------------------------------------------------------------------------
# End of ra_add_point
#---------------------------------------------------------------------------
procedure ra_grow (obj, size)

pointer	obj			# I:  RA object.
int	size			# I:  Size of arrays.

int	i			# Generic.
bool	new_max			# True to reallocate arrays.

begin
	RA_N(obj) = size
	
	# See if growth is needed.
	new_max = false
	while (RA_MAX_DATA(obj) <= RA_N(obj)) {
	    new_max = true
	    RA_MAX_DATA(obj) = RA_MAX_DATA(obj) + RA_GROW(obj)
	}

	if (new_max)
	    do i = 1, RA_N_COLUMNS
		switch (i) {
		case RA_CARPOS, RA_ORDER:
		    call realloc (RA_DATA_ARRAY(obj,i), RA_MAX_DATA(obj),
				  TY_INT)
		default:
		    call realloc (RA_DATA_ARRAY(obj,i), RA_MAX_DATA(obj),
				  TY_DOUBLE)
		}
end
#---------------------------------------------------------------------------
# End of ra_grow
#---------------------------------------------------------------------------
procedure ra_dump (obj)

pointer	obj			# I:  RA object.

int	i, j			# Generic.

begin
	# Write various single values.
	call printf ("ra_obj: The grating name is %s.\n")
	call pargstr (RA_GRATING(obj))
	call printf ("ra_obj: The aperture name is %s.\n")
	call pargstr (RA_APERTURE(obj))
	call pargstr (RA_UNITS(obj))
	call printf ("ratio_obj: the wunits is %s.\n")
	call pargstr (RA_WUNITS(obj))
	call printf ("ratio_obj: Number of points = %d.\n")
	call pargi (RA_N(obj))
	call printf ("ratio_obj: max data = %d, grow = %d.\n")
	call pargi (RA_MAX_DATA(obj))
	call pargi (RA_GROW(obj))	
	
	# Write out the column information.
	do i = 1, RA_N_COLUMNS {
	    if (RA_EXIST(obj,i) == YES) {
		call printf ("ratio_obj: Data %s is ")
		switch (i) {
		case RA_CARPOS: call pargstr ("carpos")
		case RA_ORDER: call pargstr ("order")
		case RA_VALUE: call pargstr ("value")
		case RA_WAVE: call pargstr ("wave")
		case RA_ERR: call pargstr ("err")
		}	
		do j = 1, min(3,RA_N(obj)) {
		    call printf ("%g ")
		    switch (i) {
		    case RA_CARPOS, RA_ORDER:
			call pargi (Memi[RA_DATA_ARRAY(obj,i)+j-1])
		    default:
			call pargd (Memd[RA_DATA_ARRAY(obj,i)+j-1])
		    }	
		}
		call printf ("\n")
	    }
	}
end
#---------------------------------------------------------------------------
# End of ra_dump
#---------------------------------------------------------------------------
procedure ra_read_table (obj, name)

pointer	obj			# I:  RA object.
char	name[ARB]		# I:  Name of table to read from.

# Declarations.
pointer	col_id			# Column id.
pointer	col_name		# Column name.
int	i			# Generic.
pointer	null			# Null flag.
pointer	sp			# Stack pointer.
pointer	strlen()		# Get string length.
pointer	table			# Table descriptor.
int	tbpsta()		# Get table status.
pointer	tbtopn()		# Open a table.

begin
	call smark (sp)
	call salloc (col_name, SZ_COMMAND, TY_CHAR)
	
	# Open the table.
	table = tbtopn (name, READ_ONLY, NULL)
	call ra_grow (obj, tbpsta (table, TBL_NROWS))
	call salloc (null, RA_N(obj), TY_BOOL)

	# Read each column.
	do i = 1, RA_N_COLUMNS {

	    # Get the column name.
	    call ra_col_par (i, Col_name, SZ_COMMAND)

	    # Find column.
	    if (strlen (Col_name) > 0) {
		call tbcfnd (table, Col_name, col_id, 1)
		if (col_id == NULL) {
		    call eprintf ("warning: column %s not found in table %s, no data read.\n")
		    call pargstr (Col_name)
		    call pargstr (name)
		}

		# Get data from table.
		else {
		    RA_EXIST(obj,i) = YES
		    switch (i) {	
		    case RA_CARPOS, RA_ORDER:
			call tbcgti (table, col_id, Memi[RA_DATA_ARRAY(obj,i)],
				     Null, 1, RA_N(obj))

		    case RA_WAVE:	
			call tbcgtd (table, col_id, Memd[RA_DATA_ARRAY(obj,i)],
				     Null, 1, RA_N(obj))
			call tbcigt (col_id, TBL_COL_UNITS, RA_WUNITS(obj),
				     RA_SZ_WUNITS)

		    case RA_VALUE:
			call tbcgtd (table, col_id, Memd[RA_DATA_ARRAY(obj,i)],
				     Null, 1, RA_N(obj))
			call tbcigt (col_id, TBL_COL_UNITS, RA_UNITS(obj),
				     RA_SZ_UNITS)

		    default:
			call tbcgtd (table, col_id, Memd[RA_DATA_ARRAY(obj,i)],
				     Null, 1, RA_N(obj))
		    }
		}
	    }
	}

	# Get aperture/grating modes.
	call tbhgtt (table, "aperture", RA_APERTURE(obj), RA_SZ_APERTURE)
	call tbhgtt (table, "grating", RA_GRATING(obj), RA_SZ_GRATING)
	
	# That's all folks.
	call tbtclo (table)
	call sfree (sp)
end
#---------------------------------------------------------------------------
# End of ra_read_table
#---------------------------------------------------------------------------
procedure ra_write_table (obj, name, mode, template)

pointer obj			# I:  RA object
char	name[ARB]		# I:  Name of table to write to.
int	mode			# I:  Mode to open table.
pointer	template		# I:  Table descriptor to use as template.

pointer	ra_find_column()	# Find a column.
pointer	ra_new_column()		# Define a new column.
pointer	col_id			# Column id.
pointer	col_name		# Column name.
int	i			# Generic.
int	n_rows			# Number of rows in table.
pointer	sp			# Stack pointer.
int	strlen()		# String length.
bool	strne()			# Strings not equal?
pointer	sx			# Generic string.
pointer	table			# Table descriptor.
int	tbpsta()		# Table status.
pointer	tbtopn()		# Open table.

begin
	call smark (sp)
	call salloc (sx, SZ_TMPSTRING, TY_CHAR)
	call salloc (col_name, SZ_COLNAME, TY_CHAR)
	
	# Open the table.
	table = tbtopn (name, mode, template)
	if (mode == NEW_FILE) {
	    call tbpset (table, TBL_ALLROWS, RA_N(obj))
	    call tbpset (table, TBL_MAXCOLS, RA_N_COLUMNS)
	    call tbtcre (table)
	}
	n_rows = tbpsta (table, TBL_NROWS)
	
	# If table already exists, check aperture and grating.
	if (mode != NEW_FILE) {
	    call tbhgtt (table, "aperture", Sx, SZ_TMPSTRING)
	    if (strlen (Sx) > 0 && strlen (RA_APERTURE(obj)) > 0)
		if (strne (Sx, RA_APERTURE(obj)))
		    call error (1, "apertures do not match between data and output table")

	    call tbhgtt (table, "grating", Sx, SZ_TMPSTRING)
	    if (strlen (Sx) > 0 && strlen (RA_GRATING(obj)) > 0)
		if (strne (Sx, RA_GRATING(obj)))
		    call error (1, "gratings do not match between data and output table")
	}

	# Else, write the aperture and grating
	else {
	    call tbhadt (table, "aperture", RA_APERTURE(obj))
	    call tbhadt (table, "grating", RA_GRATING(obj))
	}

	# Write each array of data.
	do i = 1, RA_N_COLUMNS {
	    if (RA_EXIST(obj,i) == YES) {

		# Get the column name.
		call ra_col_par (i, Col_name, SZ_COLNAME)

		# Find/define the column
		if (mode == NEW_FILE)
		    col_id = ra_new_column (obj, table, Col_name, i)
		else
		    col_id = ra_find_column (obj, table, Col_name, i)

		# Write a warning if the column could not be allocated
		# in the table.
		if (col_id == NULL) {
		    call eprintf ("ratio_obj: could not write column %s.\n")
		    call pargstr (Col_name)
		}
		
		# Else write the data.
		else {
		    switch (i) {
		    case RA_CARPOS, RA_ORDER:
			call tbcpti (table, col_id, Memi[RA_DATA_ARRAY(obj,i)],
				     n_rows + 1, n_rows + RA_N(obj))
		    default:
			call tbcptd (table, col_id, Memd[RA_DATA_ARRAY(obj,i)],
				     n_rows + 1, n_rows + RA_N(obj))
		    }
		}
	    }
	}

	# That's all folks.
	call tbtclo (table)
	call sfree (sp)
end
#---------------------------------------------------------------------------
# End of ra_write_table
#---------------------------------------------------------------------------
pointer procedure ra_new_column (obj, table, col_name, array)

pointer	obj			# I:  RA object.
pointer	table			# I:  Table descriptor.
char	col_name[ARB]		# I:  Name of column.
int	array			# I:  The data that will go in this column.

pointer	col_id			# Column id.

begin
	switch (array) {
	case RA_CARPOS:
	    call tbcdef (table, col_id, col_name, "encoder units",
			 "", TY_INT, 1, 1)
	case RA_ORDER:
	    call tbcdef (table, col_id, col_name, "",
			 "", TY_INT, 1, 1)
	case RA_WAVE:
	    call tbcdef (table, col_id, col_name, RA_WUNITS(obj),
			 "", TY_DOUBLE, 1, 1)
	case RA_VALUE, RA_ERR:
	    call tbcdef (table, col_id, col_name, RA_UNITS(obj),
			 "", TY_DOUBLE, 1, 1)
	}

	# That's all folks.
	return (col_id)
end
#---------------------------------------------------------------------------
# End of ra_new_column
#---------------------------------------------------------------------------
pointer procedure ra_find_column (obj, table, col_name, array)

pointer	obj			# I:  RA object.
pointer	table			# I:  Table descriptor.
char	col_name[ARB]		# I:  Name of column.
int	array			# I:  The data that will go in this column.

pointer	col_id			# Column id.
bool	bad_units			# True if units don't match.
pointer	sp			# Stack pointer.
int	strlen()		# Length of string.
bool	strne()			# Strings not equal?
pointer	sx			# Generic string.

begin
	call smark (sp)
	call salloc (sx, SZ_TMPSTRING, TY_CHAR)
	
	# Find the column id.
	call tbcfnd (table, col_name, col_id, 1)

	# If there is such a column, check units
	if (col_id != NULL) {
	    call tbcigt (col_id, TBL_COL_UNITS, Sx, SZ_COLUNITS)
	    bad_units = false
	    if (strlen (Sx) > 0) {
		switch (array) {
		case RA_CARPOS:
		    call strlwr (Sx)
		    bad_units = strne ("encoder units", Sx)
		case RA_WAVE:
		    if (strlen (RA_WUNITS(obj)) > 0)
			bad_units = strne (RA_WUNITS(obj), Sx)
		case RA_VALUE:
		    if (strlen (RA_UNITS(obj)) > 0)
			bad_units = strne (RA_UNITS(obj), Sx)
		}
		if (bad_units) {
		    call eprintf ("warning: units for column %s does not match between data and table\n")
		    call pargstr (col_name)
		}
	    }
	}

	# That's all folks.
	call sfree (sp)
	return (col_id)
end
#---------------------------------------------------------------------------
# End of ra_find_column
#---------------------------------------------------------------------------
procedure ra_col_par (column, col_name, sz_col_name)

int	column			# I:  RA object column indicator.
char	col_name[sz_col_name]	# O:  The column name to use.
int	sz_col_name		# I:  Maximum length of name.

pointer	par_name		# Parameter name.
pointer	sp			# Stack pointer.

begin
	call smark (sp)
	call salloc (par_name, SZ_COMMAND, TY_CHAR)
	
	switch (column) {
	case RA_CARPOS:
	    call strcpy ("racolnames.carpos", Par_name, SZ_COMMAND)
	case RA_ORDER:
	    call strcpy ("racolnames.order", Par_name, SZ_COMMAND)
	case RA_WAVE:
	    call strcpy ("racolnames.wave", Par_name, SZ_COMMAND)
	case RA_VALUE:
	    call strcpy ("racolnames.value", Par_name, SZ_COMMAND)
	case RA_ERR:
	    call strcpy ("racolnames.err", Par_name, SZ_COMMAND)
	}
	call clgstr (Par_name, col_name, sz_col_name)

	call sfree (sp)
end
#---------------------------------------------------------------------------
# End of ra_col_par 
#---------------------------------------------------------------------------