/*
******************************************************************************** * composit.c -- Routines for composite function objects * * User routines: * Pro_CompFunc(inner,outer) creates a new function object that * returns a function of a function, i.e. * y = outer(inner(x)). * * Mark Showalter & Neil Heather, PDS Ring-Moon Systems Node, February 1998 *******************************************************************************/ #include <stdio.h> #include <string.h> #include "profile.h" #include "fortran.h" /******************** * Type definitions * ********************/ typedef struct ZPRO_COMPFUNC_STRUCT { XPRO_CLASS class; PRO_OBJECT *inner, *outer; RL_FLT8 outer_x1, outer_x2; } ZPRO_COMPFUNC; /******************** * Static variables * ********************/ static XPRO_CLASS compfunc_class = {XPRO_COMPFUNC_CLASS, "composite", NULL}; /******************************** * Internal function prototypes * ********************************/ static RL_FLT8 ZPro_EvalComp RL_PROTO((RL_VOID *pointer, RL_FLT8 x)); static void ZPro_FreeComp RL_PROTO((RL_VOID *pointer)); static void ZPro_PrintComp RL_PROTO((RL_VOID *pointer)); /* ******************************************************************************** * EXPORTED USER ROUTINES ******************************************************************************** *$ Component_name: * Pro_CompFunc (composit.c) *$ Abstract: * This routine generates a new composite function object involving one * function of another. The result returned is outer(inner(x)). *$ Keywords: * PROFILE, FUNCTION * C, PUBLIC, SUBROUTINE *$ Declarations: * PRO_OBJECT *Pro_CompFunc(inner, outer) * PRO_OBJECT *inner, *outer; *$ Inputs: * inner pointer to the inner function object (evaluated first). * outer pointer to the outer function object (evaluated second). *$ Outputs: * none *$ Returns: * pointer to a new function object, or NULL on non-fatal error. *$ Detailed_description: * This routine generates a new composite function object involving one * function of another. The result returned is outer(inner(x)). *$ External_references: * Profile toolkit *$ Side_effects: * Memory is allocated. The new object retains links both functions. *$ Examples: * Suppose sqroot is a function object that returns the square root of x; * suppose square is a function object that returns the square of x. * * func = Pro_CompFunc(square, sqroot); * * Then Pro_FuncValue(func, 2.) returns 2.; * Pro_FuncValue(func, 1.) returns 1.; * Pro_FuncValue(func, 0.) returns 0.; * Pro_FuncValue(func, -1.) returns 1.; *$ Error_handling: * Profile library error handling is in effect. * * Conditions raised: * PRO_CLASS_ERROR if either argument is NULL or not a function. * PRO_COORD_MISMATCH if the coordinate names do not match. * 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_CompFunc(inner, outer) PRO_OBJECT *inner, *outer; { PRO_OBJECT *new; ZPRO_COMPFUNC *compfunc; RL_FLT8 x1, x2, size; /* Determine domain and validate inner function */ size = Pro_ObjectDomain(inner, &x1, &x2); if (size == 0.) return NULL; /* Test coordinate names */ if (strcmp(Pro_ObjectName(outer,1), Pro_ObjectName(inner,2)) != 0) { XPro_CoordMismatch("composite function", inner, outer, Pro_ObjectName(inner,2), Pro_ObjectName(outer,1)); } /* Create and initialize data structure */ compfunc = (ZPRO_COMPFUNC *) XRL_Malloc(sizeof(ZPRO_COMPFUNC)); if (compfunc == NULL) return NULL; compfunc->class = compfunc_class; compfunc->inner = inner; compfunc->outer = outer; (void) Pro_ObjectDomain(outer, &(compfunc->outer_x1), &(compfunc->outer_x2)); /* Create object */ new = XPro_MakeFunc(x1, x2, ZPro_EvalComp, ZPro_FreeComp, ZPro_PrintComp, (RL_VOID *) compfunc); /* Enslave old functions and check for errors */ if (new != NULL && (XPro_EnslaveObject(new,inner) || XPro_EnslaveObject(new,outer))) { Pro_FreeObject(new); new = NULL; } /* Transfer coordinate names to new object */ Pro_RenameObject(new, 1, Pro_ObjectName(inner,1)); Pro_RenameObject(new, 2, Pro_ObjectName(outer,2)); return new; } /* ******************************************************************************** * INTERNAL ROUTINES ******************************************************************************** * ZPro_EvalComp(pointer, x) * * This internal routine calculates the value of a composite function. * * Inputs: * pointer pointer to the ZPRO_COMPFUNC data structure. * x location at which to evaluate composite function. * * Return: value of composite function at x. * * Errors: * PRO_EVALUATION_FAILURE if result of inner function falls outside * domain of outer function. *******************************************************************************/ static RL_FLT8 ZPro_EvalComp(pointer, x) RL_VOID *pointer; RL_FLT8 x; { ZPRO_COMPFUNC *compfunc; RL_FLT8 y1, y2; compfunc = (ZPRO_COMPFUNC *) pointer; /* Evaluate inner function */ y1 = Pro_FuncValue(compfunc->inner, x); /* Check range for valid input to outer function */ if (y1 < compfunc->outer_x1 || y1 > compfunc->outer_x2) { (void) sprintf(xpro_message, "function evaluation failure\n\ intermediate result falls outside domain in composite function\n\ f(%#g) = %#g in inner function \"%s\"\n\ domain = [%#g, %#g] in outer function \"%s\"", x, y1, Pro_ObjectName(compfunc->inner,0), compfunc->outer_x1, compfunc->outer_x2, Pro_ObjectName(compfunc->outer,0)); RL_RaiseError("PRO_EVALUATION_FAILURE", xpro_message); if (y1 < compfunc->outer_x1) y1 = compfunc->outer_x1; else y1 = compfunc->outer_x2; } y2 = Pro_FuncValue(compfunc->outer, y1); return y2; } /* ******************************************************************************** * ZPro_FreeComp(pointer) * * This internal routine frees the memory used by a ZPRO_COMPFUNC structure. * * Inputs: * pointer pointer to the ZPRO_COMPFUNC data structure. *******************************************************************************/ static void ZPro_FreeComp(pointer) void *pointer; { XRL_Free(pointer); } /* ******************************************************************************** * ZPro_PrintComp(pointer) * * This internal routine prints out information about a composite function. It * is called by Pro_PrintFunc() and is used mainly for debugging. * * Input: * pointer pointer to the ZPRO_COMPFUNC structure. *******************************************************************************/ static void ZPro_PrintComp(pointer) RL_VOID *pointer; { ZPRO_COMPFUNC *compfunc; compfunc = (ZPRO_COMPFUNC *) pointer; /* Make sure object is not NULL */ if (compfunc == NULL) { printf("PRINT ERROR: Composite function pointer is NULL\n"); return; } /* Make sure object is a composite function */ if (compfunc->class.id != XPRO_COMPFUNC_CLASS) { printf("PRINT ERROR: Object is not a composite function\n"); return; } /* Print object info... */ printf("\nComposite function parameters...\n"); printf("inner function = "); XPro_PrintInfo(compfunc->inner); printf("outer function = "); XPro_PrintInfo(compfunc->outer); return; } /* ******************************************************************************** * FORTRAN INTERFACE ROUTINES ******************************************************************************** *$ Component_name: * FPro_CompFunc (composit.c) *$ Abstract: * This routine generates a new composite function object involving one * function of another. The result returned is outer(inner(x)). *$ Keywords: * PROFILE, FUNCTION * FORTRAN, PUBLIC, SUBROUTINE *$ Declarations: * integer*4 function FPro_CompFunc(inner, outer) * integer*4 inner, outer *$ Inputs: * inner FORTRAN pointer to inner function (evaluated first). * outer FORTRAN pointer to outer function (evaluated second). *$ Outputs: * none *$ Returns: * FORTRAN pointer to a new function object, or 0 on non-fatal error. *$ Detailed_description: * This routine generates a new composite function object involving one * function of another. The result returned is outer(inner(x)). *$ External_references: * Profile toolkit *$ Side_effects: * Memory is allocated. The new object retains links both functions. *$ Examples: * Suppose sqroot is a function object that returns the square root of x; * suppose square is a function object that returns the square of x. * * func = FPro_CompFunc(square, sqroot) * * Then FPro_FuncValue(func, 2.d0) returns 2.d0 * FPro_FuncValue(func, 1.d0) returns 1.d0 * FPro_FuncValue(func, 0.d0) returns 0.d0 * FPro_FuncValue(func, -1.d0) returns 1.d0 *$ Error_handling: * Profile library error handling is in effect. * * Conditions raised: * PRO_CLASS_ERROR if either argument is NULL or not a function. * PRO_COORD_MISMATCH if the coordinate names do not match. * RL_MEMORY_ERROR on memory allocation error. * FORTRAN_POINTER_ERROR if object is not a valid FORTRAN object pointer. *$ Limitations: * none *$ Author_and_institution: * Mark R. Showalter * NASA/Ames Research Center *$ Version_and_date: * 1.0: March 1998 *$ Change_history: * none *******************************************************************************/ RL_INT4 FORTRAN_NAME(fpro_compfunc) (inner, outer) RL_INT4 *inner, *outer; { RL_VOID *ptr1, *ptr2, *ptr3; RL_INT4 index; /* Look up function pointers */ ptr1 = FORT_GetPointer(*inner); if (ptr1 == NULL) return 0; ptr2 = FORT_GetPointer(*outer); if (ptr2 == NULL) return 0; /* Call function */ ptr3 = (RL_VOID *) Pro_CompFunc((PRO_OBJECT *) ptr1, (PRO_OBJECT *) ptr2); if (ptr3 == NULL) return 0; /* Save new pointer */ index = FORT_AddPointer(ptr3); if (index == 0) Pro_FreeObject((PRO_OBJECT *) ptr3); return index; } /********************************************************************************/