/* function.c
********************************************************************************
* function.c -- routines for generic function objects
*
* User routines:
*	Pro_FuncValue(func,x)		returns the value of a function at x.
*	Pro_WindowFunc(func,x1,x2)	creates a new function that duplicates
*					another but over a new domain (x1,x2).
*
* Programmer routines:
*	XPro_MakeFunc()			used to create a new function object.
*	XPro_FuncPtr()			returns a pointer to the sub-object.
*
* Version 1.0: Original release.
*              Mark Showalter & Neil Heather, PDS Rings Node, March 1998.
* Version 1.1: QUICK compilation mode added.
*              Mark Showalter, October 1999.
* Version 1.2: Corrected potential memory management error.
*              Mark Showalter, September 2002.
*******************************************************************************/
#include 
#include 
#include "profile.h"
#include "fortran.h"

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

typedef struct ZPRO_FUNCTION_STRUCT {
    XPRO_CLASS	class;
    RL_FLT8	x1, x2;
    RL_FLT8	(*evalfunc)  RL_PROTO((RL_VOID *pointer, RL_FLT8 x));
    void	(*freefunc)  RL_PROTO((RL_VOID *pointer));
    void	(*printfunc) RL_PROTO((RL_VOID *pointer));
    RL_BOOL	is_windowed;
} ZPRO_FUNCTION;

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

static void	      ZPro_FreeFunc  RL_PROTO((RL_VOID * func));
static void           ZPro_PrintFunc RL_PROTO((RL_VOID * pointer));
static ZPRO_FUNCTION *ZPro_GetFunc   RL_PROTO((PRO_OBJECT * object));

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

static RL_CHAR    ZPRO_BLANK = '\0';
static XPRO_CLASS func_class = {XPRO_FUNCTION_CLASS, "function", NULL};

/*********************
 * Macro definitions *
 *********************/

#ifdef QUICK
#define ZPro_GetFunc(object) ((ZPRO_FUNCTION *) XPro_ObjectPtr(object))
#endif

/*
********************************************************************************
* EXPORTED USER ROUTINES
********************************************************************************
*$ Component_name:
*	Pro_FuncValue (function.c)
*$ Abstract:
*	This routine evaluates and returns the value of a function.
*$ Keywords:
*	PROFILE, FUNCTION
*	C, PUBLIC, SUBROUTINE
*$ Declarations:
*	RL_FLT8    	Pro_FuncValue(object, x)
*	PRO_OBJECT 	*object;
*	RL_FLT8    	x;
*$ Inputs:
*	object		pointer to the function object.
*	x		argument at which to evaluate function.
*$ Outputs:
*	none
*$ Returns:
*	value of function.
*$ Detailed_description:
*	This routine evaluates and returns the value of a function.
*$ External_references:
*	Profile toolkit
*$ Side_effects:
*	none
*$ Examples:
*	Suppose square is a function that returns x squared between -3. and 3.
*
*	Then Pro_FuncValue(square, 2.) returns 4.;
*	     Pro_FuncValue(square, 3.) returns 9.;
*	     Pro_FuncValue(square, 4.) raises PRO_DOMAIN_ERROR and returns 9.
*$ Error_handling:
*	Profile library error handling is in effect.
*
*	Conditions raised:
*	PRO_CLASS_ERROR		if the object is NULL or not a function.
*	PRO_DOMAIN_ERROR	if x is outside the function domain.
*	PRO_EVALUATION_FAILURE	if function could not be evaluated.
*
*	On a non-fatal PRO_DOMAIN_ERROR the value at the nearest endpoint is
*	returned; on other non-fatal errors, 0. is returned.
*$ Limitations:
*	none
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*	1.1: October 1999
*$ Change_history:
*	1.1: QUICK mode compile option added.
*******************************************************************************/

RL_FLT8    	Pro_FuncValue(object, x)
PRO_OBJECT 	*object;
RL_FLT8    	x;
{
ZPRO_FUNCTION  	*func;
RL_FLT8       	value;

    func = ZPro_GetFunc(object);
#ifndef QUICK
    if (func == NULL) return 0.;
#endif

    /* Make sure x is inside domain */
    if (x < func->x1 || x > func->x2) {
	XPro_DomainError("x value", object, func->x1, func->x2, x);

	if (x < func->x1) x = func->x1;
	else              x = func->x2;
    }

    /* Evaluate function */
    value = (func->evalfunc) (func->class.pointer, x);

    return value;
}

