/* stat.c
********************************************************************************
* stat.c -- Routines for statistical series objects
*
* User routines
* Pro_StatCovar() returns the covariance of a pair of series
* samples.
* Pro_StatRange() returns the range of samples correlated with a
* a specified sample.
*
* Programmer routines
* XPro_MakeStat() used to create a new statistical series object.
* XPro_StatPtr() returns a pointer to the sub-object.
*
* Version 1.0: Original release.
* Mark Showalter & Neil Heather, PDS Ring-Moon Systems Node, March 1998.
* Version 1.1: QUICK compilation mode and Pro_StatRange() function added.
* Mark Showalter, January 2000
*******************************************************************************/
#include <stdio.h>
#include "profile.h"
#include "fortran.h"
/********************
* Type definitions *
********************/
typedef struct ZPRO_STAT_STRUCT {
XPRO_CLASS class;
RL_FLT8 (*covarfunc) RL_PROTO((RL_VOID *pointer,
RL_INT4 k1, RL_INT4 k2));
void (*rangefunc) RL_PROTO((RL_VOID *pointer, RL_INT4 k,
RL_INT4 *k1, RL_INT4 *k2));
RL_FLT8 (*evalfunc) RL_PROTO((RL_VOID *pointer,
RL_INT4 k, RL_INT4 *flag));
void (*freefunc) RL_PROTO((RL_VOID *pointer));
void (*printfunc) RL_PROTO((RL_VOID *pointer));
} ZPRO_STAT;
/********************
* Static variables *
********************/
static XPRO_CLASS stat_class = {XPRO_STAT_CLASS, "statistical", NULL};
/********************************
* Internal function prototypes *
********************************/
static RL_FLT8 ZPro_EvalStat RL_PROTO((RL_VOID *pointer, RL_INT4 k,
RL_INT4 *flag));
static void ZPro_FreeStat RL_PROTO((RL_VOID *pointer));
static void ZPro_PrintStat RL_PROTO((RL_VOID *pointer));
static ZPRO_STAT *ZPro_GetStat RL_PROTO((PRO_OBJECT *object));
/*********************
* Macro definitions *
*********************/
#ifdef QUICK
#define ZPro_GetStat(object) ((ZPRO_STAT *) XPro_SeriesPtr(object))
#endif
/*
********************************************************************************
* EXPORTED USER ROUTINES
********************************************************************************
*$ Component_name:
* Pro_StatCovar (stat.c)
*$ Abstract:
* This routine returns the covariance between two samples in a statistical
* series.
*$ Keywords:
* PROFILE, SERIES
* C, PUBLIC, SUBROUTINE
*$ Declarations:
* RL_FLT8 Pro_StatCovar(object, k1, k2)
* PRO_OBJECT *object;
* RL_INT4 k1, k2;
*$ Inputs:
* object pointer to a statistical series object.
* k1, k2 sample indices for which to calculate covariance.
*$ Outputs:
* none
*$ Returns:
* value of the covariance between the given samples, or 0. on non-fatal
* error.
*$ Detailed_description:
* This routine returns the covariance between two samples in a statistical
* series. A statistical series extends the properties of a series by
* the property that, given any pair of samples, it can evaluate the
* statistical covariance between them.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* none
*$ Examples:
* Suppose stat is a statistical series comprising uncorrelated Poisson
* random numbers of mean 100.
*
* Then Pro_StatCovar(stat, k, k) returns 100. for k within the domain;
* Pro_StatCovar(stat, j, k) returns 0. for j != k.
*$ Error_handling:
* Profile library error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if object is NULL or is not a stat series.
* PRO_DOMAIN_ERROR if either sample index is outside the series'
* domain.
*$ Limitations:
* none
*$ Author_and_institution:
* Mark R. Showalter
* NASA/Ames Research Center
*$ Version_and_date:
* 1.0: March 1998
* 1.1: October 1999
*$ Change_history:
* 1.1: QUICK mode compile option added.
*******************************************************************************/
RL_FLT8 Pro_StatCovar(object, k1, k2)
PRO_OBJECT *object;
RL_INT4 k1, k2;
{
ZPRO_STAT *stat;
RL_INT4 klo, khi;
stat = ZPro_GetStat(object);
#ifndef QUICK
if (stat == NULL) return 0.;
#endif
/* Make sure indices are inside domain */
(void) Pro_SeriesIndices(object, &klo, &khi);
if (k1 < klo || k1 > khi) {
XPro_IDomainError("index #1", object, klo, khi, k1);
return 0.;
}
if (k2 < klo || k2 > khi) {
XPro_IDomainError("index #2", object, klo, khi, k2);
return 0.;
}
/* Otherwise evaluate covariance */
return (stat->covarfunc)(stat->class.pointer, k1, k2);
}
/*
********************************************************************************
*$ Component_name:
* Pro_StatRange (stat.c)
*$ Abstract:
* This routine returns the range of indices in a series where samples
* might have a nonzero covariance with a given sample.
*$ Keywords:
* PROFILE, SERIES
* C, PUBLIC, SUBROUTINE
*$ Declarations:
* RL_INT4 Pro_StatRange(object, k, k1, k2)
* PRO_OBJECT *object;
* RL_INT4 k, *k1, *k2;
*$ Inputs:
* object pointer to a statistical series object.
* k index at which to evaluate range of correlated samples.
*$ Outputs:
* k1, k2 range of sample indices for which the covariance might
* be nonzero.
*$ Returns:
* size of range returned, i.e. k2-k1+1, or zero on non-fatal error.
*$ Detailed_description:
* This routine returns the range of indices in a series where samples
* might have a nonzero covariance with a given sample.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* none
*$ Examples:
* Suppose stat is a statistical series comprising uncorrelated samples.
*
* Then Pro_StatRange(stat, k, &k1, &k2) returns 1 and sets k1=k; k2=k.
*$ Error_handling:
* Profile library error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if object is NULL or is not a stat series.
* PRO_DOMAIN_ERROR if either sample index is outside the series'
* domain.
*$ Limitations:
* none
*$ Author_and_institution:
* Mark R. Showalter
* NASA/Ames Research Center
*$ Version_and_date:
* 1.1: January 2000
*$ Change_history:
* none
*******************************************************************************/
RL_INT4 Pro_StatRange(object, k, k1, k2)
PRO_OBJECT *object;
RL_INT4 k, *k1, *k2;
{
ZPRO_STAT *stat;
RL_INT4 klo, khi;
stat = ZPro_GetStat(object);
#ifndef QUICK
if (stat == NULL) return 0;
#endif
/* Make sure index is inside domain */
(void) Pro_SeriesIndices(object, &klo, &khi);
if (k < klo || k > khi) {
XPro_IDomainError("index #1", object, klo, khi, k);
return 0;
}
/* Otherwise evaluate covariance range */
(stat->rangefunc)(stat->class.pointer, k, k1, k2);
if (*k1 < klo) *k1 = klo;
if (*k2 > khi) *k2 = khi;
return (*k2 - *k1 + 1);
}
/*
*******************************************************************************
* PROGRAMMER ROUTINES
********************************************************************************
* XPro_MakeStat(k1, k2, x1, dx, evalfunc, covarfunc, rangefunc, freefunc,
* printfunc, pointer)
*
* This routine creates and initializes a statistical series object.
*
* Inputs:
* k1, k2 index limits.
* x1 minimum X value, corresponding to first sample.
* dx x-interval between consecutive samples.
* evalfunc routine to evaluate series.
* covarfunc routine to evaluate covariance.
* rangefunc routine to evaluate nonzero covariance sample range.
* freefunc routine to free data structure.
* printfunc routine to print series data structure
* pointer pointer to an arbitrary data structure describing the
* series.
*
* Returns: new statistical series object.
*
* Errors:
* RL_MEMORY_ERROR on memory allocation failure.
*******************************************************************************/
PRO_OBJECT *XPro_MakeStat(k1, k2, x1, dx, evalfunc, covarfunc, rangefunc,
freefunc, printfunc, pointer)
RL_INT4 k1, k2;
RL_FLT8 x1, dx;
RL_FLT8 (*evalfunc) RL_PROTO((RL_VOID *pointer, RL_INT4 k,
RL_INT4 *flag));
RL_FLT8 (*covarfunc) RL_PROTO((RL_VOID *pointer, RL_INT4 k1,
RL_INT4 k2));
void (*rangefunc) RL_PROTO((RL_VOID *pointer, RL_INT4 k,
RL_INT4 *k1, RL_INT4 *k2));
void (*freefunc) RL_PROTO((RL_VOID *pointer));
void (*printfunc) RL_PROTO((RL_VOID *pointer));
RL_VOID *pointer;
{
ZPRO_STAT *stat;
PRO_OBJECT *new;
/* Allocate new statistical series structure */
stat = (ZPRO_STAT *) XRL_Malloc(sizeof(ZPRO_STAT));
if (stat == NULL) return NULL;
/* Initialize structure */
stat->class = stat_class;
stat->class.pointer = pointer;
stat->evalfunc = evalfunc;
stat->covarfunc = covarfunc;
stat->rangefunc = rangefunc;
stat->freefunc = freefunc;
stat->printfunc = printfunc;
/* Create new series object */
new = XPro_MakeSeries(k1, k2, x1, dx,
ZPro_EvalStat, ZPro_FreeStat, ZPro_PrintStat,
(RL_VOID *) stat);
return new;
}
/*
*******************************************************************************
* XPro_StatPtr(object)
*
* This routine returns a pointer to the statistical series sub-object.
*
* Inputs:
* object statistical series object.
*
* Return: pointer field of the object; NULL on error.
*
* Errors:
* PRO_CLASS_ERROR if the object is NULL or not a stat series.
*******************************************************************************/
#ifndef QUICK /* In QUICK mode, this is defined as a macro in profile.h */
RL_VOID *XPro_StatPtr(object)
PRO_OBJECT *object;
{
ZPRO_STAT *stat;
stat = ZPro_GetStat(object);
if (stat == NULL) return NULL;
if (stat->class.pointer == NULL)
XPro_NullError("statistical series sub-object", object);
return stat->class.pointer;
}
#endif
/*
*******************************************************************************
* INTERNAL ROUTINES
********************************************************************************
* ZPro_EvalStat(pointer, k, flag)
*
* This internal routine evaluates the value of a statistical series. It serves
* as the standard "evalfunc" for the parent series object.
*
* Inputs:
* pointer pointer to the ZPRO_STAT structure.
* k index at which to evaluate series.
*
* Outputs:
* *flag flag value of series.
*
* Returns: value of series at k.
*******************************************************************************/
static RL_FLT8 ZPro_EvalStat(pointer, k, flag)
RL_VOID *pointer;
RL_INT4 k, *flag;
{
ZPRO_STAT *stat;
RL_FLT8 value;
stat = (ZPRO_STAT *) pointer;
value = (stat->evalfunc)(stat->class.pointer, k, flag);
return value;
}
/*
*******************************************************************************
* ZPro_FreeStat(pointer)
*
* This internal routine deallocates the memory used by a statistical series
* object. It serves as the standard "freefunc" for the parent series object.
*
* Input:
* pointer pointer to the ZPRO_STAT structure.
*******************************************************************************/
static void ZPro_FreeStat(pointer)
RL_VOID *pointer;
{
ZPRO_STAT *stat;
stat = (ZPRO_STAT *) pointer;
(stat->freefunc)(stat->class.pointer);
XRL_Free(stat);
}
/*
*******************************************************************************
* ZPro_PrintStat(pointer)
*
* This internal routine prints information about a statistical series object.
* It serves as the standard "printfunc" for the parent function object.
*
* Input:
* pointer pointer to the ZPRO_STAT structure.
*******************************************************************************/
static void ZPro_PrintStat(pointer)
RL_VOID *pointer;
{
ZPRO_STAT *stat;
RL_INT4 i;
RL_CHAR *type;
stat = (ZPRO_STAT *) pointer;
/* Make sure object is not NULL */
if (stat == NULL) {
printf("PRINT ERROR: Statistical series pointer is NULL\n");
return;
}
/* Make sure object is a statistical series */
if (stat->class.id != XPRO_STAT_CLASS) {
printf("PRINT ERROR: Object is not a statistical series\n");
return;
}
/* No object info to print at this level */
/* Print more detailed info */
(stat->printfunc)(stat->class.pointer);
return;
}
/*
*******************************************************************************
* ZPro_GetStat(object)
*
* This internal routine confirms that the given object is a statistical series
* and returns a pointer to the ZPRO_STAT data structure.
*
* Input:
* object statistical series object.
*
* Errors:
* PRO_CLASS_ERROR if object is NULL or is not a stat series.
*******************************************************************************/
#ifndef QUICK /* In QUICK mode, this is defined as a macro above */
static ZPRO_STAT *ZPro_GetStat(object)
PRO_OBJECT *object;
{
ZPRO_STAT *stat;
/* Find statistical series object pointer */
stat = (ZPRO_STAT *) XPro_SeriesPtr(object);
/* Make sure object is a statistical series */
if (stat->class.id != XPRO_STAT_CLASS) {
XPro_ClassError("statistical series", object);
return NULL;
}
return stat;
}
#endif
/*
********************************************************************************
* FORTRAN INTERFACE ROUTINES
********************************************************************************
*$ Component_name:
* FPro_StatCovar (stat.c)
*$ Abstract:
* This routine returns the covariance between two samples in a statistical
* series.
*$ Keywords:
* PROFILE, SERIES
* FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
* real*8 function FPro_StatCovar(object, k1, k2)
* integer*4 object
* integer*4 k1, k2
*$ Inputs:
* object FORTRAN pointer to a statistical series object.
* k1, k2 sample indices for which to calculate covariance.
*$ Outputs:
* none
*$ Returns:
* value of the covariance between the given samples, or 0. on non-fatal
* error.
*$ Detailed_description:
* This routine returns the covariance between two samples in a statistical
* series. A statistical series extends the properties of a series by
* the property that, given any pair of samples, it can evaluate the
* statistical covariance between them.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* none
*$ Examples:
* Suppose stat is a statistical series comprising uncorrelated Poisson
* random numbers of mean 100.
*
* Then FPro_StatCovar(stat, k, k) returns 100.d0 for k within the domain;
* FPro_StatCovar(stat, j, k) returns 0.d0 for j != k.
*$ Error_handling:
* Profile library error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if object is NULL or is not a stat series.
* PRO_DOMAIN_ERROR if either sample index is outside the series'
* domain.
* 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
* 1.1: October 1999
*$ Change_history:
* 1.1: QUICK mode compile option added.
*******************************************************************************/
RL_FLT8 FORTRAN_NAME(fpro_statcovar) (object, k1, k2)
RL_INT4 *object;
RL_INT4 *k1, *k2;
{
RL_VOID *ptr;
/* Look up statistical series pointer */
ptr = FORT_GetPointer(*object);
#ifndef QUICK
if (ptr == NULL) return 0.;
#endif
/* Call function */
return Pro_StatCovar((PRO_OBJECT *) ptr, *k1, *k2);
}
/*
********************************************************************************
*$ Component_name:
* FPro_StatRange (stat.c)
*$ Abstract:
* This routine returns the range of indices in a series where samples
* might have a nonzero covariance with a given sample.
*$ Keywords:
* PROFILE, SERIES
* FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
* real*4 function FPro_StatRange(object, k, k1, k2)
* integer*4 object
* integer*4 k1, k2
*$ Inputs:
* object FORTRAN pointer to a statistical series object.
* k index at which to evaluate range of correlated samples.
*$ Outputs:
* k1, k2 range of sample indices for which the covariance might
* be nonzero.
*$ Returns:
* size of range returned, i.e. k2-k1+1, or zero on non-fatal error.
*$ Detailed_description:
* This routine returns the range of indices in a series where samples
* might have a nonzero covariance with a given sample.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* none
*$ Examples:
* Suppose stat is a statistical series comprising uncorrelated samples.
*
* Then FPro_StatRange(stat, k, k1, k2) returns 1 and sets k1=k; k2=k.
*$ Error_handling:
* Profile library error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if object is NULL or is not a stat series.
* PRO_DOMAIN_ERROR if either sample index is outside the series'
* domain.
*$ Limitations:
* none
*$ Author_and_institution:
* Mark R. Showalter
* NASA/Ames Research Center
*$ Version_and_date:
* 1.1: January 2000
*$ Change_history:
* none
*******************************************************************************/
RL_INT4 FORTRAN_NAME(fpro_statrange) (object, k, k1, k2)
RL_INT4 *object;
RL_INT4 *k, *k1, *k2;
{
RL_VOID *ptr;
/* Look up statistical series pointer */
ptr = FORT_GetPointer(*object);
#ifndef QUICK
if (ptr == NULL) return 0.;
#endif
/* Call function */
return Pro_StatRange((PRO_OBJECT *) ptr, *k, k1, k2);
}
/*******************************************************************************
*/