/* column.c
********************************************************************************
* column.c -- Routines for treating a PDS COLUMN object as a series.
*
* User routines:
*	Pro_ColumnSeries()	creates a series object out of a specified
*				PDS-labeled COLUMN object.
*
* Mark Showalter & Neil Heather, PDS Rings Node, March 1998
*******************************************************************************/
#include 
#include 
#include 
#include "profile.h"
#include "fortran.h"
#include "oal.h"

/*************************
 * Data type definitions *
 *************************/

typedef struct ZPRO_COLUMN_STRUCT {
    XPRO_CLASS	class;
    PRO_OBJECT	*label;
    ODLTREE	tabletree, columntree;
    RL_INT4	table, column, item, items, row1, row2, rows;
    RL_INT4	k1, start, skip;
    RL_FLT8	missing, invalid, offset, scale;
    RL_BOOL	isdouble;
    RL_FLT8	*(ddata[2]);
    RL_FLT4	*(sdata[2]);
    RL_INT4	buffer_rows, rowsegs[2];
} ZPRO_COLUMN;

/********************
 * Static variables *
 ********************/

static XPRO_CLASS column_class = {XPRO_COLUMN_CLASS, "PDS column", NULL};

/************************************
 * Prototypes of internal functions *
 ************************************/

static RL_FLT8 ZPro_ColumnValue RL_PROTO((RL_VOID *pointer, RL_INT4 k,
                                          RL_INT4 *flag));
static void    ZPro_FreeColumn  RL_PROTO((RL_VOID *pointer));
static void    ZPro_PrintColumn RL_PROTO((RL_VOID *pointer));

/*
********************************************************************************
* EXPORTED USER ROUTINES
********************************************************************************
*$ Component_name:
*	Pro_ColumnSeries (column.c)
*$ Abstract:
*	This routine creates and returns a column series object.  A column
*	series returns the values from a column of data found in a series or
*	table of a PDS-labeled data file.
*$ Keywords:
*	PROFILE, SERIES
*	C, PUBLIC, SUBROUTINE
*$ Declarations:
*	PRO_OBJECT	*Pro_ColumnSeries(label, ntable, ncolumn, nitem,
*				row1, row2, k1, buffersize, usedouble)
*	PRO_OBJECT	*label;
*	RL_INT4		ntable, ncolumn, nitem, row1, row2, k1, buffersize;
*	RL_BOOL		usedouble;
*$ Inputs:
*	label		pointer to a PDS label object.
*	ntable		table index in label.
*	ncolumn		column index in label.
*	nitem		item index [1...n] or 0 to use all items.
*	row1		first row to include (numbered from 1).
*	row2		last row to include (numbered from 1; 0 for all).
*	k1		starting index for series.
*	buffersize	minimum number of samples to keep in internal buffer;
*			0 to keep entire column in memory.
*	usedouble	TRUE to save double precision values internally;
*			FALSE for single precision.
*$ Outputs:
*	none
*$ Returns:
*	pointer to a new column series object, or NULL on non-fatal error.
*$ Detailed_description:
*	This routine creates and returns a column series object.  A column
*	series returns the values from a column of data found in a series or
*	table of a PDS-labeled data file.
*
*	For PDS SERIES objects, the SAMPLING_PARAMETER quantities in the label
*	define the sampling of the series.  For PDS TABLE objects, the series
*	sampling parameter is assumed to be the row index, starting with 1.
*
*	Note: The buffersize parameter enables the user to have access to a
*	finite subset of the array at any given time without the need to retain
*	the entire column in memory.  Whenever an attempt is made to access a
*	sample not currently in memory, the needed segment of the data file is
*	read into memory.  The buffersize parameter should be no smaller than
*	the difference between the first and last series samples needed at a
*	given time.  For example, when convolving the data with a filter
*	function, the buffersize should be greater than or equal to the full
*	width of the filter used.
*$ External_references:
*	Profile toolkit, Object Access library
*$ Side_effects:
*	Memory is allocated.  A link to the corresponding label object is
*	created.
*$ Examples:
*	This snippet of code prints out the first three samples in the second
*	column of the first table in a PDS-labeled data file.
*
*	label = Pro_OpenLabel("table.tab");
*	ntable = 1;
*	ncolumn = 2;
*	nitem = 0;
*	k1 = 0;
*	column = Pro_ColumnSeries(label, ntable, ncolumn, nitem,
*				1, 0, k1, 0, TRUE);
*
*	printf("%g %g %g\n", Pro_SeriesValue(column,k1),
*	                     Pro_SeriesValue(column,k1+1),
*	                     Pro_SeriesValue(column,k1+2));
*$ Error_handling:
*	Profile library error handling is in effect.
*
*	Conditions raised:
*	PRO_CLASS_ERROR		if label is NULL or is not a label object.
*	PRO_DOMAIN_ERROR	it ntable, ncolumn or nitem is out of range.
*	PRO_MEMORY_ERROR	on memory allocation failure.
*	PRO_SETUP_FAILURE	on any OA Library error.
*$ Limitations:
*	none
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
*******************************************************************************/

