/* fortran.c
********************************************************************************
* fortran.c -- Routines for handling C pointers inside FORTRAN programs.
*
* Programmer routines:
* FORT_Init() initializes C runtime libraries from FORTRAN.
* FORT_AddPointer() saves a C pointer and returns an index.
* FORT_GetPointer() returns the C pointer given the index.
* FORT_FreePointer() removes a C pointer from the list.
*
* Version 1.0: Original release.
* Mark Showalter, PDS Ring-Moon Systems Node, January 1994
* Version 1.1: Updated to support other RingLib components and to allocate more
* memory when needed.
* Mark Showalter, January 1997.
* Version 1.2: QUICK mode compile option added.
* Mark Showalter, October 1999.
*******************************************************************************/
#include "fortran.h"
/* In QUICK mode, the array ZFORT_Pointers becomes global */
#ifdef QUICK
#define STATIC
#else
#define STATIC static
#endif
/* Variables holding C pointers and FORTRAN indices */
static RL_INT4 ZFORT_IndexCount = 0; /* number of pointers in use */
static RL_INT4 ZFORT_ListCount = 0; /* size of tables */
static RL_INT4 *ZFORT_Indices = NULL; /* List of available slots in
* pointer table */
STATIC RL_VOID **ZFORT_Pointers = NULL; /* Pointer table */
#define ZFORT_StepSize 100 /* number of slots to add at one
* time */
/* Protoypes of internal routines */
static RL_BOOL ZFORT_ExpandTable RL_PROTO((RL_INT4 count));
#ifdef VMS
void DECC$CRTL_INIT(void);
#endif
/*
********************************************************************************
*$ Component_name:
* FORT_Init (fortran.c)
*$ Abstract:
* Initializes the FORTRAN interface to a library written in C.
*$ Keywords:
* UTILITY, FORTRAN_C
* C, INTERNAL, SUBROUTINE
*$ Declarations:
* void FORT_Init()
*$ Inputs:
* none
*$ Outputs:
* none
*$ Returns:
* none
*$ Detailed_description:
* This function initializes the FORTRAN interface to a library written in
* C. It initializes the C Runtime Library if necessary.
*$ External_references:
* none
*$ Side_effects:
* none
*$ Examples:
* none
*$ Error_handling:
* none
*$ Limitations:
* none
*$ Author_and_institution:
* Mark R. Showalter
* PDS Ring-Moon Systems Node, NASA/Ames Research Center
*$ Version_and_date:
* 1.0: January 1994
* 1.1: January 1997
*$ Change_history:
* 1.1: Updated to support other RingLib components and to allocate more
* memory when needed.
*******************************************************************************/
void FORT_Init()
{
static RL_BOOL initialized = FALSE;
/* Return immediately if initialization already occurred */
if (initialized) return;
#ifdef VMS
/* Initialize C runtime library if necessary */
DECC$CRTL_INIT();
#endif
/* Avoid further initializations */
initialized = TRUE;
return;
}
/*
********************************************************************************
*$ Component_name:
* FORT_AddPointer (fortran.c)
*$ Abstract:
* Adds the given C pointer to an internal list and returns an integer
* index.
*$ Keywords:
* UTILITY, FORTRAN_C
* C, INTERNAL, SUBROUTINE
*$ Declarations:
* RL_INT4 FORT_AddPointer(pointer)
* RL_VOID *pointer;
*$ Inputs:
* pointer pointer to newly allocated memory.
*$ Outputs:
* none
*$ Returns:
* an integer index to pass back when the pointer is again needed, or zero
* on failure.
*$ Detailed_description:
* This function adds the given C pointer to an internal list and returns
* an integer index. It returns zero on failure.
*
* The value returned serves as an integer "reference" for a pointer.
* Subsequent calls to FORT_GetPointer() with this argument will return
* the desired pointer.
*$ External_references:
* none
*$ Side_effects:
* An internal static array of pointers is modified.
*$ Examples:
* none
*$ Error_handling:
* The routine returns zero on failure. RingLib error handling is also in
* in effect.
*
* RL_MEMORY_ERROR on memory allocation failure.
*$ Limitations:
* None.
*$ Author_and_institution:
* Mark R. Showalter
* PDS Ring-Moon Systems Node, NASA/Ames Research Center
*$ Version_and_date:
* 1.0: January 1994
* 1.1: January 1997
*$ Change_history:
* 1.1: Updated to support other RingLib components and to allocate more
* memory when needed.
*******************************************************************************/
RL_INT4 FORT_AddPointer(pointer)
RL_VOID *pointer;
{
RL_INT4 index;
RL_BOOL status;
/* Expand the table if necessary */
if (ZFORT_IndexCount == ZFORT_ListCount) {
if (ZFORT_ListCount == 0) FORT_Init();
status = ZFORT_ExpandTable(ZFORT_StepSize);
if (!status) return 0;
}
/* Get the next available pointer slot */
index = ZFORT_Indices[ZFORT_IndexCount];
/* Increment the pointer count */
ZFORT_IndexCount++;
/* Save the pointer value in the selected slot */
ZFORT_Pointers[index] = pointer;
/* Return the slot index (offset by one because zero is an error flag) */
return (index+1);
}
/*
********************************************************************************
*$ Component_name:
* FORT_GetPointer (fortran.c)
*$ Abstract:
* Returns the C pointer corresponding to an integer index.
*$ Keywords:
* UTILITY, FORTRAN_C
* C, INTERNAL, SUBROUTINE
*$ Declarations:
* RL_VOID *FORT_GetPointer(index)
* RL_INT4 index;
*$ Inputs:
* index integer index identifying the desired pointer.
*$ Outputs:
* none
*$ Returns:
* the C pointer corresponding to the given index.
*$ Detailed_description:
* This function returns the C pointer corresponding to an integer index.
* If the index is out of range, a NULL is returned.
*$ External_references:
* none
*$ Side_effects:
* none
*$ Examples:
* none
*$ Error_handling:
* If the index is out of range, a NULL is returned and error condition
* FORTRAN_POINTER_ERROR is raised.
*$ Limitations:
* none
*$ Author_and_institution:
* Mark R. Showalter
* PDS Ring-Moon Systems Node, NASA/Ames Research Center
*$ Version_and_date:
* 1.0: January 1994
* 1.1: January 1997
* 1.2: October 1999
*$ Change_history:
* 1.1: Updated to support other RingLib components and to allocate more
* memory when needed.
* 1.2: QUICK mode compile option added.
*******************************************************************************/
#ifndef QUICK /* In QUICK mode, this is defined as a macro in fortran.h */
RL_VOID *FORT_GetPointer(index)
RL_INT4 index;
{
RL_VOID *ptr;
if (index <= 0 || index >= ZFORT_ListCount) ptr = NULL;
else ptr = ZFORT_Pointers[index-1];
if (ptr == NULL) {
RL_RaiseError("FORTRAN_POINTER_ERROR", "invalid FORTRAN pointer");
}
return ptr;
}
#endif
/*
********************************************************************************
*$ Component_name:
* FORT_FreePointer (fortran.c)
*$ Abstract:
* Removes a C pointer from the internal list and frees the index for
* subsequent use.
*$ Keywords:
* UTILITY, FORTRAN_C
* C, INTERNAL, SUBROUTINE
*$ Declarations:
* RL_VOID *FORT_FreePointer(index)
* RL_INT4 index;
*$ Inputs:
* index integer index identifying the desired pointer.
*$ Outputs:
* none
*$ Returns:
* the value of the pointer it has just removed from the list, or NULL on
* error.
*$ Detailed_description:
* This function removes a C pointer from the internal list and frees the
* index for subsequent use.
*$ External_references:
* RingLib
*$ Side_effects:
* An internal static array of pointers is modified.
*$ Examples:
* none
*$ Error_handling:
* If the pointer index is out of range, RingLib error condition
* FORTRAN_POINTER_ERROR is raised and a NULL is returned.
*$ Limitations:
* The program will fail in unexpected ways if one frees an index not
* previously returned by FORT_AddPointer(), or frees the same index more
* than once. It will also fail if one attempts to use an index after it
* has been freed.
*$ Author_and_institution:
* Mark R. Showalter
* PDS Ring-Moon Systems Node, NASA/Ames Research Center
*$ Version_and_date:
* 1.0: January 1994
* 1.1: January 1997
*$ Change_history:
* 1.1: Updated to support other RingLib components and to allocate more
* memory when needed.
*******************************************************************************/
RL_VOID *FORT_FreePointer(index)
RL_INT4 index;
{
RL_VOID *ptr;
/* Check for valid index */
if (index <= 0 || index >= ZFORT_ListCount) {
RL_RaiseError("FORTRAN_POINTER_ERROR", "invalid FORTRAN pointer");
return NULL;
}
/* Decrement the pointer count after testing */
if (ZFORT_IndexCount <= 0) {
RL_RaiseError("FORTRAN_POINTER_ERROR",
"FORTRAN pointer list underflow");
return NULL;
}
ZFORT_IndexCount--;
/* Save the newly-available slot index at the top of the list */
ZFORT_Indices[ZFORT_IndexCount] = index-1;
/* Reset the old pointer value */
ptr = ZFORT_Pointers[index-1];
ZFORT_Pointers[index-1] = NULL;
/* Return the old pointer value */
return ptr;
}
/*
********************************************************************************
* ZFORT_ExpandTable(count)
*
* This internal routine expands the pointer table size by a given number of
* entries.
*
* Inputs:
* count number of elements to add to table.
*
* Return: TRUE on success; FALSE on failure.
*
* Errors:
* RL_MEMORY_ERROR on allocation failure. In this case the pointer
* table is unchanged.
*******************************************************************************/
static RL_BOOL ZFORT_ExpandTable(count)
RL_INT4 count;
{
RL_VOID **temp_pointers;
RL_INT4 *temp_indices;
RL_INT4 temp_listcount, index;
/* Allocate memory for the tables */
if (ZFORT_ListCount == 0) {
temp_listcount = count;
temp_pointers = (RL_VOID **) XRL_Malloc(count * sizeof(RL_VOID *));
temp_indices = (RL_INT4 *) XRL_Malloc(count * sizeof(RL_INT4));
} else {
temp_listcount = ZFORT_ListCount + count;
temp_pointers = (RL_VOID **) XRL_Realloc((RL_VOID *) ZFORT_Pointers,
temp_listcount * sizeof(RL_VOID *));
temp_indices = (RL_INT4 *) XRL_Realloc((RL_VOID *) ZFORT_Indices,
temp_listcount * sizeof(RL_INT4));
}
if (temp_pointers == NULL || temp_indices == NULL) {
XRL_Free((RL_VOID *) temp_pointers);
XRL_Free((RL_VOID *) temp_indices);
return FALSE;
}
/* Update tables */
ZFORT_ListCount = temp_listcount;
ZFORT_Pointers = temp_pointers;
ZFORT_Indices = temp_indices;
for (index = ZFORT_ListCount - count; index < ZFORT_ListCount; index++) {
ZFORT_Indices[index] = index;
ZFORT_Pointers[index] = NULL;
}
return TRUE;
}
/*******************************************************************************
*/