/*
********************************************************************************
*$ Component_name:
*	Pro_WindowFunc (function.c)
*$ Abstract:
*	This routine generates a new function object with a narrower domain than
*	the original function.
*$ Keywords:
*	PROFILE, FUNCTION
*	C, PUBLIC, SUBROUTINE
*$ Declarations:
*	PRO_OBJECT    	*Pro_WindowFunc(object, x1, x2)
*	PRO_OBJECT     	*object;
*	RL_FLT8         x1, x2;
*$ Inputs:
*	object		pointer to the function object.
*	x1, x2		new lower and upper limits of domain (inclusive).
*$ Outputs:
*	none
*$ Returns:
*	pointer to a new function object, or NULL on non-fatal error.
*$ Detailed_description:
*	This routine generates a new function object with a narrower domain than
*	the original function.
*$ External_references:
*	Profile toolkit
*$ Side_effects:
*	Memory is allocated.  The new function object creates a link to the old.
*$ Examples:
*	Suppose square is a function that returns x squared between -3. and 3.
*
*	Then Pro_WindowFunc(square, -1., 5.) creates a fuction that returns x
*	squared between -1. and 3.
*$ Error_handling:
*	Profile library error handling is in effect.
*
*	Conditions raised:
*	PRO_CLASS_ERROR		if the object is NULL or not a function.
*	PRO_EMPTY_DOMAIN 	if the windowed function would have an empty
*				domain.
*	RL_MEMORY_ERROR		on memory allocation 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_WindowFunc(object, x1, x2)
PRO_OBJECT     	*object;
RL_FLT8         x1, x2;
{
ZPRO_FUNCTION  *func;
PRO_OBJECT     *new;
RL_FLT8		x1a, x2a;

    func = ZPro_GetFunc(object);
    if (func == NULL) return NULL;

    /* Determine new domain */
    x1a = x1;
    x2a = x2;
    if (x1a < func->x1) x1a = func->x1;
    if (x2a > func->x2) x2a = func->x2;

    /* Make sure domain is not empty */
    if (x1a >= x2a) {
	XPro_EmptyDomain("windowed function", object, NULL,
		func->x1, func->x2, x1, x2);
	return NULL;
    }

    /* Duplicate function object */
    new = XPro_MakeFunc(x1a, x2a, func->evalfunc, func->freefunc,
                        func->printfunc, func->class.pointer);

    /* Enslave original object and check for allocation errors */
    if (new != NULL && XPro_EnslaveObject(new, object)) {
	Pro_FreeObject(new);
	new = NULL;
    }

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

    /* Mark function as windowed */
    func = ZPro_GetFunc(new);
    func->is_windowed = TRUE;

    return new;
}

/*
********************************************************************************
* EXPORTED PROGRAMMER ROUTINES
********************************************************************************
* XPro_MakeFunc(x1, x2, evalfunc, freefunc, printfunc, pointer)
*
* This routine creates and initializes a function object.
*
* Inputs:
*	x1, x2		domain limits.
*	evalfunc	routine to evaluate function.
*	freefunc	routine to free data structure.
*	printfunc	routine to print contents of data structure.
*	pointer		pointer to an arbitrary data structure describing the
*			function.
*
* Returns:		new function object.
*
* Errors:
*	RL_MEMORY_ERROR	on memory allocation error.
*******************************************************************************/