PRO_OBJECT	*Pro_ColumnSeries(label, ntable, ncolumn, nitem, row1, row2, k1,
			buffersize, usedouble)
PRO_OBJECT	*label;
RL_INT4		ntable, ncolumn, nitem, row1, row2, k1, buffersize;
RL_BOOL		usedouble;
{
PRO_OBJECT	*new;
ZPRO_COLUMN	*column;
RL_INT4		k2, rows, flag, oldtype;
RL_FLT8		x1, x2, dx;
RL_CHAR		*xname, *yname;
RL_BOOL		status, olderror;
ODLTREE		nodes[1];
RL_VOID		*pointer, *tableptr, *columnptr;

    /* Allocate new column structure */
    column = (ZPRO_COLUMN *) XRL_Malloc(sizeof(ZPRO_COLUMN));
    if (column == NULL) return NULL;

    /* Initialize structure */
    column->class    = column_class;
    column->label    = label;
    column->table    = ntable;
    column->column   = ncolumn;
    column->k1       = k1;
    column->isdouble = usedouble;
    column->ddata[0] = NULL;
    column->ddata[1] = NULL;
    column->sdata[0] = NULL;
    column->sdata[1] = NULL;
    column->rowsegs[0] = 1;
    column->rowsegs[1] = 0;

    /* Get column info from label */
    status = XPro_LabelInfo(label, ntable, ncolumn, &tableptr, &columnptr,
		&(column->rows), &(column->items),
		&x1, &x2, &dx, &xname, &yname,
		&(column->missing), &(column->invalid),
		&(column->offset),  &(column->scale));
    if (!status) {
	XRL_Free((RL_VOID *) column);
	return NULL;
    }

    column->tabletree  = (ODLTREE) tableptr;
    column->columntree = (ODLTREE) columnptr;

    if (!usedouble) {
	if (column->missing != -HUGE_VAL)
		column->missing = (RL_FLT4) column->missing;
	if (column->invalid != -HUGE_VAL)
		column->invalid = (RL_FLT4) column->invalid;
    }

    /* Interpret row parameters */
    if (row1 < 1 || row1 > column->rows) {
	XPro_IDomainError("first row index", label, 1, column->rows, row1);
	XRL_Free((RL_VOID *) column);
	return NULL;
    }
    if (row2 == 0) row2 = column->rows;
    if (row2 < row1 || row2 > column->rows) {
	XPro_IDomainError("last row index", label, row1, column->rows, row2);
	XRL_Free((RL_VOID *) column);
	return NULL;
    }
    column->row1 = row1;
    column->row2 = row2;

    /* Interpret item parameter */
    if (nitem == 1 && column->items == 1) nitem = 0;

    if (nitem == 0) {
	dx /= column->items;
	k2 = k1 + (row2-row1+1) * column->items - 1;
	column->start = 0;
	column->skip  = 1;
    }
    else {
	if (nitem < 1 || nitem > column->items) {
	    XPro_IDomainError("item index", label, 1, column->items, nitem);
	    XRL_Free((RL_VOID *) column);
	    return NULL;
	}
	column->start = nitem-1;
	column->skip  = column->items;
	k2 = k1 + row2 - row1;
    }
    column->item = nitem;
    column->k1 = k1;

    /* Determine number of rows to retain in cache */
    rows = row2 - row1 + 1;
    if (buffersize <= 0)
	column->buffer_rows = rows;
    else if (column->skip > 1)
	column->buffer_rows = buffersize;
    else
	column->buffer_rows = (buffersize + column->items - 1) / column->items;

    if (column->buffer_rows > rows) column->buffer_rows = rows;

    /* Save any PRO_EVALUATION_FAILURE and record future ones */
    olderror = RL_ClearError1("PRO_EVALUATION_FAILURE");
    oldtype = RL_SetErrorType("PRO_EVALUATION_FAILURE", RL_RECORD);

    /* Fill first buffer and check for errors */
    ZPro_ColumnValue((RL_VOID *) column, column->k1, &flag);
    status = RL_ClearError1("PRO_EVALUATION_FAILURE");

    /* Raise PRO_SETUP_FAILURE if necessary */
    if (status) {
	RL_RaiseError("PRO_SETUP_FAILURE", xpro_message);
	/* Note xpro_message is a global variable and is already loaded with the
           error message by Pro_ColumnValue() */
    }

    /* Restore any PRO_EVALUATION_FAILURE */
    if (olderror) RL_RaiseError("PRO_EVALUATION_FAILURE", "");
    RL_SetErrorType("PRO_EVALUATION_FAILURE", oldtype);

    /* Free the object and return NULL on error */
    if (status) {
	ZPro_FreeColumn((RL_VOID *) column);
	return NULL;
    }

    /* Create new object */
    new = XPro_MakeSeries(k1, k2, x1, dx,
                          ZPro_ColumnValue, ZPro_FreeColumn, ZPro_PrintColumn,
                          (RL_VOID *) column);

    /* Enslave the label and check for error */
    if (new != NULL && XPro_EnslaveObject(new, label)) {
	Pro_FreeObject(new);
    }

    /* Transfer coordinate names to new object */
    Pro_RenameObject(new, 1, xname);
    Pro_RenameObject(new, 2, yname);

    return new;
}

