/* 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 Rings Node, March 1998
*******************************************************************************/
#include 
#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;
}

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