PRO_OBJECT     	*XPro_MakeFunc(x1, x2, evalfunc, freefunc, printfunc, pointer)
RL_FLT8         x1, x2;
RL_FLT8 	(*evalfunc)  RL_PROTO((RL_VOID *pointer, RL_FLT8 x));
void		(*freefunc)  RL_PROTO((RL_VOID *pointer));
void		(*printfunc) RL_PROTO((RL_VOID *pointer));
RL_VOID        	*pointer;
{
ZPRO_FUNCTION  	*func;
PRO_OBJECT     	*new;

    /* Allocate new function structure */
    func = (ZPRO_FUNCTION *) XRL_Malloc(sizeof(ZPRO_FUNCTION));
    if (func == NULL) return NULL;

    /* Initialize structure */
    func->class = func_class;
    func->class.pointer = pointer;

    func->x1 = x1;
    func->x2 = x2;
    func->evalfunc = evalfunc;
    func->freefunc = freefunc;
    func->printfunc = printfunc;
    func->is_windowed = FALSE;

    /* Create new object */
    new = XPro_MakeObject(x1, x2, ZPro_FreeFunc, ZPro_PrintFunc, func);

    return new;
}

/*
********************************************************************************
* XPro_FuncPtr(object)
*
* This routine returns a pointer to the function sub-object.
*
* Inputs:
*	object		function object.
*
* Return:		pointer field of the object; NULL on error.
*
* Errors:
*	PRO_CLASS_ERROR		if the object is NULL or not a function.
****************************************************************************/

#ifndef QUICK	/* In QUICK mode, this is defined as a macro in profile.h */

RL_VOID        	*XPro_FuncPtr(object)
PRO_OBJECT     	*object;
{
ZPRO_FUNCTION	*func;

    func = ZPro_GetFunc(object);
    if (func == NULL) return NULL;

    if (func->class.pointer == NULL)
	XPro_NullError("function sub-object", object);

    return func->class.pointer;
}

#endif

/*
********************************************************************************
* INTERNAL ROUTINES
********************************************************************************
* ZPro_FreeFunc(pointer)
*
* This internal routine deallocates the memory used by a generic function
* object.  It is called by Pro_FreeObject().
*
* Input:
*	pointer		pointer to the ZPRO_FUNCTION structure.
*******************************************************************************/

static void	ZPro_FreeFunc(pointer)
RL_VOID        	*pointer;
{
ZPRO_FUNCTION  *func;

    func = (ZPRO_FUNCTION *) pointer;
    if (func == NULL) return;

    if (func->class.pointer != NULL && !func->is_windowed)
	(func->freefunc) (func->class.pointer);
    XRL_Free(func);
}

/*
********************************************************************************
* ZPro_PrintFunc(pointer)
*
* This internal routine prints out information about a function.  It is called
* by Pro_PrintObject() and is used mainly for debugging.
*
* Input:
*	pointer		pointer to the ZPRO_FUNCTION structure.
*******************************************************************************/

static void	ZPro_PrintFunc(pointer)
RL_VOID        	*pointer;
{
ZPRO_FUNCTION	*func;

    func = (ZPRO_FUNCTION *) pointer;

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

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

    /* Print object info... */
    if (func->is_windowed) printf("\nDomain has been windowed\n");

    (func->printfunc)(func->class.pointer);
}

/*
********************************************************************************
* ZPro_GetFunc(object)
*
* This internal routine returns a pointer to the object's ZPRO_FUNCTION data
* structure.
*
* Input:
*	object		function object.
*
* Return:		pointer to ZPRO_FUNCTION structure, or NULL on error.
*
* Errors:
*	PRO_CLASS_ERROR		if object is NULL or not a function.
*******************************************************************************/

#ifndef QUICK	/* In QUICK mode, this is defined as a macro above */

static ZPRO_FUNCTION *ZPro_GetFunc(object)
PRO_OBJECT     	*object;
{
ZPRO_FUNCTION	*func;

    /* Find function object pointer */
    func = (ZPRO_FUNCTION *) XPro_ObjectPtr(object);

    /* Make sure object is not NULL */
    if (func == NULL) {
	XPro_NullError("function", object);
	return NULL;
    }

    /* Make sure object is a function */
    if (func->class.id != XPRO_FUNCTION_CLASS) {
	XPro_ClassError("function", object);
	return NULL;
    }

    return func;
}

#endif