/*
********************************************************************************
* INTERNAL FUNCTIONS
********************************************************************************
* ZPro_ColumnValue(pointer, k, flag)
*
* This is the series evaluation function for a PDS column series object.  It
* checks to see if the sample is in the buffer, and reads a new section of the
* data file if necessary.
*
* Inputs:
*	pointer		pointer to the ZPRO_COLUMN data structure.
*	k		index at which to evaluate array.
*
* Outputs:
*	*flag		0 if value returned is valid; PRO_MISSING_FLAG if it is
*			missing; PRO_INVALID_FLAG if it is invalid.
*
* Return:		value of column at given index; 0. on error.
*
* Errors:
*	PRO_EVALUATION_FAILURE	if an I/O occurs during file access.
*******************************************************************************/

static RL_FLT8	ZPro_ColumnValue(pointer, k, flag)
RL_VOID		*pointer;
RL_INT4		k, *flag;
{
ZPRO_COLUMN	*column;
RL_INT4		rowrel, rowseg, rowbase, rowmod, row1, row2, offset;
RL_FLT8		value;
RL_VOID		*array;
RL_CHAR		*verb;
OA_OBJECT	oaobject, oaconvert;

    column = (ZPRO_COLUMN *) pointer;

    /***************************************
     * Identify needed segment of the file *
     ***************************************/

    rowrel  = (k - column->k1) * column->skip/column->items;
    rowseg  = rowrel / column->buffer_rows;
    rowbase = rowseg * column->buffer_rows;
    rowmod  = rowseg & 1;

    /*
     * Explanation...
     *
     * rowrel is the desired sample's row relative to the first row used by
     *        this column object.
     * rowseg is the segment index.  This is 0 for the first set of
     *         rows in the file, 1 for the second set, etc.
     * rowbase is the first row in the segment, relative to the first row used.
     * rowmod is 0 if rowseg is even; 1 if it is odd.  This enables the routine
     *        to keep two different segments in memory simultaneously.
     */

    /*****************************************
     * Load segment into memory if necessary *
     *****************************************/

    if (rowseg != column->rowsegs[rowmod]) {
	column->rowsegs[rowmod] = rowseg;

	/* Read segment of column from PDS file */
	row1 = column->row1 + rowbase;
	row2 = row1 + column->buffer_rows - 1;
	if (row2 > column->row2) row2 = column->row2;

#ifdef DEBUG
	printf("Reading rows %d to %d\n", row1, row2);
#endif

	oaobject = OaReadSubTable(column->tabletree, (long) row1, (long) row2,
	                          &(column->columntree), 1);

	if (oaobject == NULL || (oa_errno >= 500 && oa_errno < 900)) {
	    verb = "reading";
	    goto OAFAILURE;
        }

	/* Convert the data */
	if (column->isdouble) {
	    oaconvert = OaConvertObjecttoOneType(oaobject, "double", 0, FALSE);
	} else {
            oaconvert = OaConvertObjecttoOneType(oaobject, "float",  0, FALSE);
	}

	if (oaconvert == NULL || (oa_errno >= 500 && oa_errno < 900)) {
	    verb = "converting";
	    goto OAFAILURE;
	}

	/* Export the data */
	array = OaExportObject(oaconvert);
	if (column->isdouble) {
	    XRL_Free((RL_VOID *) column->ddata[rowmod]);
	    column->ddata[rowmod] = (RL_FLT8 *) array;
	}
	else {
	    XRL_Free((RL_VOID *) column->sdata[rowmod]);
            column->sdata[rowmod] = (RL_FLT4 *) array;
	}

	if (pointer == NULL || (oa_errno >= 500 && oa_errno < 900)) {
	    verb = "exporting";
	    goto OAFAILURE;
	}

	/* Delete the unconverted object */
	(void) OaDeleteObject(oaobject);

	if (oa_errno >= 500 && oa_errno < 900) {
	    verb = "deleting";
	    goto OAFAILURE;
	}
    }

    /*******************************
     * Extract sample from segment *
     *******************************/

    offset = (k - column->k1)*column->skip - rowbase * column->items
             + column->start;
    if (column->isdouble) {
	if (column->ddata == NULL) goto INVALID; /* if I/O error occurred */
	value = (column->ddata[rowmod])[offset];
    }
    else {
	if (column->sdata == NULL) goto INVALID; /* if I/O error occurred */
	value = (RL_FLT8) (column->sdata[rowmod])[offset];
    }

    /* Check for flags */
    if (value == column->missing) goto MISSING;
    if (value == column->invalid) goto INVALID;

    /* Return valid value */
    *flag = 0;
    return value * column->scale + column->offset;

OAFAILURE:
    (void) sprintf(xpro_message, "error %s PDS column object\n\
OA Library error code %d", verb, oa_errno);
    RL_RaiseError("PRO_EVALUATION_FAILURE", xpro_message);
    goto INVALID;

INVALID:
    *flag = PRO_INVALID_FLAG;
    return 0.;

MISSING:
    *flag = PRO_MISSING_FLAG;
    return 0.;
}

