/* triangle.c
********************************************************************************
* triangle.c -- Routines for triangle function objects
*
* User routines:
* Pro_TriangleFunc() creates a triangle function object.
* Pro_TriangleInfo() returns information about a triangle function.
*
* Mark Showalter, PDS Ring-Moon Systems Node, March 1998
*******************************************************************************/
#include <stdio.h>
#include "profile.h"
#include "fortran.h"
/********************
* Type definitions *
********************/
typedef struct ZPRO_TRIANGLE_STRUCT {
RL_INT4 flag;
RL_FLT8 height, halfwidth, norm;
} ZPRO_TRIANGLE;
/**********************
* Symbol definitions *
**********************/
#define ZPRO_TRIANGLE_FLAG 'tria'
/************************************
* Prototypes of internal functions *
************************************/
static RL_FLT8 ZPro_TriangleCalc RL_PROTO((RL_FLT8 x, RL_VOID *params));
static void ZPro_PrintTriangle RL_PROTO((RL_VOID *params));
/*
********************************************************************************
* EXPORTED USER ROUTINES
********************************************************************************
*$ Component_name:
* Pro_TriangleFunc (triangle.c)
*$ Abstract:
* This routine creates and returns a triangle function object. A triangle
* function returns a value that decreases linearly from the origin,
* reaching zero at its endpoints.
*$ Keywords:
* PROFILE, FUNCTION, PSF
* C, PUBLIC, SUBROUTINE
*$ Declarations:
* PRO_OBJECT *Pro_TriangleFunc(height, halfwidth)
* RL_FLT8 height, halfwidth;
*$ Inputs:
* height y-value of function at origin.
* halfwidth x-value at which y-value first reaches zero.
*$ Outputs:
* none
*$ Returns:
* pointer to a new triangle function object, or NULL on non-fatal error.
*$ Detailed_description:
* This routine creates and returns a triangle function object. A triangle
* function returns a value that decreases linearly from the origin,
* reaching zero at its endpoints. The x and y coordinates are initially
* unnamed.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* Memory is allocated.
*$ Examples:
* This line of code creates a triangle function of full width 2 and height
* 0.5.
*
* triangle = Pro_TriangleFunc(0.5, 1.);
*$ Error_handling:
* Profile toolkit 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_TriangleFunc(height, halfwidth)
RL_FLT8 height, halfwidth;
{
ZPRO_TRIANGLE *params;
PRO_OBJECT *func;
RL_INT4 paramsize;
paramsize = sizeof(ZPRO_TRIANGLE);
params = (ZPRO_TRIANGLE *) XRL_Malloc(paramsize);
if (params == NULL) return NULL;
params->flag = ZPRO_TRIANGLE_FLAG;
params->height = height;
params->halfwidth = halfwidth;
params->norm = height / halfwidth;
func = Pro_SoftFunc(ZPro_TriangleCalc, -halfwidth, halfwidth,
(RL_VOID *) params, paramsize, TRUE, ZPro_PrintTriangle);
XRL_Free((RL_VOID *) params);
return func;
}
/*
********************************************************************************
*$ Component_name:
* Pro_TriangleInfo (triangle.c)
*$ Abstract:
* This routine returns information about a triangle function object.
*$ Keywords:
* PROFILE, FUNCTION, PSF
* C, PUBLIC, SUBROUTINE
*$ Declarations:
* RL_BOOL Pro_TriangleInfo(triangle, height, halfwidth)
* PRO_OBJECT *triangle;
* RL_FLT8 *height, *halfwidth;
*$ Inputs:
* triangle pointer to a triangle function object.
*$ Outputs:
* *height height of triangle function at origin.
* *halfwidth x-value above which y-value is zero.
*$ Returns:
* TRUE if this is a triangle function; FALSE otherwise.
*$ Detailed_description:
* This routine returns information about a triangle function object.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* none
*$ Examples:
* This snippet of code of code prints the full width of a triangle
* function.
*
* PRO_OBJECT *triangle;
* RL_FLT8 halfwidth;
*
* Pro_TriangleInfo(boxcar, NULL, &halfwidth);
* printf("Full width = %g\n", 2.*halfwidth);
*$ Error_handling:
* Profile toolkit error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if this is not a software function object.
*$ Limitations:
* none
*$ Author_and_institution:
* Mark R. Showalter
* NASA/Ames Research Center
*$ Version_and_date:
* 1.0: March 1998
*$ Change_history:
* none
*******************************************************************************/
RL_BOOL Pro_TriangleInfo(triangle, height, halfwidth)
PRO_OBJECT *triangle;
RL_FLT8 *height, *halfwidth;
{
ZPRO_TRIANGLE *params;
params = (ZPRO_TRIANGLE *) XPro_SoftParams(triangle);
if (params == NULL) return FALSE;
if (params->flag != ZPRO_TRIANGLE_FLAG) return FALSE;
if (height != NULL) *height = params->height;
if (halfwidth != NULL) *halfwidth = params->halfwidth;
return TRUE;
}
/*
*******************************************************************************
* ZPro_PrintTriangle(params)
*
* This internal routine prints information about a triangle function.
*
* Inputs:
* params pointer to the ZPRO_TRIANGLE data structure.
*******************************************************************************/
static void ZPro_PrintTriangle(params)
RL_VOID *params;
{
ZPRO_TRIANGLE *tripar;
tripar = (ZPRO_TRIANGLE *) params;
/* Print triangle object info... */
printf("\nTriangle software function parameters...\n");
printf(" height = %#g\n", tripar->height);
printf("halfwidth = %#g\n", tripar->halfwidth);
}
/*
*******************************************************************************
* INTERNAL ROUTINES
********************************************************************************
* ZPro_TriangleCalc(x, params)
*
* This internal routine calculates the value of a triangle function.
*
* Inputs:
* x location at which to evaluate function.
* params pointer to the ZPRO_TRIANGLE data structure.
*
* Return: value of function at x.
*******************************************************************************/
static RL_FLT8 ZPro_TriangleCalc(x, params)
RL_FLT8 x;
RL_VOID *params;
{
ZPRO_TRIANGLE *tripar;
tripar = (ZPRO_TRIANGLE *) params;
if (x < 0.) x = -x;
return tripar->norm * (tripar->halfwidth - x);
}
/*
********************************************************************************
* FORTRAN INTERFACE ROUTINES
********************************************************************************
*$ Component_name:
* FPro_TriangleFunc (triangle.c)
*$ Abstract:
* This routine creates and returns a triangle function object. A triangle
* function returns a value that decreases linearly from the origin,
* reaching zero at its endpoints.
*$ Keywords:
* PROFILE, FUNCTION, PSF
* FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
* integer*4 function FPro_TriangleFunc(height, halfwidth)
* real*8 height, domain
*$ Inputs:
* height y-value of function at origin.
* halfwidth x-value at which y-value first reaches zero.
*$ Outputs:
* none
*$ Returns:
* FORTRAN pointer to a new triangle function object, or 0 on non-fatal
* error.
*$ Detailed_description:
* This routine creates and returns a triangle function object. A triangle
* function returns a value that decreases linearly from the origin,
* reaching zero at its endpoints. The x and y coordinates are initially
* unnamed.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* Memory is allocated.
*$ Examples:
* This line of code creates a triangle function of full width 2 and height
* 0.5.
*
* triangle = FPro_TriangleFunc(0.5d0, 1.d0)
*$ Error_handling:
* Profile toolkit 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_trianglefunc) (height, halfwidth)
RL_FLT8 *height, *halfwidth;
{
RL_VOID *ptr;
RL_INT4 index;
ptr = (RL_VOID *) Pro_TriangleFunc(*height, *halfwidth);
if (ptr == NULL) return 0;
index = FORT_AddPointer(ptr);
if (index == 0) Pro_FreeObject((PRO_OBJECT *) ptr);
return index;
}
/*
********************************************************************************
*$ Component_name:
* FPro_TriangleInfo (triangle.c)
*$ Abstract:
* This routine returns information about a triangle function object.
*$ Keywords:
* PROFILE, FUNCTION, PSF
* FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
* logical*4 function FPro_TriangleInfo(triangle, height, halfwidth)
* integer*4 triangle
* real*8 height, halfwidth
*$ Inputs:
* triangle FORTRAN pointer to a triangle function object.
*$ Outputs:
* height height of triangle function at origin.
* halfwidth x-value above which y-value is zero.
*$ Returns:
* .TRUE. if this is a triangle function; .FALSE. otherwise.
*$ Detailed_description:
* This routine returns information about a triangle function object.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* none
*$ Examples:
* This snippet of code of code prints the full width of a triangle
* function.
*
* integer*4 triangle
* real*8 dummy, halfwidth
*
* call FPro_TriangleInfo(triangle, dummy, halfwidth)
* write(*,*) "Full width = ", 2.d0*halfwidth
*$ Error_handling:
* Profile toolkit error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if this is not a software function object.
* FORTRAN_POINTER_ERROR if triangle is not a 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_triangleinfo) (triangle, height, halfwidth)
RL_INT4 *triangle;
RL_FLT8 *height, *halfwidth;
{
RL_VOID *ptr;
RL_BOOL status;
/* Look up triangle function pointer */
ptr = FORT_GetPointer(*triangle);
if (ptr == NULL) return 0;
/* Return info */
status = Pro_TriangleInfo(ptr, height, halfwidth);
return status ? FTRUE:FFALSE;
}
/*******************************************************************************
*/