/* 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 Ring-Moon Systems 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 <stdio.h>
#include <string.h>
#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;
}
/*******************************************************************************
*/