/*
********************************************************************************
* ZPro_FreeColumn(pointer)
*
* This is the freeing function for a PDS column series object.
*
* Inputs:
*	pointer		pointer to the ZPRO_COLUMN data structure.
*******************************************************************************/

static void	ZPro_FreeColumn(pointer)
RL_VOID		*pointer;
{
ZPRO_COLUMN	*column;
RL_FLT8		value;

    column = (ZPRO_COLUMN *) pointer;
    XRL_Free((RL_VOID *) column->ddata[0]);
    XRL_Free((RL_VOID *) column->ddata[1]);
    XRL_Free((RL_VOID *) column->sdata[0]);
    XRL_Free((RL_VOID *) column->sdata[1]);

    XRL_Free(pointer);
}

/*
********************************************************************************
* ZPro_PrintColumn(pointer)
*
* This is the series printing function for a PDS series object.
*
* Inputs:
*	pointer		pointer to the ZPRO_COLUMN data structure.
*******************************************************************************/

static void	ZPro_PrintColumn(pointer)
RL_VOID		*pointer;
{
ZPRO_COLUMN	*column;
RL_INT4		k;

    column = (ZPRO_COLUMN *) pointer;

    /* Make sure object is not NULL */
    if (column == NULL) {
	printf("PRINT ERROR: PDS column series pointer is NULL\n");
	return;
    }

    /* Make sure object is a PDS series */
    if (column->class.id != XPRO_COLUMN_CLASS) {
	printf("PRINT ERROR: Object is not a PDS column series\n");
	return;
    }

    /* Print object info... */
    printf("\nPDS column series parameters...\n");
    printf("    label = "); XPro_PrintInfo(column->label);
    printf("    table = %d\n", column->table);
    printf("   column = %d\n", column->column);

    if (column->items == 1) {
	printf("     item = 1 of 1\n");
    } else if (column->item == 0) {
	printf("     item = all of %d\n", column->items);
    } else {
	printf("     item = %d of %d\n", column->item, column->items);
    }

    printf("     rows = %1d to %1d of %1d\n",
			column->row1, column->row2, column->rows);
    printf("precision = %s\n", column->isdouble ? "double":"single");
    if (column->missing != -HUGE_VAL)
	printf("  missing = %#g\n", column->missing);
    if (column->invalid != -HUGE_VAL)
	printf("  invalid = %#g\n", column->invalid);
    if (column->scale != 1. && column->offset != 0.)
	printf("  scaling = %#g * x + %#g\n", column->scale, column->offset);
}

