/* object.c
********************************************************************************
* object.c -- Routines for manipulating generic objects
*
* User routines:
* Pro_FreeObject(object) frees the memory used by an object.
* Pro_PrintObject(object) prints information about an object.
* Pro_ObjectName(object,coord) returns name of an object or one of
* its coordinates.
* Pro_RenameObject(object,coord,name)
* renames an object or one of its
* coordinates.
* Pro_ObjectDomain(object,x1,x2) returns the domain (X-limits) of an
* object.
* Pro_ObjectOverlap(object,x1,x2,xname,first)
* solves for the domain of overlap of
* multiple objects.
*
* Programmer routines:
* XPro_MakeObject(x1, x2, freefunc, printfunc, pointer)
* creates and intializes a new generic
* object.
* XPro_EnslaveObject(object, slave)
* adds a link to a "slave" object.
* XPro_PrintInfo(object) prints name and type of object.
* XPro_ObjectName(object) returns name of an object without
* checking for a class error.
* XPro_ObjectPtr(object) returns pointer to sub-object.
*
* Version 1.0: Original release.
* Mark Showalter & Neil Heather, PDS Ring-Moon Systems Node, March 1998.
* Version 1.1: QUICK compilation mode added.
* Mark Showalter, October 1999.
*******************************************************************************/
#include <stdio.h>
#include <string.h>
#include <ctype.h>
#include "profile.h"
#include "fortran.h"
/************************************
* Prototypes for internal routines *
************************************/
static void ZPro_RemoveOwner RL_PROTO((PRO_OBJECT *object,
PRO_OBJECT *owner));
static void ZPro_DeleteObject RL_PROTO((PRO_OBJECT *object));
static RL_BOOL ZPro_TestObject RL_PROTO((PRO_OBJECT *object));
/********************
* Static variables *
********************/
static RL_INT4 object_counter = 0;
static RL_INT4 objects_active = 0;
static PRO_OBJECT empty_object = {{XPRO_OBJECT_CLASS, "object", NULL},
"Untitled", "", "", 0., 0., NULL, NULL,
FALSE, {NULL, NULL}, {NULL, NULL}};
static RL_CHAR empty_name[] = "";
/********************
* Global variables *
********************/
PRO_OBJECT XPRO_UNKNOWN_OBJECT = {{XPRO_OBJECT_CLASS, "object", NULL},
"Unknown", "", "", 0., 0., NULL, NULL,
FALSE, {NULL, NULL}, {NULL, NULL}};
/*
********************************************************************************
* EXPORTED USER ROUTINES
********************************************************************************
*$ Component_name:
* Pro_FreeObject (object.c)
*$ Abstract:
* This routine frees the specified object.
*$ Keywords:
* PROFILE
* C, PUBLIC, SUBROUTINE
*$ Declarations:
* void Pro_FreeObject(object)
* PRO_OBJECT *object;
*$ Inputs:
* object pointer to the object to free.
*$ Outputs:
* none
*$ Returns:
* none
*$ Detailed_description:
* This routine frees the specified object. Memory is deallocated,
* associated files are closed, and any linked objects are freed.
*
* Note that the user can free an object as soon it is no longer needed for
* direct manipulation. When this routine is called, the object will still
* be retained internally by the Profile toolkit until every object that
* links to it is also freed.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* Memory is deallocated, associated files are closed, and linked objects
* are freed.
*$ Examples:
* PRO_OBJECT *series, *func;
*
* series = Pro_ArraySeries(...); // create a series
* func = Pro_LSplineFunc(series); // create a function using the series
* Pro_FreeObject(series); // free the series because we won't use
* it again directly. It won't really
* disappear till func is freed
* printf("%g\n", Pro_FuncValue(func,1.));
* // function can still be used
* Pro_FreeObject(func); // freeing the function now also frees
* the series too
*$ Error_handling:
* Profile toolkit error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if object is NULL or not a profile object.
*$ Limitations:
* none
*$ Author_and_institution:
* Mark R. Showalter
* NASA/Ames Research Center
*$ Version_and_date:
* 1.0: March 1998
*$ Change_history:
* none
*******************************************************************************/
void Pro_FreeObject(object)
PRO_OBJECT *object;
{
XPRO_LINK *link, *save;
/* Make sure object it's a valid object */
if (ZPro_TestObject(object)) return;
/* Mark object as freed if it isn't already */
if (object->isfreed) return;
object->isfreed = TRUE;
/* Free slaves of the object */
link = object->slaves.next;
while (link != NULL) {
ZPro_RemoveOwner(link->object, object);
save = link->next;
XRL_Free((RL_VOID *) link);
link = save;
}
/* If the object has no owners, delete it */
if (object->owners.next == NULL) ZPro_DeleteObject(object);
}
/*
********************************************************************************
*$ Component_name:
* Pro_PrintObject (object.c)
*$ Abstract:
* This routine prints out information about an object.
*$ Keywords:
* PROFILE
* C, PUBLIC, SUBROUTINE
*$ Declarations:
* void Pro_PrintObject(object)
* PRO_OBJECT *object;
*$ Inputs:
* object pointer to the object to print.
*$ Outputs:
* none
*$ Returns:
* none
*$ Detailed_description:
* This routine prints out information about an object. It is used mainly
* for debugging.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* Information is printed to standard output.
*$ Examples:
* PRO_OBJECT *series;
* series = Pro_ArraySeries(...); // create a series
* Pro_PrintObject(series) // print out info about it
*$ Error_handling:
* No error conditions are ever raised by this routine.
*$ Limitations:
* none
*$ Author_and_institution:
* Mark R. Showalter
* NASA/Ames Research Center
*$ Version_and_date:
* 1.0: March 1998
*$ Change_history:
* none
*******************************************************************************/
void Pro_PrintObject(object)
PRO_OBJECT *object;
{
XPRO_LINK *link;
/* Print out object name and class */
printf("Object ");
XPro_PrintInfo(object);
/* Print out freed status if necessary */
if (object->isfreed) {
printf("PRINT ERROR: Object is already freed\n");
return;
}
/* Print out slave list, indented */
for (link = object->slaves.next; link != NULL; link = link->next) {
printf(" slave ");
XPro_PrintInfo(link->object);
}
/* Print out owner list, indented */
for (link = object->owners.next; link != NULL; link = link->next) {
printf(" owner ");
XPro_PrintInfo(link->object);
}
/* Print generic object info */
printf("\nGeneric object parameters...\n");
printf(" xname = \"%s\"\n", XPro_ObjectName(object,1));
printf(" yname = \"%s\"\n", XPro_ObjectName(object,2));
printf(" domain = [%#g,%#g]\n", object->x1, object->x2);
/* Print the remaining info */
(object->printfunc) (object->class.pointer);
}
/*
********************************************************************************
*$ Component_name:
* Pro_ObjectName (object.c)
*$ Abstract:
* This routine returns the name of an object or one of its coordinates.
*$ Keywords:
* PROFILE
* C, PUBLIC, SUBROUTINE
*$ Declarations:
* RL_CHAR *Pro_ObjectName(object, coord)
* PRO_OBJECT *object;
* RL_INT4 coord;
*$ Inputs:
* object pointer to the object.
* coord 0 for object name;
* 1 for X-coordinate name;
* 2 for Y-coordinate name.
*$ Outputs:
* none
*$ Returns:
* a pointer to a (read-only) string containing the name of the object.
* On non-fatal error, it returns a pointer to an empty string.
*$ Detailed_description:
* This function returns a pointer to the name of an object or one of its
* coordinates.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* none
*$ Examples:
* This snippet of code creates a series, names it, and then prints the
* names. The result is:
* Name = Series
* X = X coord
* Y = Y coord
*
* PRO_OBJECT *series;
* series = Pro_ArraySeries(...); // create a series
* Pro_RenameObject(series, 0, "Series") // name it
* Pro_RenameObject(series, 1, "X coord") // name the x coordinate
* Pro_RenameObject(series, 2, "Y coord") // name the y coordinate
*
* printf("Name = %s\n", Pro_ObjectName(series,0));// print name
* printf("X = %s\n", Pro_ObjectName(series,1)); // print X cordinate
* printf("Y = %s\n", Pro_ObjectName(series,2)); // print Y cordinate
*$ Error_handling:
* Profile toolkit error handling is in effect. On non-fatal error, a
* pointer to an empty string is returned.
*
* Conditions raised:
* PRO_CLASS_ERROR if object is NULL or not an object pointer.
* PRO_DOMAIN_ERROR if the coord is outside the range 0 to 2.
*$ Limitations:
* Names are limited to 59 characters, plus a final null character.
*$ Author_and_institution:
* Mark R. Showalter
* NASA/Ames Research Center
*$ Version_and_date:
* 1.0: March 1998
*$ Change_history:
* none
*******************************************************************************/
RL_CHAR *Pro_ObjectName(object, coord)
PRO_OBJECT *object;
RL_INT4 coord;
{
if (ZPro_TestObject(object)) {
return empty_name;
}
else {
return XPro_ObjectName(object, coord);
}
}
/*
********************************************************************************
*$ Component_name:
* Pro_RenameObject (object.c)
*$ Abstract:
* This routine changes the name of an object or one of its coordinates.
*$ Keywords:
* PROFILE
* C, PUBLIC, SUBROUTINE
*$ Declarations:
* void Pro_RenameObject(object, coord, name)
* PRO_OBJECT *object;
* RL_INT4 coord;
* RL_CHAR *name;
*$ Inputs:
* object pointer to the object to rename.
* coord 0 for object name;
* 1 for X-coordinate name;
* 2 for Y-coordinate name.
* name character string containing new name.
*$ Outputs:
* none
*$ Returns:
* none
*$ Detailed_description:
* This routine changes the name of an object or one of its coordinates.
* It replaces any unprintable characters with a period.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* none
*$ Examples:
* This snippet of code creates a series, names it, and then prints the
* names. The result is:
* Name = Series
* X = X coord
* Y = Y coord
*
* PRO_OBJECT *series;
* series = Pro_ArraySeries(...); // create a series
* Pro_RenameObject(series, 0, "Series") // name it
* Pro_RenameObject(series, 1, "X coord") // name the x coordinate
* Pro_RenameObject(series, 2, "Y coord") // name the y coordinate
*
* printf("Name = %s\n", Pro_ObjectName(series,0));// print name
* printf("X = %s\n", Pro_ObjectName(series,1)); // print X cordinate
* printf("Y = %s\n", Pro_ObjectName(series,2)); // print Y cordinate
*$ Error_handling:
* Profile toolkit error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if object is NULL or not a profile object.
* PRO_DOMAIN_ERROR if the coord is outside the range 0 to 2.
*$ Limitations:
* Names are limited to 59 characters, plus a final null character.
*$ Author_and_institution:
* Mark R. Showalter
* NASA/Ames Research Center
*$ Version_and_date:
* 1.0: March 1998
*$ Change_history:
* none
*******************************************************************************/
void Pro_RenameObject(object, coord, name)
PRO_OBJECT *object;
RL_INT4 coord;
RL_CHAR *name;
{
RL_CHAR *loc, *c;
if (ZPro_TestObject(object)) return;
if (coord == 0) loc = object->name;
else if (coord == 1) loc = object->xname;
else if (coord == 2) loc = object->yname;
else {
XPro_IDomainError("coordinate index", object, 0, 2, coord);
return;
}
/* Copy name into object structure */
strncpy(loc, name, PRO_NAMELEN);
loc[PRO_NAMELEN] = '\0'; /* ensure null termination */
/* Obliterate unprintable characters */
for (c = loc; *c != '\0'; c++) {
if (!isprint((int) *c)) *c = '.';
}
}
/*
********************************************************************************
*$ Component_name:
* Pro_ObjectDomain (object.c)
*$ Abstract:
* This routine returns the domain (X-limits) for an object.
*$ Keywords:
* PROFILE
* C, PUBLIC, SUBROUTINE
*$ Declarations:
* RL_FLT8 Pro_ObjectDomain(object, x1, x2)
* PRO_OBJECT *object;
* RL_FLT8 *x1, *x2;
*$ Inputs:
* object pointer to the object.
*$ Outputs:
* *x1, *x2 lower and upper limits of domain (inclusive); not
* returned if either pointer value is NULL; unchanged on
* non-fatal error.
*$ Returns:
* size of domain (x2 - x1); 0. on non-fatal error.
*$ Detailed_description:
* This routine returns the domain (X-limits) for an object. It also
* returns the size of the domain.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* none
*$ Examples:
* none
*$ Error_handling:
* Profile library error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if the object is NULL or not a profile object.
*$ 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_ObjectDomain(object, x1, x2)
PRO_OBJECT *object;
RL_FLT8 *x1, *x2;
{
#ifndef QUICK
if (ZPro_TestObject(object)) return 0.;
#endif
if (x1 != NULL) *x1 = object->x1;
if (x2 != NULL) *x2 = object->x2;
return (object->x2 - object->x1);
}
/*
********************************************************************************
*$ Component_name:
* Pro_ObjectOverlap (object.c)
*$ Abstract:
* This routine finds the domain of overlap of two or more objects.
*$ Keywords:
* PROFILE
* C, PUBLIC, SUBROUTINE
*$ Declarations:
* RL_FLT8 Pro_ObjectOverlap(object, refobj, x1, x2)
* PRO_OBJECT *object, *refobj;
* RL_FLT8 *x1, *x2;
*$ Inputs:
* object pointer to the object to test for overlap.
* refobj pointer to the reference object (see below).
* *x1, *x2 current domain limits; ignored if first is TRUE.
*$ Outputs:
* *x1, *x2 updated domain limits.
*$ Returns:
* size of overlapping domain, i.e. (*x2 - *x1), or 0. on non-fatal error.
*$ Detailed_description:
* This routine finds the domain of overlap of two or more objects. It
* also checks to confirm that the X-coordinate names match.
*
* On the first call to this routine, the object and the reference object
* should be the same. In this case, the domain is saved in x1 and x2.
* On subsequent calls, the first argument should be each new object to
* overlap with the reference object. After the last call, *x1 and *x2
* contain the intersection of all the objects' domains. If at any time
* the intersection becomes empty, an error condition is raised.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* none
*$ Examples:
* Suppose you wish to find the overlapping domain of object1, object2 and
* object3.
*
* RL_FLT8 x1, x2;
*
* Pro_ObjectOverlap(object1, object1, &x1, &x2);
* Pro_ObjectOverlap(object2, object1, &x1, &x2);
* Pro_ObjectOverlap(object3, object1, &x1, &x2);
*
* At this point, x1 and x2 are the limits of the overlapping domain. If
* any of the X-coordinate names do not match or if the overlapping domain
* is empty, an error condition is raised.
*$ Error_handling:
* Profile toolkit error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if object is NULL or not a profile object.
* PRO_COORD_MISMATCH if X-coordinate names of objects do not match.
* PRO_EMPTY_DOMAIN if overlapping domain is empty.
*
* On a non-fatal PRO_COORD_MISMATCH condition, the domain limits are still
* updated and the return is normal. Otherwise, 0. is returned.
*$ Limitations:
* none
*$ Author_and_institution:
* Mark R. Showalter
* NASA/Ames Research Center
*$ Version_and_date:
* 1.0: March 1998
*$ Change_history:
* none
*******************************************************************************/
RL_FLT8 Pro_ObjectOverlap(object, refobj, x1, x2)
PRO_OBJECT *object, *refobj;
RL_FLT8 *x1, *x2;
{
RL_CHAR *aname;
RL_FLT8 size, a1, a2, b1, b2;
/* Get domain info */
size = Pro_ObjectDomain(object, &a1, &a2);
if (size <= 0.) return 0.;
/* On first call, just save domain info */
if (object == refobj) {
*x1 = a1;
*x2 = a2;
return (a2 - a1);
}
/* Otherwise, compare names */
if (strcmp(Pro_ObjectName(object,1), Pro_ObjectName(refobj,1)) != 0) {
XPro_CoordMismatch("overlap", object, refobj, Pro_ObjectName(object,1),
Pro_ObjectName(refobj,1));
}
/* Derive new domain */
b1 = (a1 > *x1 ? a1 : *x1);
b2 = (a2 < *x2 ? a2 : *x2);
/* Test for empty domain */
if (b1 >= b2) {
XPro_EmptyDomain("overlap", object, refobj, a1, a2, *x1, *x2);
return 0.;
}
/* Update domain and return */
*x1 = b1;
*x2 = b2;
return (b2 - b1);
}
/*
********************************************************************************
* EXPORTED PROGRAMMER ROUTINES
********************************************************************************
* XPro_MakeObject(x1, x2, freefunc, printfunc, pointer)
*
* This routine creates and initializes a generic object.
*
* Inputs:
* x1, x2 domain limits.
* freefunc function to free data structure.
* printfunc function to print object data.
* pointer pointer to object data structure.
*
* Returns: pointer to the new object.
*
* Errors:
* RL_MEMORY_ERROR if memory for the object could not be allocated;
* in this case, the pointer data structure is also
* freed.
*******************************************************************************/
PRO_OBJECT *XPro_MakeObject(x1, x2, freefunc, printfunc, pointer)
RL_FLT8 x1, x2;
void (*freefunc) RL_PROTO((RL_VOID * pointer));
void (*printfunc) RL_PROTO((RL_VOID * pointer));
RL_VOID *pointer;
{
PRO_OBJECT *object;
/* Allocate and initialize new object */
object = (PRO_OBJECT *) XRL_Malloc(sizeof(PRO_OBJECT));
if (object == NULL) {
(*freefunc) (pointer);
return NULL;
}
/* Fill in temporary object */
*object = empty_object;
object->class.pointer = pointer;
object->x1 = x1;
object->x2 = x2;
object->freefunc = freefunc;
object->printfunc = printfunc;
/* Generate temporary name */
object_counter++;
objects_active++;
sprintf(object->name, "Untitled #%1d", object_counter);
return object;
}
/*
********************************************************************************
* XPro_EnslaveObject(object, slave)
*
* This routine adds an object to the slave list for a given object. In this
* usage, a slave object is one that the given object uses.
*
* Inputs:
* object object to modify.
* slave slave object.
*
* Return: TRUE if an error occured; FALSE if all is well.
*
* Errors:
* RL_MEMORY_ERROR if memory for the links could not be allocated.
*******************************************************************************/
RL_BOOL XPro_EnslaveObject(object, slave)
PRO_OBJECT *object, *slave;
{
XPRO_LINK *link, *link1, *link2;
if (ZPro_TestObject(object) || ZPro_TestObject(slave)) return TRUE;
/* Search object's slave list so we don't re-enslave */
for (link = object->slaves.next; link != NULL; link = link->next) {
if (link->object == slave) return FALSE;
}
/* Allocate a pair of new links */
link1 = NULL;
link2 = NULL;
link1 = (XPRO_LINK *) XRL_Malloc(sizeof(XPRO_LINK));
link2 = (XPRO_LINK *) XRL_Malloc(sizeof(XPRO_LINK));
if (link2 == NULL) {
XRL_Free((RL_VOID *) link1);
XRL_Free((RL_VOID *) link2);
return TRUE;
}
/* Insert a new link into object's slave list */
link1->object = slave;
link1->next = object->slaves.next;
object->slaves.next = link1;
/* Insert new link into slave's owner list */
link2->object = object;
link2->next = slave->owners.next;
slave->owners.next = link2;
/* Now recursively enslave all of slave's slaves */
for (link = slave->slaves.next; link != NULL; link = link->next) {
/* On failure, remove new links and free them */
if (XPro_EnslaveObject(object, link->object)) {
object->slaves.next = link1->next;
slave->owners.next = link2->next;
XRL_Free((RL_VOID *) link1);
XRL_Free((RL_VOID *) link2);
return TRUE;
}
}
return FALSE;
}
/*
********************************************************************************
* XPro_PrintInfo(object)
*
* This function prints out one line of information about an object, giving its
* name and class.
*
* Inputs:
* object object to print.
*******************************************************************************/
void XPro_PrintInfo(object)
PRO_OBJECT *object;
{
/* Check for null object */
if (object == NULL) {
printf("PRINT ERROR: Null object\n");
return;
}
/* Print out object name and class */
printf("%s:", Pro_ObjectName(object, 0));
XPro_PrintClass(&(object->class));
printf("\n");
}
/*
********************************************************************************
* XPro_ObjectName(object, coord)
*
* This routine returns a pointer to the name of an object. Unlike routine
* Pro_ObjectName(), this one does not raise class errors.
*
* Inputs:
* object object.
* coord 0 for object name;
* 1 for X-coordinate name;
* 2 for Y-coordinate name.
*
* Return: pointer to a character string giving the object's name.
*******************************************************************************/
RL_CHAR *XPro_ObjectName(object, coord)
PRO_OBJECT *object;
RL_INT4 coord;
{
RL_CHAR *t, *loc;
/* Check for invalid pointer */
if (object == NULL || object->class.id != XPRO_OBJECT_CLASS) {
return empty_name;
}
/* Identify coordinate */
if (coord == 0) return object->name;
else if (coord == 1) return object->xname;
else if (coord == 2) return object->yname;
else {
XPro_IDomainError("coordinate index", object, 0, 2, coord);
return empty_name;
}
}
/*
********************************************************************************
* XPro_ObjectPtr(object)
*
* This function returns a pointer to the sub-object of a given object.
*
* Inputs:
* object object for which to return sub-object.
*******************************************************************************/
#ifndef QUICK /* In QUICK mode, this is defined as a macro in profile.h */
RL_VOID *XPro_ObjectPtr(object)
PRO_OBJECT *object;
{
if (ZPro_TestObject(object)) return NULL;
if (object->class.pointer == NULL)
XPro_NullError("sub-object", object);
return object->class.pointer;
}
#endif
/*
********************************************************************************
* XPro_PrintClass(class)
*
* This function recursively prints out the class name of an object. It is
* called by XPro_PrintInfo().
*
* Inputs:
* class class structure to print.
*******************************************************************************/
void XPro_PrintClass(class)
XPRO_CLASS *class;
{
if (class != NULL) {
XPro_PrintClass((XPRO_CLASS *) class->pointer);
printf(" %s", class->name);
}
}
/*
********************************************************************************
* INTERNAL ROUTINES
********************************************************************************
* ZPro_RemoveOwner(object, owner)
*
* This internal routine removes the specified owner from an object. If the
* object is marked for freeing and its last owner is removed, it is deleted.
* This routine is called by Pro_FreeObject().
*
* Inputs:
* object object to modify.
* owner owner object to remove.
*******************************************************************************/
static void ZPro_RemoveOwner(object, owner)
PRO_OBJECT *object, *owner;
{
XPRO_LINK *link, *prev;
/* Walk down owner list... */
for (prev = &(object->owners); prev->next != NULL; prev = prev->next) {
link = prev->next;
/* When link to specified owner is found, remove it */
if (link->object == owner) {
prev->next = link->next;
XRL_Free(link);
/* If object is freed and has no owners, delete it */
if (object->isfreed && object->owners.next == NULL)
ZPro_DeleteObject(object);
return;
}
}
/* We should never get to this point in the code */
}
/*
********************************************************************************
* ZPro_DeleteObject(object)
*
* This internal routine frees a given object unconditionally. It is only
* called when the object is already marked freed and has no owners.
*
* Inputs:
* object object to delete.
*******************************************************************************/
static void ZPro_DeleteObject(object)
PRO_OBJECT *object;
{
objects_active--;
(*object->freefunc) (object->class.pointer);
XRL_Free(object);
}
/*
********************************************************************************
* ZPro_TestObject(object)
*
* This internal function checks to make sure an object is not NULL and not
* already freed.
*
* Inputs:
* object object to check.
*
* Return: TRUE on error; FALSE if all is well.
*
* Errors:
* PRO_CLASS_ERROR if object is NULL or not a generic object;
*******************************************************************************/
static RL_BOOL ZPro_TestObject(object)
PRO_OBJECT *object;
{
#ifndef QUICK /* These tests are disabled in QUICK mode */
if (object == NULL) {
XPro_NullError("generic object", object);
return TRUE;
}
if (object->class.id != XPRO_OBJECT_CLASS) {
XPro_ClassError("generic object", object);
return TRUE;
}
#endif
return FALSE;
}
/*
********************************************************************************
* FORTRAN INTERFACE ROUTINES
********************************************************************************
*$ Component_name:
* FPro_FreeObject (object.c)
*$ Abstract:
* This routine frees the specified object.
*$ Keywords:
* PROFILE
* FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
* subroutine FPro_FreeObject(object)
* integer*4 object
*$ Inputs:
* object FORTRAN pointer to the object to free.
*$ Outputs:
* none
*$ Returns:
* none
*$ Detailed_description:
* This routine frees the specified object. Memory is deallocated,
* associated files are closed, and any linked objects are freed.
*
* Note that the user can free an object as soon it is no longer needed for
* direct manipulation. When this routine is called, the object will still
* be retained internally by the Profile toolkit until every object that
* links to it is also freed.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* Memory is deallocated, associated files are closed, and linked objects
* are freed.
*$ Examples:
* integer*4 series, func
*
* series = FPro_ArraySeries(...) ! create a series
* func = FPro_LSplineFunc(series) ! create a function using the series
* call FPro_FreeObject(series) ! free the series because we won't use
* ! it again directly. It won't really
* ! disappear till func is freed
* write(*,*) Pro_FuncValue(func,1.d0)
* ! function can still be used
* call FPro_FreeObject(func) ! freeing the function now also frees
* ! the series too
*$ Error_handling:
* Profile toolkit error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if object is NULL or not a profile object.
* 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
*******************************************************************************/
void FORTRAN_NAME(fpro_freeobject) (object)
RL_INT4 *object;
{
RL_VOID *ptr;
/* Look up object pointer */
ptr = FORT_GetPointer(*object);
if (ptr == NULL) return;
Pro_FreeObject((PRO_OBJECT *) ptr);
FORT_FreePointer(*object);
}
/*
********************************************************************************
*$ Component_name:
* FPro_PrintObject (object.c)
*$ Abstract:
* This routine prints out information about an object.
*$ Keywords:
* PROFILE
* FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
* subroutine FPro_PrintObject(object)
* integer*4 object
*$ Inputs:
* object FORTRAN pointer to the object to print.
*$ Outputs:
* none
*$ Returns:
* none
*$ Detailed_description:
* This routine prints out information about an object. It is used mainly
* for debugging.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* Information is printed to standard output (i.e. the terminal).
*$ Examples:
* integer*4 series
* series = FPro_ArraySeries(...) ! create a series
* call FPro_PrintObject(series) ! print out info about it
*$ Error_handling:
* RingLib toolkit error handling is in effect. No Profile toolkit
* error conditions are raised by this routine.
*
* Conditions raised:
* 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
*******************************************************************************/
void FORTRAN_NAME(fpro_printobject) (object)
RL_INT4 *object;
{
RL_VOID *ptr;
/* Look up object pointer */
ptr = FORT_GetPointer(*object);
if (ptr == NULL) return;
Pro_PrintObject((PRO_OBJECT *) ptr);
}
/*
********************************************************************************
*$ Component_name:
* FPro_ObjectName (object.c, fprofile.for)
*$ Abstract:
* This routine returns the name of an object or one of its coordinates.
*$ Keywords:
* PROFILE
* FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
* subroutine FPro_ObjectName(object, coord, name)
* integer*4 object, coord
* character*(*) name
*$ Inputs:
* object FORTRAN pointer to the profile object.
* coord 0 for object name;
* 1 for X-coordinate name;
* 2 for Y-coordinate name.
*
*$ Outputs:
* name name of object, possibly truncated. On error, this
* string is blank.
*$ Returns:
* none
*$ Detailed_description:
* This function returns a pointer to the name of an object or one of its
* coordinates. It also replaces unprintable characters with periods and
* limits the length to 59 characters (plus a final null character).
*$ External_references:
* Profile toolkit
*$ Side_effects:
* none
*$ Examples:
* This snippet of code creates a series, names it, and then prints the
* names. The result is:
* Name = Series
* X = X coord
* Y = Y coord
*
* integer*4 series
* character*80 name
*
* series = FPro_ArraySeries(...) ! create a series
* call Pro_RenameObject(series, 0, 'Series') ! name it
* call Pro_RenameObject(series, 1, 'X coord') ! name the x coord
* call Pro_RenameObject(series, 2, 'Y coord') ! name the y coord
*
* call FPro_ObjectName(series, 0, name) ! get name
* write(*,*) 'Name = ', name ! print it
* call FPro_ObjectName(series, 1, name) ! get X cordinate
* write(*,*) 'X = ', name ! print it
* call FPro_ObjectName(series, 2, name) ! get Y cordinate
* write(*,*) 'Y = ', name ! print it
*$ Error_handling:
* Profile library error handling is in effect. On non-fatal error, it
* returns an empty string.
*
* Conditions raised:
* PRO_CLASS_ERROR if object is NULL or not a profile toolkit
* object.
* PRO_DOMAIN_ERROR if the coord is outside the range 0 to 2.
* FORTRAN_POINTER_ERROR if object is not a valid FORTRAN pointer.
*$ Limitations:
* Object names are limited to 59 characters.
*$ Author_and_institution:
* Mark R. Showalter
* NASA/Ames Research Center
*$ Version_and_date:
* 1.0: March 1998
*$ Change_history:
* none
********************************************************************************
* Note: GPro_ObjectName() defined here is the intermediary routine between
* FPro_ObjectName() and Pro_ObjectName(), allowing for the fact that strings
* cannot be passed directly between FORTRAN and C. See fprofile.for for the
* rest of the code.
*
* subroutine GPro_ObjectName(object, coord, buffer, lbuffer)
* integer*4 object, coord, lbuffer
* byte buffer(*)
*******************************************************************************/
void FORTRAN_NAME(gpro_objectname)(object, coord, buffer, lbuffer)
RL_INT4 *object, *coord, *lbuffer;
RL_CHAR *buffer;
{
RL_VOID *ptr;
/* Look up object pointer */
ptr = FORT_GetPointer(*object);
if (ptr == NULL) {
buffer[0] = '\0';
return;
}
strncpy(buffer, Pro_ObjectName((PRO_OBJECT *) ptr, *coord), *lbuffer-1);
buffer[*lbuffer-1] = '\0';
}
/*
********************************************************************************
*$ Component_name:
* FPro_RenameObject (object.c, fprofile.for)
*$ Abstract:
* This routine changes the name of an object or one of its coordinates.
*$ Keywords:
* PROFILE
* FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
* subroutine FPro_RenameObject(object, coord, name)
* integer*4 object, coord
* character*(*) name
*$ Inputs:
* object FORTRAN pointer to the object to rename.
* coord 0 for object name;
* 1 for X-coordinate name;
* 2 for Y-coordinate name.
* name character string containing new name.
*$ Outputs:
* none
*$ Returns:
* none
*$ Detailed_description:
* This routine changes the name of an object or one of its coordinates.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* none
*$ Examples:
* This snippet of code creates a series, names it, and then prints the
* names. The result is:
* Name = Series
* X = X coord
* Y = Y coord
*
* integer*4 series
* character*80 name
*
* series = FPro_ArraySeries(...) ! create a series
* call Pro_RenameObject(series, 0, 'Series') ! name it
* call Pro_RenameObject(series, 1, 'X coord') ! name the x coord
* call Pro_RenameObject(series, 2, 'Y coord') ! name the y coord
*
* call FPro_ObjectName(series, 0, name) ! get name
* write(*,*) 'Name = ', name ! print it
* call FPro_ObjectName(series, 1, name) ! get X cordinate
* write(*,*) 'X = ', name ! print it
* call FPro_ObjectName(series, 2, name) ! get Y cordinate
* write(*,*) 'Y = ', name ! print it
*$ Error_handling:
* Profile library error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if object is NULL or not a profile toolkit
* object.
* PRO_DOMAIN_ERROR if the coord is outside the range 0 to 2.
* FORTRAN_POINTER_ERROR if object is not a valid FORTRAN pointer.
*$ Limitations:
* Object names are limited to 59 characters.
*$ Author_and_institution:
* Mark R. Showalter
* NASA/Ames Research Center
*$ Version_and_date:
* 1.0: March 1998
*$ Change_history:
* none
********************************************************************************
* Note: GPro_RenameObject() defined here is the intermediary routine between
* FPro_RenameObject() and Pro_RenameObject(), allowing for the fact that strings
* cannot be passed directly between FORTRAN and C. See fprofile.for for the
* rest of the code.
*
* subroutine GPro_RenameObject(object, coord, name)
* integer*4 object, coord
* byte name(*)
*******************************************************************************/
void FORTRAN_NAME(gpro_renameobject) (object, coord, name)
RL_INT4 *object, *coord;
RL_CHAR *name;
{
RL_VOID *ptr;
/* Look up object pointer */
ptr = FORT_GetPointer(*object);
if (ptr == NULL) return;
Pro_RenameObject((PRO_OBJECT *) ptr, *coord, name);
}
/*
********************************************************************************
*$ Component_name:
* FPro_ObjectDomain (object.c)
*$ Abstract:
* This routine returns the domain (X-limits) for an object.
*$ Keywords:
* PROFILE
* FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
* real*8 function FPro_ObjectDomain(object, x1, x2)
* integer*4 object
* real*8 x1, x2
*$ Inputs:
* object pointer to the object.
*$ Outputs:
* x1, x2 lower and upper limits of domain (inclusive); unchanged
* on non-fatal error.
*$ Returns:
* size of domain (x2 - x1); 0. on non-fatal error.
*$ Detailed_description:
* This routine returns the domain (X-limits) for an object. It also
* returns the size of the domain.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* none
*$ Examples:
* none
*$ Error_handling:
* Profile library error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if the object is NULL or not a profile object.
* FORTRAN_POINTER_ERROR if 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
* 1.1: October 1999
*$ Change_history:
* 1.1: QUICK mode compile option added.
*******************************************************************************/
RL_FLT8 FORTRAN_NAME(fpro_objectdomain) (object, x1, x2)
RL_INT4 *object;
RL_FLT8 *x1, *x2;
{
RL_VOID *ptr;
/* Look up object pointer */
ptr = FORT_GetPointer(*object);
#ifndef QUICK
if (ptr == NULL) return 0.;
#endif
return Pro_ObjectDomain((PRO_OBJECT *) ptr, x1, x2);
}
/*
********************************************************************************
*$ Component_name:
* FPro_ObjectOverlap (object.c)
*$ Abstract:
* This routine finds the domain of overlap of two or more objects.
*$ Keywords:
* PROFILE
* FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
* subroutine FPro_ObjectOverlap(object, refobj, x1, x2)
* integer*4 object, refobj
* real*8 x1, x2
*$ Inputs:
* object FORTRAN pointer to the object to test for overlap.
* refobj FORTRAN pointer to the reference object (see below).
* x1, x2 current domain limits; ignored if object = refobj.
*$ Outputs:
* x1, x2 updated domain limits.
*$ Returns:
* size of overlapping domain, i.e. (x2 - x1), or 0. on non-fatal error.
*$ Detailed_description:
* This routine finds the domain of overlap of two or more objects. It
* also checks to confirm that the X-coordinate names match.
*
* On the first call to this routine, the object and the reference object
* should be the same. In this case, the domain is saved in x1 and x2.
* On subsequent calls, the first argument should be each new object to
* overlap with the reference object. After the last call, *x1 and *x2
* contain the intersection of all the objects' domains. If at any time
* the intersection becomes empty, an error condition is raised.
*$ External_references:
* Profile toolkit
*$ Side_effects:
* none
*$ Examples:
* Suppose you wish to find the overlapping domain of object1, object2 and
* object3.
*
* real*8 x1, x2
*
* call FPro_ObjectOverlap(object1, object1, x1, x2)
* call FPro_ObjectOverlap(object2, object1, x1, x2)
* call FPro_ObjectOverlap(object3, object1, x1, x2)
*
* At this point, x1 and x2 are the limits of the overlapping domain. If
* any of the X-coordinate names do not match or if the overlapping domain
* is empty, an error condition is raised.
*$ Error_handling:
* Profile toolkit error handling is in effect.
*
* Conditions raised:
* PRO_CLASS_ERROR if object is NULL or not a profile object.
* PRO_COORD_MISMATCH if X-coordinate names of objects do not match.
* PRO_EMPTY_DOMAIN if overlapping domain is empty.
* FORTRAN_POINTER_ERROR if object is not a valid FORTRAN object pointer.
*
* On a non-fatal PRO_COORD_MISMATCH condition, the domain limits are still
* updated and the return is normal. Otherwise, 0. is returned.
*$ Limitations:
* none
*$ Author_and_institution:
* Mark R. Showalter
* NASA/Ames Research Center
*$ Version_and_date:
* 1.0: March 1998
*$ Change_history:
* none
*******************************************************************************/
RL_FLT8 FORTRAN_NAME(fpro_objectoverlap) (object, refobj, x1, x2)
RL_INT4 *object, *refobj;
RL_FLT8 *x1, *x2;
{
RL_VOID *ptr1, *ptr2;
/* Look up object pointers */
ptr1 = FORT_GetPointer(*object);
if (ptr1 == NULL) return 0.;
ptr2 = FORT_GetPointer(*refobj);
if (ptr2 == NULL) return 0.;
/* Call function */
return Pro_ObjectOverlap((PRO_OBJECT *) ptr1, (PRO_OBJECT *) ptr2, x1, x2);
}
/*******************************************************************************
*/