/*
******************************************************************************** * 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; } /********************************************************************************/