/*
********************************************************************************
* FORTRAN INTERFACE ROUTINES
********************************************************************************
*$ Component_name:
*	FPro_ColumnSeries (column.c)
*$ Abstract:
*	This routine creates and returns a column series object.  A column
*	series returns the values from a column of data found in a series or
*	table of a PDS-labeled data file.
*$ Keywords:
*	PROFILE, SERIES
*	FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
*	integer*4 function FPro_ColumnSeries(label, table, column, item,
*				row1, row2, k1, buffersize, usedouble)
*	integer*4	label, table, column, item, row1, row2, k1, buffersize
*	logical*4	usedouble
*$ Inputs:
*	label		FORTRAN pointer to a PDS label object.
*	ntable		table index in label.
*	ncolumn		column index in label.
*	nitem		item index [1...n] or 0 to use all items.
*	row1		first row to include (numbered from 1).
*	row2		last row to include (numbered from 1; 0 for all).
*	k1		starting index for series.
*	buffersize	minimum number of samples to keep in internal buffer;
*			0 to keep entire column in memory.
*	usedouble	TRUE to save double precision values internally;
*			FALSE for single precision.
*$ Outputs:
*	none
*$ Returns:
*	FORTRAN pointer to a new column series object, or NULL on non-fatal
*	error.
*$ Detailed_description:
*	This routine creates and returns a column series object.  A column
*	series returns the values from a column of data found in a series or
*	table of a PDS-labeled data file.
*
*	For PDS SERIES objects, the SAMPLING_PARAMETER quantities in the label
*	define the sampling of the series.  For PDS TABLE objects, the series
*	sampling parameter is assumed to be the row index, starting with 1.
*
*	Note: The buffersize parameter enables the user to have access to a
*	finite subset of the array at any given time without the need to retain
*	the entire column in memory.  Whenever an attempt is made to access a
*	sample not currently in memory, the needed segment of the data file is
*	read into memory.  The buffersize parameter should be no smaller than
*	the difference between the first and last series samples needed at a
*	given time.  For example, when convolving the data with a filter
*	function, the buffersize should be greater than or equal to the full
*	width of the filter used.
*$ External_references:
*	Profile toolkit, Object Access library
*$ Side_effects:
*	Memory is allocated.  A link to the corresponding label object is
*	created.
*$ Examples:
*	This snippet of code prints out the first three samples in the second
*	column of the first table in a PDS-labeled data file.
*
*	label = Pro_OpenLabel('table.tab')
*	ntable = 1
*	ncolumn = 2
*	nitem = 0
*	k1 = 0
*	column = FPro_ColumnSeries(label, ntable, ncolumn, nitem,
*    &				1, 0, k1, 0, .TRUE.)
*
*	write(*,*) FPro_SeriesValue(column,k1),
*    &	           FPro_SeriesValue(column,k1+1),
*    &	           FPro_SeriesValue(column,k1+2)
*$ Error_handling:
*	Profile library error handling is in effect.
*
*	Conditions raised:
*	PRO_CLASS_ERROR		if label is NULL or is not a label object.
*	PRO_DOMAIN_ERROR	it ntable, ncolumn or nitem is out of range.
*	PRO_MEMORY_ERROR	on memory allocation failure.
*	PRO_SETUP_FAILURE	on any OA Library error.
*	FORTRAN_POINTER_ERROR	if label is not a valid FORTRAN object pointer.
*$ Limitations:
*	none
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
*******************************************************************************/

RL_INT4 FORTRAN_NAME(fpro_columnseries) (label, table, column, item, row1, row2,
				k1, buffersize, usedouble)
RL_INT4 *label, *table, *column, *item, *row1, *row2, *k1, *buffersize,
	*usedouble;
{
RL_VOID *ptr1, *ptr2;
RL_INT4 index;

    /* Look up label pointer */
    ptr1 = FORT_GetPointer(*label);
    if (ptr1 == NULL) return 0;

    /* Call function */
    ptr2 = (RL_VOID *) Pro_ColumnSeries(ptr1, *table, *column, *item, *row1,
				*row2, *k1, *buffersize, (RL_BOOL) *usedouble);
    if (ptr2 == NULL) return 0;

    index = FORT_AddPointer(ptr2);
    if (index == 0) Pro_FreeObject((PRO_OBJECT *) ptr2);

    return index;
}

/*******************************************************************************
*/