/* software.c ********************************************************************************
* software.c -- Routines for software function objects
*
* User routines:
* Pro_SoftFunc() creates a function object that returns the
* value of a user-defined subroutine.
* Pro_SoftFunc1() creates a new function object that performs a
* calculation on the result returned by a given
* function object.
* Pro_SoftFunc2() creates a new function object that performs a
* calculation on the results returned by two given
* function objects.
*
* Programmer routines:
* XPro_SoftParams() returns a pointer to the parameter set.
*
* Neil Heather & Mark Showalter, PDS Ring-Moon Systems Node, March 1998
*******************************************************************************/
#include <stdio.h>
#include <string.h>
#include "profile.h"
#include "fortran.h"
/********************
* Type definitions *
********************/
typedef struct ZPRO_SOFTFUNC_STRUCT {
XPRO_CLASS class;
RL_FLT8 (*calc1) RL_PROTO((RL_FLT8 x, RL_VOID *params));
RL_FLT8 (*calc2) RL_PROTO((RL_FLT8 x1, RL_FLT8 x2, RL_VOID *params));
PRO_OBJECT *object1, *object2;
RL_VOID *params;
RL_INT4 paramsize;
RL_BOOL isduped;
void (*printmore) RL_PROTO((RL_VOID *params));
} ZPRO_SOFTFUNC;
/********************
* Static variables *
********************/
static XPRO_CLASS softfunc_class = {XPRO_SOFTFUNC_CLASS, "software", NULL};
/********************************
* Internal function prototypes *
********************************/
static RL_FLT8 ZPro_EvalSoft RL_PROTO((RL_VOID *pointer, RL_FLT8 x));
static RL_FLT8 ZPro_EvalSoft1 RL_PROTO((RL_VOID *pointer, RL_FLT8 x));
static RL_FLT8 ZPro_EvalSoft2 RL_PROTO((RL_VOID *pointer, RL_FLT8 x));
static void ZPro_FreeSoft RL_PROTO((RL_VOID *pointer));
static void ZPro_PrintSoft RL_PROTO((RL_VOID *pointer));
static RL_BOOL ZPro_FillParams RL_PROTO((ZPRO_SOFTFUNC *softfunc,
RL_VOID *params));
/*
********************************************************************************
* EXPORTED USER ROUTINES
********************************************************************************
*$ Component_name:
* Pro_SoftFunc (software.c)
*$ Abstract:
* This routine generates a function object that returns the value of a
* user-written subroutine.
*$ Keywords:
* PROFILE, FUNCTION
* C, PUBLIC, SUBROUTINE
*$ Declarations:
* PRO_OBJECT *Pro_SoftFunc(calc, x1, x2, params, paramsize, dupe,
* printmore)
* RL_FLT8 (*calc) (RL_FLT8 x, RL_VOID *params);
* RL_FLT8 x1, x2;
* RL_VOID *params;
* RL_SIZE paramsize;
* RL_BOOL dupe;
* void (*printmore) (RL_VOID *params);
*$ Inputs:
* calc subroutine to calculate function values.
* x1, x2 domain limits.
* params function parameters.
* paramsize size of parameters in bytes.
* dupe FALSE if only the parameter pointer needs to be saved;
* TRUE if the parameter set must be copied.
* printmore optional subroutine to print more info about function;
* NULL to ignore.
*$ Outputs:
* none
*$ Returns:
* pointer to a new software function object, or NULL on non-fatal error.
*$ Detailed_description:
* This routine generates a function object that returns the value of a
* user-written subroutine. The x and y coordinates are initially unnamed.
*
* The user-written subroutine must take two arguments and return a
* double-precision floating-point number. The first argument is the
* location at which to evaluate the function. The second argument is a
* pointer to an arbitrary data structure used by the subroutine, which
* might for example contain parameters needed to evaluate the function.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* Memory is allocated.
*$ Examples:
* Suppose we have this function that returns x**k:
* RL_FLT8 foo(x,k)
* RL_FLT8 x,k
* {
* return exp(k * log(x));
* }
*
* param = 0.5;
* Pro_SoftFunc(foo, 0., 100., ¶m, 8, FALSE, NULL);
* creates a software function that returns the square root of x
* for 0. <= x <= 100.
*
* param = 2.;
* Pro_SoftFunc(foo, 0., 10., ¶m, 8, FALSE, NULL);
* creates a software function that returns the square of x
* for 0. <= x <= 10.
*$ Error_handling:
* Profile library error handling is in effect.
*
* Conditions raised:
* 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_SoftFunc(calc, x1, x2, params, paramsize, dupe, printmore)
RL_FLT8 (*calc) RL_PROTO((RL_FLT8 x, RL_VOID *params));
RL_FLT8 x1, x2;
RL_VOID *params;
RL_SIZE paramsize;
RL_BOOL dupe;
void (*printmore) RL_PROTO((RL_VOID *params));
{
ZPRO_SOFTFUNC *softfunc;
PRO_OBJECT *new;
RL_BOOL status;
/* Allocate and initialize structure */
softfunc = (ZPRO_SOFTFUNC *) XRL_Malloc(sizeof(ZPRO_SOFTFUNC));
if (softfunc == NULL) return NULL;
softfunc->class = softfunc_class;
softfunc->calc1 = calc;
softfunc->calc2 = NULL;
softfunc->object1 = NULL;
softfunc->object2 = NULL;
softfunc->params = NULL;
softfunc->paramsize = paramsize;
softfunc->isduped = dupe;
softfunc->printmore = printmore;
status = ZPro_FillParams(softfunc, params);
if (!status) {
XRL_Free((RL_VOID *) softfunc);
return NULL;
}
/* Create function object */
new = XPro_MakeFunc(x1, x2, ZPro_EvalSoft, ZPro_FreeSoft, ZPro_PrintSoft,
(RL_VOID *) softfunc);
return new;
}
/*
********************************************************************************
*$ Component_name:
* Pro_SoftFunc1 (software.c)
*$ Abstract:
* This routine generates a new function object that performs a calculation
* on the result returned by a given function object.
*$ Keywords:
* PROFILE, FUNCTION
* C, PUBLIC, SUBROUTINE
*$ Declarations:
* PRO_OBJECT *Pro_SoftFunc1(object, calc, params, paramsize, dupe,
* printmore)
* PRO_OBJECT *object;
* RL_FLT8 (*calc) (RL_FLT8 y, RL_VOID *params);
* RL_VOID *params;
* RL_SIZE paramsize;
* RL_BOOL dupe;
* void (*printmore) (RL_VOID *params);
*$ Inputs:
* object pointer to a function to evaluate.
* calc routine to modify function values.
* params function parameters.
* paramsize size of parameters in bytes.
* dupe FALSE if only the parameter pointer needs to be saved;
* TRUE if the parameter set must be saved.
* printmore optional subroutine to print more info about function;
* NULL to ignore.
*$ Outputs:
* none
*$ Returns:
* pointer to a new software function object, or NULL on non-fatal error.
*$ Detailed_description:
* This routine generates a new function object that performs a calculation
* on the result returned by a given function object. The domain and
* x coordinate name match that of the given function; the y coordinate is
* initially unnamed.
*
* The user-written subroutine must take two arguments and return a
* double-precision floating-point number. The first argument is the
* value returned by the given function object. The second argument is a
* pointer to an arbitrary data structure used by the subroutine, which
* might for example contain parameters needed to evaluate the function.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* Memory is allocated. The new object links to the given function object.
*$ Examples:
* Suppose we have this function that returns x**k:
* RL_FLT8 foo(x,k)
* RL_FLT8 x,k
* {
* return exp(k * log(x));
* }
* Suppose we have a function object func that returns f(x).
*
* param = 0.5;
* Pro_SoftFunc1(func, foo, ¶m, 8, FALSE, NULL);
* creates a software function that returns the square root of f(x)
*$ Error_handling:
* Profile library error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if the object is NULL or not a function.
* RL_MEMORY_ERROR on memory allocation failure.
*$ 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_SoftFunc1(object, calc, params, paramsize, dupe,
printmore)
PRO_OBJECT *object;
RL_FLT8 (*calc) RL_PROTO((RL_FLT8 y, RL_VOID *params));
RL_VOID *params;
RL_SIZE paramsize;
RL_BOOL dupe;
void (*printmore) RL_PROTO((RL_VOID *params));
{
ZPRO_SOFTFUNC *softfunc;
PRO_OBJECT *new;
RL_BOOL status;
RL_FLT8 x1, x2, size;
/* Determine domain and validate old function */
size = Pro_ObjectDomain(object, &x1, &x2);
if (size == 0.) return NULL;
/* Allocate and initialize structure */
softfunc = (ZPRO_SOFTFUNC *) XRL_Malloc(sizeof(ZPRO_SOFTFUNC));
if (softfunc == NULL) return NULL;
softfunc->class = softfunc_class;
softfunc->calc1 = calc;
softfunc->calc2 = NULL;
softfunc->object1 = object;
softfunc->object2 = NULL;
softfunc->params = NULL;
softfunc->paramsize = paramsize;
softfunc->isduped = dupe;
softfunc->printmore = printmore;
status = ZPro_FillParams(softfunc, params);
if (!status) {
XRL_Free((RL_VOID *) softfunc);
return NULL;
}
/* Create new function */
new = XPro_MakeFunc(x1, x2,
ZPro_EvalSoft1, ZPro_FreeSoft, ZPro_PrintSoft,
(RL_VOID *) softfunc);
/* Enslave old function and check for errors */
if (new != NULL && XPro_EnslaveObject(new,object)) {
Pro_FreeObject(new);
new = NULL;
}
/* Transfer X-coordinate name to new function */
Pro_RenameObject(new, 1, Pro_ObjectName(object,1));
return new;
}
/*
********************************************************************************
*$ Component_name:
* Pro_SoftFunc2 (software.c)
*$ Abstract:
* This routine generates a new function object that performs a calculation
* on the results returned by a pair of given function objects.
*$ Keywords:
* PROFILE, FUNCTION
* C, PUBLIC, SUBROUTINE
*$ Declarations:
* PRO_OBJECT *Pro_SoftFunc2(object1, object2, calc,
* params, paramsize, dupe, printmore)
* PRO_OBJECT *object1, *object2;
* RL_FLT8 (*calc) (RL_FLT8 y1, RL_FLT8 y2, RL_VOID *params);
* RL_VOID *params;
* RL_SIZE paramsize;
* RL_BOOL dupe;
* void (*printmore) (RL_VOID *params);
*$ Inputs:
* object1, object2 pointers to the function objects to evaluate.
* calc routine to modify function values.
* params function parameters.
* paramsize size of parameters in bytes.
* dupe FALSE if only the parameter pointer needs to be saved;
* TRUE if the parameter set must be saved.
* printmore optional subroutine to print more info about function;
* NULL to ignore.
*$ Outputs:
* none
*$ Returns:
* pointer to a new software function object, or NULL on non-fatal error.
*$ Detailed_description:
* This routine generates a new function object that performs a calculation
* on the results returned by a pair of given function objects. The domain
* of the new function is the intersection the domains of the two function
* objects. The new x coordinate name matches that of the first function
* object; the new y coordinate is initially unnamed.
*
* The user-written subroutine must take three arguments and return a
* double-precision floating-point number. The first two arguments are the
* values returned by each of the given function objects, in order. The
* third argument is a pointer to an arbitrary data structure used by the
* subroutine, which might for example contain parameters needed to
* evaluate the function.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* Memory is allocated. The new object links to both of the given function
* objects.
*$ Examples:
* Suppose we have this function that returns x/y:
* RL_FLT8 div(x,y,params)
* RL_FLT8 x,y,params;
* {
* return x/y;
* }
* Suppose we have a curve object radius that returns r(x).
* Suppose we have a curve object time that returns t(x).
*
* Pro_Object *drdx, *dtdx, *drdt;
*
* drdx = Pro_SlopeFunc(radius);
* dtdx = Pro_SlopeFunc(time);
* drdt = ro_SoftFunc2(drdx, dtdx, div, 0., 0, FALSE);
*
* Here drdt is a function that returns the radial velocity, drdt(x).
*$ Error_handling:
* Profile library error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if either object is NULL or not a function.
* PRO_EMPTY_DOMAIN if new function would have an empty domain.
* PRO_COORD_MISMATCH if function x-coordinate names do not match; in
* this case a valid function is returned, using
* x-coordinate name of the first function object.
* RL_MEMORY_ERROR on memory allocation failure.
*$ 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_SoftFunc2(object1, object2, calc,
params, paramsize, dupe, printmore)
PRO_OBJECT *object1, *object2;
RL_FLT8 (*calc) RL_PROTO((RL_FLT8 y1, RL_FLT8 y2, RL_VOID *params));
RL_VOID *params;
RL_SIZE paramsize;
RL_BOOL dupe;
void (*printmore) RL_PROTO((RL_VOID *params));
{
ZPRO_SOFTFUNC *softfunc;
PRO_OBJECT *new;
RL_BOOL status;
RL_FLT8 x1, x2, size;
/* Determine domain and validate both functions */
size = Pro_ObjectOverlap(object1, object1, &x1, &x2);
size = Pro_ObjectOverlap(object2, object1, &x1, &x2);
if (size <= 0.) return NULL;
/* Allocate and initialize structure */
softfunc = (ZPRO_SOFTFUNC *) XRL_Malloc(sizeof(ZPRO_SOFTFUNC));
if (softfunc == NULL) return NULL;
softfunc->class = softfunc_class;
softfunc->calc1 = NULL;
softfunc->calc2 = calc;
softfunc->object1 = object1;
softfunc->object2 = object2;
softfunc->params = NULL;
softfunc->paramsize = paramsize;
softfunc->isduped = dupe;
softfunc->printmore = printmore;
status = ZPro_FillParams(softfunc, params);
if (!status) {
XRL_Free((RL_VOID *) softfunc);
return NULL;
}
/* Create new function */
new = XPro_MakeFunc(x1, x2,
ZPro_EvalSoft2, ZPro_FreeSoft, ZPro_PrintSoft,
(RL_VOID *) softfunc);
/* Enslave old functions and check for errors */
if (new != NULL && (XPro_EnslaveObject(new,object1) ||
XPro_EnslaveObject(new,object2))) {
Pro_FreeObject(new);
new = NULL;
}
/* Transfer first X-coordinate name to new function */
Pro_RenameObject(new, 1, Pro_ObjectName(object1,1));
return new;
}
/*
********************************************************************************
* PROGRAMMER ROUTINES
********************************************************************************
* XPro_SoftParams(object)
*
* This routine returns a pointer to the software function parameter structure.
*
* Inputs:
* object software function object.
*
* Return: pointer to the data structure, or NULL on error.
*
* Errors:
* PRO_CLASS_ERROR if object is NULL or is not a software function.
*******************************************************************************/
RL_VOID *XPro_SoftParams(object)
PRO_OBJECT *object;
{
ZPRO_SOFTFUNC *softfunc;
softfunc = (ZPRO_SOFTFUNC *) XPro_FuncPtr(object);
if (softfunc == NULL) return NULL;
return (softfunc->params);
}
/*
********************************************************************************
* INTERNAL ROUTINES
********************************************************************************
* ZPro_EvalSoft(x, pointer)
*
* This internal routine calculates the value of a simple software function, one
* not involving any secondary functions.
*
* Inputs:
* x location at which to evaluate software function.
* pointer pointer to a ZPRO_SOFTFUNC data structure.
*
* Return: value of software function at x.
*******************************************************************************/
static RL_FLT8 ZPro_EvalSoft(pointer, x)
RL_VOID *pointer;
RL_FLT8 x;
{
ZPRO_SOFTFUNC *softfunc;
softfunc = (ZPRO_SOFTFUNC *) pointer;
return (softfunc->calc1(x, softfunc->params));
}
/*
********************************************************************************
* ZPro_EvalSoft1(x, pointer)
*
* This internal routine calculates the value of a software function involving
* one secondary function.
*
* Inputs:
* x location at which to evaluate software function.
* pointer pointer to a ZPRO_SOFTFUNC data structure.
*
* Return: value of software function at x.
*******************************************************************************/
static RL_FLT8 ZPro_EvalSoft1(pointer, x)
RL_VOID *pointer;
RL_FLT8 x;
{
ZPRO_SOFTFUNC *softfunc;
RL_FLT8 y1;
softfunc = (ZPRO_SOFTFUNC *) pointer;
y1 = Pro_FuncValue(softfunc->object1, x);
return (softfunc->calc1(y1, softfunc->params));
}
/*
********************************************************************************
* ZPro_EvalSoft2(x, pointer)
*
* This internal routine calculates the value of a software function involving
* two secondary functions.
*
* Inputs:
* x location at which to evaluate software function.
* pointer pointer to a ZPRO_SOFTFUNC data structure.
*
* Return: value of software function at x.
*******************************************************************************/
static RL_FLT8 ZPro_EvalSoft2(pointer, x)
RL_VOID *pointer;
RL_FLT8 x;
{
ZPRO_SOFTFUNC *softfunc;
RL_FLT8 y1, y2;
softfunc = (ZPRO_SOFTFUNC *) pointer;
y1 = Pro_FuncValue(softfunc->object1, x);
y2 = Pro_FuncValue(softfunc->object2, x);
return (softfunc->calc2(y1, y2, softfunc->params));
}
/*
********************************************************************************
* ZPro_FreeSoft(pointer)
*
* This internal routine frees the memory used by a ZPRO_SOFTFUNC structure.
*
* Inputs:
* pointer pointer to the ZPRO_SOFTFUNC data structure.
*******************************************************************************/
static void ZPro_FreeSoft(pointer)
RL_VOID *pointer;
{
ZPRO_SOFTFUNC *softfunc;
softfunc = (ZPRO_SOFTFUNC *) pointer;
if (softfunc->isduped) XRL_Free(softfunc->params);
XRL_Free(softfunc);
}
/*
********************************************************************************
* ZPro_PrintSoft(pointer)
*
* This internal routine prints out information about a software function. It is
* called by Pro_PrintFunc() and is used mainly for debugging.
*
* Input:
* pointer pointer to the ZPRO_SOFTFUNC structure.
*******************************************************************************/
static void ZPro_PrintSoft(pointer)
RL_VOID *pointer;
{
ZPRO_SOFTFUNC *softfunc;
softfunc = (ZPRO_SOFTFUNC *) pointer;
/* Make sure object is not NULL */
if (softfunc == NULL) {
printf("PRINT ERROR: Software function pointer is NULL\n");
return;
}
/* Make sure object is a software function */
if (softfunc->class.id != XPRO_SOFTFUNC_CLASS) {
printf("PRINT ERROR: Object is not a software function\n");
return;
}
/* Print object info... */
printf("\nSoftware function parameters...\n");
printf("objects used = %1d\n", (softfunc->object1 == NULL ? 0 :
(softfunc->object2 == NULL ? 1 : 2)));
if (softfunc->object1 != NULL) {
printf(" object #1 = "); XPro_PrintInfo(softfunc->object1);
}
if (softfunc->object2 != NULL) {
printf(" object #2 = "); XPro_PrintInfo(softfunc->object2);
}
printf("func pointer = %x\n", (softfunc->calc1 != NULL ?
(RL_VOID *) softfunc->calc1 :
(RL_VOID *) softfunc->calc2));
printf(" paramsize = %d\n", softfunc->paramsize);
printf(" duplicated = %s\n", (softfunc->isduped ? "true" : "false"));
if (softfunc->printmore != NULL) {
(*softfunc->printmore) (softfunc->params);
}
return;
}
/*
********************************************************************************
* ZPro_FillParams(softfunc, params)
*
* This internal routine loads the parameter set into the ZPRO_SOFTFUNC
* structure. It either just enters the pointer or copies the data, depending
* on the value of the "isduped" field. It is called by Pro_SoftFunc(),
* Pro_SoftFunc1() and Pro_SoftFunc2().
*
* Input:
* softfunc pointer to the ZPRO_SOFTFUNC structure.
* params pointer to the parameter set.
*
* Output:
* softfunc params field is modified.
*
* Return: TRUE if parameter transfer succeeded; FALSE on error.
*
* Errors:
* RL_MEMORY_ERROR on memory allocation failure.
*******************************************************************************/
static RL_BOOL ZPro_FillParams(softfunc, params)
ZPRO_SOFTFUNC *softfunc;
RL_VOID *params;
{
/* Duplicate parameters if necessary */
if (softfunc->isduped && params != NULL && softfunc->paramsize > 0) {
softfunc->params = (RL_VOID *) XRL_Malloc(softfunc->paramsize);
if (softfunc->params == NULL) {
XRL_Free((RL_VOID *) softfunc);
return FALSE;
}
memcpy(softfunc->params, params, softfunc->paramsize);
} else {
softfunc->params = params;
}
return TRUE;
}
/*******************************************************************************
* FORTRAN INTERFACE ROUTINES
*******************************************************************************/
/* This data structure is used when the subroutine has been written in FORTRAN
* rather than C; in this case the "calc" functions pass X by reference rather
* than by value.
*/
typedef struct ZPRO_FPARAMS_STRUCT {
RL_FLT8 (*fcalc1) RL_PROTO((RL_FLT8 *x, RL_VOID *params));
RL_FLT8 (*fcalc2) RL_PROTO((RL_FLT8 *x1, RL_FLT8 *x2, RL_VOID *params));
RL_VOID *params; /* pointer to un-duplicated params, if needed */
RL_CHAR stuff; /* place to put duplicated params, if needed */
} ZPRO_FPARAMS;
/* Each of these internal functions calls the analogous FORTRAN subroutine after
* converting the first argument(s) to pointer(s).
*/
RL_FLT8 ZPro_FCalc1 RL_PROTO((RL_FLT8 x, RL_VOID *fparams));
RL_FLT8 ZPro_FCalc2 RL_PROTO((RL_FLT8 x1, RL_FLT8 x2, RL_VOID *fparams));
/* This internal function sets up the parameter structure used by ZPro_FCalc1()
* and ZPro_FCalc2()
*/
ZPRO_FPARAMS *ZPro_FillFParams RL_PROTO((
RL_FLT8 (*calc1) (RL_FLT8 *x, RL_VOID *params),
RL_FLT8 (*calc2) (RL_FLT8 *x1, RL_FLT8 *x2, RL_VOID *params),
RL_VOID *params,
RL_SIZE paramsize,
RL_BOOL dupe,
RL_SIZE *fparamsize));
/*
********************************************************************************
*$ Component_name:
* FPro_SoftFunc (software.c)
*$ Abstract:
* This routine generates a function object that returns the value of a
* user-written subroutine.
*$ Keywords:
* PROFILE, FUNCTION
* FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
* integer*4 function FPro_SoftFunc(calc, x1, x2, params, paramsize, dupe)
* external calc
* real*8 x1, x2
* integer*4 params(*), paramsize
* logical*4 dupe
*$ Inputs:
* calc external subroutine to calculate function values.
* x1, x2 domain limits.
* params arbitrary array of function parameters.
* paramsize size of parameters in bytes.
* dupe .FALSE. if only a pointer to the parameter set needs to
* be saved; .TRUE. if the parameter set must be copied.
*$ Outputs:
* none
*$ Returns:
* FORTRAN pointer to a new software function object, or 0 on non-fatal error.
*$ Detailed_description:
* This routine generates a function object that returns the value of a
* user-written subroutine. The x and y coordinates are initially unnamed.
*
* The user-written subroutine must take two arguments and return a
* double-precision floating-point number. The first argument is the
* location at which to evaluate the function. The second argument is an
* arbitrary array used by the subroutine, which might for example contain
* parameters needed to evaluate the function.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* Memory is allocated.
*$ Examples:
* Suppose we have this function that returns x**k:
* real*8 function foo(x,k)
* real*8 x,k
* foo = x**k
* return
*
* Pro_SoftFunc(foo, 0.d0, 100.d0, 0.5d0, 8, .FALSE.)
* creates a software function that returns the square root of x
* for 0.d0 <= x <= 100.d0
*
* Pro_SoftFunc(foo, 0.d0, 10.d0, 2.d0, 8, .FALSE.)
* creates a software function that returns the square of x
* for 0.d0 <= x <= 10.d0
*$ Error_handling:
* Profile library error handling is in effect.
*
* Conditions raised:
* 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
*******************************************************************************/
RL_INT4 FORTRAN_NAME(fpro_softfunc) (fcalc, x1, x2, params, paramsize, dupe)
RL_FLT8 (*fcalc) RL_PROTO((RL_FLT8 *x, RL_VOID *params));
RL_FLT8 *x1, *x2;
RL_VOID *params;
RL_INT4 *paramsize, *dupe;
{
RL_VOID *ptr;
RL_INT4 index;
ZPRO_FPARAMS *fparams;
RL_SIZE fparamsize;
/* Set up substitute parameter set */
fparams = ZPro_FillFParams(fcalc, NULL, params, *paramsize, (RL_BOOL) *dupe,
&fparamsize);
if (fparams == NULL) return 0;
/* Call function */
ptr = (RL_VOID *) Pro_SoftFunc(ZPro_FCalc1, *x1, *x2,
fparams, fparamsize, TRUE, NULL);
XRL_Free((RL_VOID *) fparams);
if (ptr == NULL) return 0;
/* Save new pointer */
index = FORT_AddPointer(ptr);
if (index == 0) Pro_FreeObject((PRO_OBJECT *) ptr);
return index;
}
/*
********************************************************************************
*$ Component_name:
* FPro_SoftFunc1 (software.c)
*$ Abstract:
* This routine generates a new function object that performs a calculation
* on the result returned by a given function object.
*$ Keywords:
* PROFILE, FUNCTION
* FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
* integer*4 function FPro_SoftFunc1(object, calc, params, paramsize,
* dupe)
* integer*4 object
* external calc
* integer*4 params(*)
* integer*4 paramsize
* logical*4 dupe
*$ Inputs:
* object FORTRAN pointer to a function to evaluate.
* calc external routine to modify function values.
* params(*) arbitrary array of function parameters.
* paramsize size of the parameter array in bytes.
* dupe .FALSE. if only the parameter array pointer needs to be
* saved; .TRUE. if the array must be copied.
*$ Outputs:
* none
*$ Returns:
* FORTRAN pointer to a new software function object, or 0 on non-fatal
* error.
*$ Detailed_description:
* This routine generates a new function object that performs a calculation
* on the result returned by a given function object. The domain and
* x coordinate name match that of the given function; the y coordinate is
* initially unnamed.
*
* The user-written subroutine must take two arguments and return a
* double-precision floating-point number. The first argument is the
* value returned by the given function object. The second argument is a
* pointer to an arbitrary data structure used by the subroutine, which
* might for example contain parameters needed to evaluate the function.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* Memory is allocated. The new object links to the given function object.
*$ Examples:
* Suppose we have this function that returns x**k:
* real*8 function foo(x,k)
* real*8 x,k
* foo = x**k
* return
* Suppose we have a function object func that returns f(x).
*
* Pro_SoftFunc1(func, foo, 0.5, 8, .FALSE.)
* creates a software function that returns the square root of f(x)
*$ Error_handling:
* Profile library error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if the object is NULL or not a function.
* RL_MEMORY_ERROR on memory allocation failure.
* 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_softfunc1) (object, fcalc, params, paramsize, dupe)
RL_INT4 *object, *dupe;
RL_FLT8 (*fcalc) RL_PROTO((RL_FLT8 *y, RL_VOID *params));
RL_VOID *params;
RL_SIZE *paramsize;
{
RL_VOID *ptr1, *ptr2;
RL_INT4 index;
ZPRO_FPARAMS *fparams;
RL_SIZE fparamsize;
/* Look up function pointer */
ptr1 = FORT_GetPointer(*object);
if (ptr1 == NULL) return 0;
/* Set up substitute parameter set */
fparams = ZPro_FillFParams(fcalc, NULL, params, *paramsize, (RL_BOOL) *dupe,
&fparamsize);
if (fparams == NULL) return 0;
/* Call function */
ptr2 = (RL_VOID *) Pro_SoftFunc1((PRO_OBJECT *) ptr1, ZPro_FCalc1,
fparams, fparamsize, TRUE, NULL);
XRL_Free((RL_VOID *) fparams);
if (ptr2 == NULL) return 0;
/* Save new pointer */
index = FORT_AddPointer(ptr2);
if (index == 0) Pro_FreeObject((PRO_OBJECT *) ptr2);
return index;
}
/*
********************************************************************************
*$ Component_name:
* FPro_SoftFunc2 (software.c)
*$ Abstract:
* This routine generates a new function object that performs a calculation
* on the results returned by a pair of given function objects.
*$ Keywords:
* PROFILE, FUNCTION
* FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
* integer*4 function FPro_SoftFunc2(object1, object2, calc,
* params, paramsize, dupe)
* integer*4 object1, object2
* external calc
* integer*4 params(*)
* integer*4 paramsize
* logical*4 dupe
*$ Inputs:
* object1, object2 FORTRAN pointers to the function objects to evaluate.
* calc external routine to modify function values.
* params(*) arbitrary array of function parameters.
* paramsize size of the parameter array in bytes.
* dupe .FALSE. if only a pointer to the parameter array needs
* to be saved; .TRUE. if the array must be copied.
*$ Outputs:
* none
*$ Returns:
* FORTRAN pointer to a new software function object, or 0 on non-fatal
* error.
*$ Detailed_description:
* This routine generates a new function object that performs a calculation
* on the results returned by a pair of given function objects. The domain
* of the new function is the intersection the domains of the two function
* objects. The new x coordinate name matches that of the first function
* object; the new y coordinate is initially unnamed.
*
* The user-written subroutine must take three arguments and return a
* double-precision floating-point number. The first two arguments are the
* values returned by each of the given function objects, in order. The
* third argument is a pointer to an arbitrary array used by the
* subroutine, which might for example contain parameters needed to
* evaluate the function.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* Memory is allocated. The new object links to both of the given function
* objects.
*$ Examples:
* Suppose we have this function that returns x/y:
* real*8 function div(x,y,params)
* real*8 x,y,params
* foo = x/y
* return
* Suppose we have a curve object radius that returns r(x).
* Suppose we have a curve object time that returns t(x).
*
* integer*4 drdx, dtdx, drdt
*
* drdx = FPro_SlopeFunc(radius)
* dtdx = FPro_SlopeFunc(time)
* drdt = Pro_SoftFunc2(drdx, dtdx, div, 0.d0, 0, .FALSE.)
*
* Here drdt is a function that returns the radial velocity, drdt(x).
*$ Error_handling:
* Profile library error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if either object is NULL or not a function.
* PRO_EMPTY_DOMAIN if new function would have an empty domain.
* PRO_COORD_MISMATCH if function x-coordinate names do not match; in
* this case a valid function is returned, using
* x-coordinate name of the first function object.
* RL_MEMORY_ERROR on memory allocation failure.
* FORTRAN_POINTER_ERROR if either function object is not a valid FORTRAN
* 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_softfunc2) (object1, object2, fcalc,
params, paramsize, dupe)
RL_INT4 *object1, *object2, *dupe;
RL_FLT8 (*fcalc) RL_PROTO((RL_FLT8 *y1, RL_FLT8 *y2, RL_VOID *params));
RL_VOID *params;
RL_SIZE *paramsize;
{
RL_VOID *ptr1, *ptr2, *ptr3;
RL_INT4 index;
ZPRO_FPARAMS *fparams;
RL_SIZE fparamsize;
/* Look up function pointers */
ptr1 = FORT_GetPointer(*object1);
if (ptr1 == NULL) return 0;
ptr2 = FORT_GetPointer(*object2);
if (ptr2 == NULL) return 0;
/* Set up substitute parameter set */
fparams = ZPro_FillFParams(NULL, fcalc, params, *paramsize, (RL_BOOL) *dupe,
&fparamsize);
if (fparams == NULL) return 0;
/* Call function */
ptr3 = (RL_VOID *) Pro_SoftFunc2((PRO_OBJECT *) ptr1, (PRO_OBJECT *) ptr2,
ZPro_FCalc2, fparams, fparamsize, TRUE, NULL);
XRL_Free((RL_VOID *) fparams);
if (ptr3 == NULL) return 0;
/* Save new pointer */
index = FORT_AddPointer(ptr3);
if (index == 0) Pro_FreeObject((PRO_OBJECT *) ptr3);
return index;
}
/*
********************************************************************************
* ZPro_FCalc1(x, params)
*
* This internal routine calls the FORTRAN equivalent routine after converting
* the first argument to a pointer.
*******************************************************************************/
RL_FLT8 ZPro_FCalc1(x, params)
RL_FLT8 x;
RL_VOID *params;
{
ZPRO_FPARAMS *fparams;
fparams = (ZPRO_FPARAMS *) params;
if (fparams->params == NULL)
return (fparams->fcalc1) (&x, &(fparams->stuff));
else
return (fparams->fcalc1) (&x, fparams->params);
}
/*
*******************************************************************************
* ZPro_FCalc2(x1, x2, params)
*
* This internal routine calls the FORTRAN equivalent routine after converting
* the first two arguments to pointers.
*******************************************************************************/
RL_FLT8 ZPro_FCalc2(x1, x2, params)
RL_FLT8 x1, x2;
RL_VOID *params;
{
ZPRO_FPARAMS *fparams;
fparams = (ZPRO_FPARAMS *) params;
if (fparams->params == NULL)
return (fparams->fcalc2) (&x1, &x2, &(fparams->stuff));
else
return (fparams->fcalc2) (&x1, &x2, fparams->params);
}
/*
*******************************************************************************
* ZPro_FillFParams(fcalc1, fcalc2, params, paramsize, dupe, fparamsize)
*
* This internal function sets up the parameter structure used by ZPro_FCalc1()
* and ZPro_FCalc2().
*
* Input:
* fcalc1 pointer to a one-argument routine, or NULL.
* fcalc2 pointer to a two-argument routine, or NULL.
* params pointer to the parameter set needed by the routine.
* paramsize size of the parameter set in bytes.
* dupe TRUE to duplicate the parameter set; FALSE just to save
* the pointer.
*
* Output:
* *fparamsize size of the newly-constructed parameter set, in bytes.
*
* Return: a pointer to the parameter set, or NULL on failure.
*******************************************************************************/
ZPRO_FPARAMS *ZPro_FillFParams(fcalc1, fcalc2, params, paramsize, dupe,
fparamsize)
RL_FLT8 (*fcalc1) RL_PROTO((RL_FLT8 *x, RL_VOID *params));
RL_FLT8 (*fcalc2) RL_PROTO((RL_FLT8 *x1, RL_FLT8 *x2, RL_VOID *params));
RL_VOID *params;
RL_SIZE paramsize, *fparamsize;
RL_BOOL dupe;
{
ZPRO_FPARAMS *fparams;
/* Count bytes to allocate */
*fparamsize = sizeof(ZPRO_FPARAMS);
if (dupe) *fparamsize += paramsize; /* space to append additional params */
/* Allocate stucture */
fparams = (ZPRO_FPARAMS *) XRL_Malloc(*fparamsize);
if (fparams == NULL) return NULL;
/* Fill in function pointers */
fparams->fcalc1 = fcalc1;
fparams->fcalc2 = fcalc2;
/* Copy params onto end of structure if necessary */
if (dupe) {
memcpy(&(fparams->stuff), params, paramsize);
fparams->params = NULL;
}
else
fparams->params = params; /* otherwise point elsewhere */
return fparams;
}
/*******************************************************************************
*/