/* 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., &param, 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., &param, 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, &param, 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;
}

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