/*
******************************************************************************** * 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); } /********************************************************************************/