/*
********************************************************************************
* FORTRAN INTERFACE ROUTINES
********************************************************************************
*$ Component_name:
*	FPro_FuncValue (function.c)
*$ Abstract:
*	This routine evaluates and returns the value of a function.
*$ Keywords:
*	PROFILE, FUNCTION
*	FUNCTION, PUBLIC, SUBROUTINE
*$ Declarations:
*	real*8 function Pro_FuncValue(object, x)
*	integer*4	object
*	real*8		x
*$ Inputs:
*	object		FORTRAN pointer to the function object.
*	x		argument at which to evaluate function.
*$ Outputs:
*	none
*$ Returns:
*	value of function.
*$ Detailed_description:
*	This routine evaluates and returns the value of a function.
*$ External_references:
*	Profile toolkit
*$ Side_effects:
*	none
*$ Examples:
*	Suppose square is a function that returns x squared between -3.d0 and
*	3.d0.
*
*	Then FPro_FuncValue(square, 2.d0) returns 4.d0;
*	     FPro_FuncValue(square, 3.d0) returns 9.d0;
*	     FPro_FuncValue(square, 4.d0) raises PRO_DOMAIN_ERROR, returns 9.d0.
*$ Error_handling:
*	Profile library error handling is in effect.
*
*	Conditions raised:
*	PRO_CLASS_ERROR		if the object is NULL or not a function.
*	PRO_DOMAIN_ERROR	if x is outside the function domain.
*	PRO_EVALUATION_FAILURE	if function could not be evaluated.
*	FORTRAN_POINTER_ERROR	if object is not a valid FORTRAN object pointer.
*
*	On a non-fatal PRO_DOMAIN_ERROR the value at the nearest endpoint is
*	returned; on other non-fatal errors, 0. is returned.
*$ Limitations:
*	none
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*	1.1: October 1999
*$ Change_history:
*	1.1: QUICK mode compile option added.
*******************************************************************************/

RL_FLT8 FORTRAN_NAME(fpro_funcvalue) (object, x)
RL_INT4 *object;
RL_FLT8 *x;
{
RL_VOID *ptr;

    /* Look up function pointer */
    ptr = FORT_GetPointer(*object);
#ifndef QUICK
    if (ptr == NULL) return 0.;
#endif

    /* Call function */
    return Pro_FuncValue((PRO_OBJECT *) ptr, *x);
}

/*
********************************************************************************
*$ Component_name:
*	FPro_WindowFunc (function.c)
*$ Abstract:
*	This routine generates a new function object with a narrower domain than
*	the original function.
*$ Keywords:
*	PROFILE, FUNCTION
*	FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
*	integer*4 function FPro_WindowFunc(object, x1, x2)
*	integer*4	object
*	real*8		x1, x2
*$ Inputs:
*	object		FORTRAN pointer to the function object.
*	x1, x2		new lower and upper limits of domain (inclusive).
*$ Outputs:
*	none
*$ Returns:
*	FORTRAN pointer to a new function object, or 0 on non-fatal error.
*$ Detailed_description:
*	This routine generates a new function object with a narrower domain than
*	the original function.
*$ External_references:
*	Profile toolkit
*$ Side_effects:
*	Memory is allocated.  The new function object creates a link to the old.
*$ Examples:
*	Suppose square is a function that returns x squared between -3.d0 and
*	3.d0.
*
*	Then FPro_WindowFunc(square, -1.d0, 5.d0) creates a fuction that returns
*	x squared between -1.d0 and 3.d0.
*$ Error_handling:
*	Profile library error handling is in effect.
*
*	Conditions raised:
*	PRO_CLASS_ERROR		if the object is NULL or not a function.
*	PRO_EMPTY_DOMAIN 	if the windowed function would have an empty
*				domain.
*	RL_MEMORY_ERROR		on memory allocation error.
*	FORTRAN_POINTER_ERROR	if object 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_windowfunc) (object, x1, x2)
RL_INT4 *object;
RL_FLT8 *x1, *x2;
{
RL_VOID *ptr1, *ptr2;
RL_INT4 index;

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

    /* Call function */
    ptr2 = (RL_VOID *) Pro_WindowFunc((PRO_OBJECT *) ptr1, *x1, *x2);
    if (ptr2 == NULL) return 0;

    /* Save new pointer */
    index = FORT_AddPointer(ptr2);
    if (index == 0) Pro_FreeObject((PRO_OBJECT *) ptr2);

    return index;
}

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